From 0cc9f90ccee4a657ffdb6689cdbf56ed00a146c5 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 10 Mar 2023 13:22:20 -0800 Subject: [PATCH 001/250] starting to sketch out how the LUH data will be used in FATES --- biogeochem/EDPatchDynamicsMod.F90 | 57 ++++++++++++++---------- biogeochem/FatesLandUseChangeMod.F90 | 45 +++++++++++++++++++ main/EDTypesMod.F90 | 1 - main/FatesConstantsMod.F90 | 8 ++-- main/FatesInterfaceMod.F90 | 33 +++++++++++++- main/FatesInterfaceTypesMod.F90 | 6 ++- parameter_files/fates_params_default.cdl | 10 +++++ 7 files changed, 131 insertions(+), 29 deletions(-) create mode 100644 biogeochem/FatesLandUseChangeMod.F90 diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 2e85f5e62a..071bf55e2d 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -49,6 +49,8 @@ module EDPatchDynamicsMod use FatesInterfaceTypesMod , only : hlm_use_nocomp use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog use FatesInterfaceTypesMod , only : hlm_num_lu_harvest_cats + use FatesInterfaceTypesMod , only : hlm_num_luh2_states + use FatesInterfaceTypesMod , only : hlm_num_luh2_transitions use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue, ifalse @@ -70,8 +72,9 @@ module EDPatchDynamicsMod use FatesConstantsMod , only : days_per_sec use FatesConstantsMod , only : years_per_day use FatesConstantsMod , only : nearzero - use FatesConstantsMod , only : primaryforest, secondaryforest - use FatesConstantsMod , only : n_anthro_disturbance_categories + use FatesConstantsMod , only : primarylands, secondarylands, pasture_rangelands, crops + use FatesConstantsMod , only : n_landuse_cats + use FatesLandUseChangeMod, only : get_landuse_transition_rates use FatesConstantsMod , only : fates_unset_r8 use FatesConstantsMod , only : fates_unset_int use FatesConstantsMod , only : hlm_harvest_carbon @@ -200,6 +203,7 @@ subroutine disturbance_rates( site_in, bc_in) real(r8) :: tempsum real(r8) :: harvestable_forest_c(hlm_num_lu_harvest_cats) integer :: harvest_tag(hlm_num_lu_harvest_cats) + real(r8) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) !---------------------------------------------------------------------------------------------- ! Calculate Mortality Rates (these were previously calculated during growth derivatives) @@ -258,6 +262,8 @@ subroutine disturbance_rates( site_in, bc_in) call get_harvest_debt(site_in, bc_in, harvest_tag) + call get_landuse_transition_rates(site_in, bc_in, landuse_transition_matrix) + ! --------------------------------------------------------------------------------------------- ! Calculate Disturbance Rates based on the mortality rates just calculated ! --------------------------------------------------------------------------------------------- @@ -495,7 +501,7 @@ subroutine spawn_patches( currentSite, bc_in) ! figure out whether the receiver patch for disturbance from this patch will be ! primary or secondary land receiver patch is primary forest only if both the ! donor patch is primary forest and the current disturbance type is not logging - if ( currentPatch%anthro_disturbance_label .eq. primaryforest .and. & + if ( currentPatch%anthro_disturbance_label .eq. primarylands .and. & (i_disturbance_type .ne. dtype_ilog) ) then site_areadis_primary = site_areadis_primary + currentPatch%area * disturbance_rate @@ -509,7 +515,7 @@ subroutine spawn_patches( currentSite, bc_in) site_areadis_secondary = site_areadis_secondary + currentPatch%area * disturbance_rate ! track disturbance rates to output to history - if (currentPatch%anthro_disturbance_label .eq. secondaryforest) then + if (currentPatch%anthro_disturbance_label .eq. secondarylands) then currentSite%disturbance_rates_secondary_to_secondary(i_disturbance_type) = & currentSite%disturbance_rates_secondary_to_secondary(i_disturbance_type) + & currentPatch%area * disturbance_rate * AREA_INV @@ -539,7 +545,7 @@ subroutine spawn_patches( currentSite, bc_in) allocate(new_patch_primary) call create_patch(currentSite, new_patch_primary, age, & - site_areadis_primary, primaryforest, i_nocomp_pft) + site_areadis_primary, primarylands, i_nocomp_pft) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -561,7 +567,7 @@ subroutine spawn_patches( currentSite, bc_in) if ( site_areadis_secondary .gt. nearzero) then allocate(new_patch_secondary) call create_patch(currentSite, new_patch_secondary, age, & - site_areadis_secondary, secondaryforest,i_nocomp_pft) + site_areadis_secondary, secondarylands,i_nocomp_pft) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -601,7 +607,7 @@ subroutine spawn_patches( currentSite, bc_in) ! will be primary or secondary land receiver patch is primary forest ! only if both the donor patch is primary forest and the current ! disturbance type is not logging - if (currentPatch%anthro_disturbance_label .eq. primaryforest .and. & + if (currentPatch%anthro_disturbance_label .eq. primarylands .and. & (i_disturbance_type .ne. dtype_ilog)) then new_patch => new_patch_primary else @@ -618,7 +624,7 @@ subroutine spawn_patches( currentSite, bc_in) ! the current disturbance from this patch is non-anthropogenic, ! we need to average in the time-since-anthropogenic-disturbance ! from the donor patch into that of the receiver patch - if ( currentPatch%anthro_disturbance_label .eq. secondaryforest .and. & + if ( currentPatch%anthro_disturbance_label .eq. secondarylands .and. & (i_disturbance_type .ne. dtype_ilog) ) then new_patch%age_since_anthro_disturbance = new_patch%age_since_anthro_disturbance + & @@ -1156,12 +1162,12 @@ subroutine spawn_patches( currentSite, bc_in) currentPatch => currentSite%youngest_patch ! insert new youngest primary patch after all the secondary patches, if there are any. ! this requires first finding the current youngest primary to insert the new one ahead of - if (currentPatch%anthro_disturbance_label .eq. secondaryforest ) then + if (currentPatch%anthro_disturbance_label .eq. secondarylands ) then found_youngest_primary = .false. do while(associated(currentPatch) .and. .not. found_youngest_primary) currentPatch => currentPatch%older if (associated(currentPatch)) then - if (currentPatch%anthro_disturbance_label .eq. primaryforest) then + if (currentPatch%anthro_disturbance_label .eq. primarylands) then found_youngest_primary = .true. endif endif @@ -2139,7 +2145,7 @@ subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) ! assign anthropgenic disturbance category and label new_patch%anthro_disturbance_label = label - if (label .eq. secondaryforest) then + if (label .eq. secondarylands) then new_patch%age_since_anthro_disturbance = age else new_patch%age_since_anthro_disturbance = fates_unset_r8 @@ -2329,14 +2335,14 @@ subroutine fuse_patches( csite, bc_in ) integer :: ft,z !counters for pft and height class real(r8) :: norm !normalized difference between biomass profiles real(r8) :: profiletol !tolerance of patch fusion routine. Starts off high and is reduced if there are too many patches. - integer :: nopatches(n_anthro_disturbance_categories) !number of patches presently in gridcell + integer :: nopatches(n_landuse_cats) !number of patches presently in gridcell integer :: iterate !switch of patch reduction iteration scheme. 1 to keep going, 0 to stop integer :: fuse_flag !do patches get fused (1) or not (0). integer :: i_disttype !iterator over anthropogenic disturbance categories integer :: i_pftlabel !nocomp pft iterator real(r8) :: primary_land_fraction_beforefusion,primary_land_fraction_afterfusion integer :: pftlabelmin, pftlabelmax - real(r8) :: maxpatches(n_anthro_disturbance_categories) + real(r8) :: maxpatches(n_landuse_cats) ! !--------------------------------------------------------------------- @@ -2347,23 +2353,28 @@ subroutine fuse_patches( csite, bc_in ) primary_land_fraction_beforefusion = 0._r8 primary_land_fraction_afterfusion = 0._r8 - nopatches(1:n_anthro_disturbance_categories) = 0 + nopatches(1:n_landuse_cats) = 0 ! Its possible that, in nocomp modes, there are more categorically distinct patches than we allow as ! primary patches in non-nocomp mode. So if this is the case, bump up the maximum number of primary patches ! to let there be one for each type of nocomp PFT on the site. this is likely to lead to problems ! if anthropogenic disturance is enabled. if (hlm_use_nocomp.eq.itrue) then - maxpatches(primaryforest) = max(maxpatch_primary, sum(csite%use_this_pft)) - maxpatches(secondaryforest) = maxpatch_total - maxpatches(primaryforest) - if (maxpatch_total .lt. maxpatches(primaryforest)) then + !!cdk this logic for how many patcehs to allow in nocomp will need to be changed + maxpatches(primarylands) = max(maxpatch_primary, sum(csite%use_this_pft)) + maxpatches(crops) = maxpatch_crops + maxpatches(pasture_rangelands) = maxpatch_pasture_range + maxpatches(secondarylands) = maxpatch_total - maxpatches(primarylands) - maxpatches(crops) - maxpatches(pasture_rangelands) + if (maxpatch_total .lt. maxpatches(primarylands)) then write(fates_log(),*) 'too many PFTs and not enough patches for nocomp w/o fixed biogeog' write(fates_log(),*) 'maxpatch_total,numpft',maxpatch_total,numpft, sum(csite%use_this_pft) call endrun(msg=errMsg(sourcefile, __LINE__)) endif else - maxpatches(primaryforest) = maxpatch_primary - maxpatches(secondaryforest) = maxpatch_secondary + maxpatches(primarylands) = maxpatch_primary + maxpatches(secondarylands) = maxpatch_secondary + maxpatches(crops) = maxpatch_crops + maxpatches(pasture_rangelands) = maxpatch_pasture_range endif currentPatch => currentSite%youngest_patch @@ -2371,7 +2382,7 @@ subroutine fuse_patches( csite, bc_in ) nopatches(currentPatch%anthro_disturbance_label) = & nopatches(currentPatch%anthro_disturbance_label) + 1 - if (currentPatch%anthro_disturbance_label .eq. primaryforest) then + if (currentPatch%anthro_disturbance_label .eq. primarylands) then primary_land_fraction_beforefusion = primary_land_fraction_beforefusion + & currentPatch%area * AREA_INV endif @@ -2390,7 +2401,7 @@ subroutine fuse_patches( csite, bc_in ) ! iterate over anthropogenic disturbance categories !---------------------------------------------------------------------! - disttype_loop: do i_disttype = 1, n_anthro_disturbance_categories + disttype_loop: do i_disttype = 1, n_landuse_cats !---------------------------------------------------------------------! ! We only really care about fusing patches if nopatches > 1 ! @@ -2605,7 +2616,7 @@ subroutine fuse_patches( csite, bc_in ) currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - if (currentPatch%anthro_disturbance_label .eq. primaryforest) then + if (currentPatch%anthro_disturbance_label .eq. primarylands) then primary_land_fraction_afterfusion = primary_land_fraction_afterfusion + & currentPatch%area * AREA_INV endif @@ -3182,7 +3193,7 @@ subroutine get_frac_site_primary(site_in, frac_site_primary) frac_site_primary = 0._r8 currentPatch => site_in%oldest_patch do while (associated(currentPatch)) - if (currentPatch%anthro_disturbance_label .eq. primaryforest) then + if (currentPatch%anthro_disturbance_label .eq. primarylands) then frac_site_primary = frac_site_primary + currentPatch%area * AREA_INV endif currentPatch => currentPatch%younger diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 new file mode 100644 index 0000000000..7d88217b07 --- /dev/null +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -0,0 +1,45 @@ +module FatesLandUseChangeMod + + ! Controls the transfer and initialization of patch structure to land use types + + use FatesGlobals , only : fates_log + use FatesConstantsMod , only : primarylands, secondarylands, pasture_rangelands, crops + use FatesConstantsMod , only : n_landuse_cats + use FatesGlobals , only : endrun => fates_endrun + use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : itrue, ifalse + use FatesInterfaceTypesMod , only : bc_in_type + use EDTypesMod , only : area_site => area + + ! CIME globals + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use shr_log_mod , only : errMsg => shr_log_errMsg + + ! + implicit none + private + ! + public :: get_landuse_transition_rates + + ! 03/10/2023 Created By Charlie Koven + ! ============================================================================ + +contains + + ! ============================================================================ + subroutine get_landuse_transition_rates(site_in, bc_in, landuse_transition_matrix) + + + ! The purpose of this routine is to ingest the land use transition rate information that the host model has read in from a dataset, + ! aggregate land use types to those being used in the simulation, and output a transition matrix that can be used to drive patch + ! disturbance rates. + + ! !ARGUMENTS: + type(ed_site_type) , intent(in) :: site_in + type(bc_in_type) , intent(in) :: bc_in + + + end subroutine get_landuse_transition_rates + + +end module FatesLandUseChangeMod diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index dcc6ea7bc6..22099387e4 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -16,7 +16,6 @@ module EDTypesMod use PRTGenericMod, only : carbon12_element use FatesLitterMod, only : litter_type use FatesLitterMod, only : ncwd - use FatesConstantsMod, only : n_anthro_disturbance_categories use FatesConstantsMod, only : days_per_year use FatesConstantsMod, only : fates_unset_r8 use FatesRunningMeanMod, only : rmean_type diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 66a9c56d8d..da97bc731c 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -31,9 +31,11 @@ module FatesConstantsMod integer, parameter, public :: ifalse = 0 ! Labels for patch disturbance history - integer, parameter, public :: n_anthro_disturbance_categories = 2 - integer, parameter, public :: primaryforest = 1 - integer, parameter, public :: secondaryforest = 2 + integer, parameter, public :: n_landuse_cats = 4 + integer, parameter, public :: primarylands = 1 + integer, parameter, public :: secondarylands = 2 + integer, parameter, public :: pasture_rangelands = 3 + integer, parameter, public :: crops = 4 ! Bareground label for no competition mode integer, parameter, public :: nocomp_bareground = 0 diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index b314073e60..1994e75025 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -379,7 +379,8 @@ end subroutine zero_bcs ! =========================================================================== - subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats,natpft_lb,natpft_ub) + subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats, num_luh2_states, & + num_luh2_transitions, natpft_lb,natpft_ub) ! --------------------------------------------------------------------------------- ! Allocate and Initialze the FATES boundary condition vectors @@ -390,6 +391,8 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats, integer,intent(in) :: nlevsoil_in integer,intent(in) :: nlevdecomp_in integer,intent(in) :: num_lu_harvest_cats + integer,intent(in) :: num_luh2_states + integer,intent(in) :: num_luh2_transitions integer,intent(in) :: natpft_lb,natpft_ub ! dimension bounds of the array holding surface file pft data ! Allocate input boundaries @@ -535,6 +538,10 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats, if (hlm_use_lu_harvest .gt. 0) then allocate(bc_in%hlm_harvest_rates(num_lu_harvest_cats)) allocate(bc_in%hlm_harvest_catnames(num_lu_harvest_cats)) + allocate(bc_in%hlm_luh_states(num_luh2_states)) + allocate(bc_in%hlm_luh_state_names(num_luh2_states)) + allocate(bc_in%hlm_luh_transitions(num_luh2_transitions)) + allocate(bc_in%hlm_luh_transition_names(num_luh2_transitions)) else ! LoggingMortality_frac needs these passed to it regardless of harvest allocate(bc_in%hlm_harvest_rates(0)) allocate(bc_in%hlm_harvest_catnames(0)) @@ -1392,6 +1399,8 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) hlm_use_planthydro = unset_int hlm_use_lu_harvest = unset_int hlm_num_lu_harvest_cats = unset_int + hlm_num_luh2_states = unset_int + hlm_num_luh2_transitions = unset_int hlm_use_cohort_age_tracking = unset_int hlm_use_logging = unset_int hlm_use_ed_st3 = unset_int @@ -1448,6 +1457,16 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if ( (hlm_num_luh2_states .lt. 0) ) then + write(fates_log(), *) 'The FATES number of hlm luh state cats must be >= 0, exiting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if ( (hlm_num_luh2_transitions .lt. 0) ) then + write(fates_log(), *) 'The FATES number of hlm luh state transition cats must be >= 0, exiting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if ( .not.((hlm_use_logging .eq.1).or.(hlm_use_logging.eq.0)) ) then write(fates_log(), *) 'The FATES namelist use_logging flag must be 0 or 1, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1814,6 +1833,18 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering hlm_num_lu_harvest_cats= ',ival,' to FATES' end if + case('num_luh2_states') + hlm_num_luh2_states = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_num_luh2_states= ',ival,' to FATES' + end if + + case('num_luh2_transitions') + hlm_num_luh2_transitions = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_num_luh2_transitions= ',ival,' to FATES' + end if + case('use_cohort_age_tracking') hlm_use_cohort_age_tracking = ival if (fates_global_verbose()) then diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index e6aedc08f7..0084ce2259 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -527,8 +527,12 @@ module FatesInterfaceTypesMod ! Land use ! --------------------------------------------------------------------------------- real(r8),allocatable :: hlm_harvest_rates(:) ! annual harvest rate per cat from hlm for a site - character(len=64), allocatable :: hlm_harvest_catnames(:) ! names of hlm_harvest d1 + real(r8),allocatable :: hlm_luh_states(:) + character(len=64),allocatable :: hlm_luh_state_names(:) + real(r8),allocatable :: hlm_luh_transitions(:) + character(len=64),allocatable :: hlm_luh_transition_names(:) + integer :: hlm_harvest_units ! what units are the harvest rates specified in? [area vs carbon] diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index c5ddba36c6..b65900ce99 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -725,6 +725,12 @@ variables: double fates_maxcohort ; fates_maxcohort:units = "count" ; fates_maxcohort:long_name = "maximum number of cohorts per patch. Actual number of cohorts also depend on cohort fusion tolerances" ; + double fates_maxpatch_crops ; + fates_maxpatch_crops:units = "count" ; + fates_maxpatch_crops:long_name = "maximum number of crop patches per site" ; + double fates_maxpatch_pasture_range ; + fates_maxpatch_pasture_range:units = "count" ; + fates_maxpatch_pasture_rangey:long_name = "maximum number of combined pasture and rangeland patches per site" ; double fates_maxpatch_primary ; fates_maxpatch_primary:units = "count" ; fates_maxpatch_primary:long_name = "maximum number of primary vegetation patches per site" ; @@ -1497,6 +1503,10 @@ data: fates_maxcohort = 100 ; + fates_maxpatch_crops = 1 ; + + fates_maxpatch_pasture_rangeland = 1 ; + fates_maxpatch_primary = 10 ; fates_maxpatch_secondary = 4 ; From ece80ee7628fff7be7cf6f2937a46c2946217969 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Sat, 11 Mar 2023 13:27:36 -0800 Subject: [PATCH 002/250] more sketching out of land use change in FATES --- biogeochem/EDPatchDynamicsMod.F90 | 10 ++-- biogeochem/FatesLandUseChangeMod.F90 | 71 +++++++++++++++++++++++- main/FatesConstantsMod.F90 | 11 ++-- main/FatesInterfaceTypesMod.F90 | 4 ++ parameter_files/fates_params_default.cdl | 13 +++-- 5 files changed, 93 insertions(+), 16 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 071bf55e2d..48615c6fc5 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -262,7 +262,7 @@ subroutine disturbance_rates( site_in, bc_in) call get_harvest_debt(site_in, bc_in, harvest_tag) - call get_landuse_transition_rates(site_in, bc_in, landuse_transition_matrix) + call get_landuse_transition_rates(bc_in, landuse_transition_matrix) ! --------------------------------------------------------------------------------------------- ! Calculate Disturbance Rates based on the mortality rates just calculated @@ -2363,8 +2363,9 @@ subroutine fuse_patches( csite, bc_in ) !!cdk this logic for how many patcehs to allow in nocomp will need to be changed maxpatches(primarylands) = max(maxpatch_primary, sum(csite%use_this_pft)) maxpatches(crops) = maxpatch_crops - maxpatches(pasture_rangelands) = maxpatch_pasture_range - maxpatches(secondarylands) = maxpatch_total - maxpatches(primarylands) - maxpatches(crops) - maxpatches(pasture_rangelands) + maxpatches(pasture) = maxpatch_pasture + maxpatches(rangelands) = maxpatch_rangeland + maxpatches(secondarylands) = maxpatch_total - maxpatches(primarylands) - maxpatches(crops) - maxpatches(pasture) - maxpatches(rangelands) if (maxpatch_total .lt. maxpatches(primarylands)) then write(fates_log(),*) 'too many PFTs and not enough patches for nocomp w/o fixed biogeog' write(fates_log(),*) 'maxpatch_total,numpft',maxpatch_total,numpft, sum(csite%use_this_pft) @@ -2374,7 +2375,8 @@ subroutine fuse_patches( csite, bc_in ) maxpatches(primarylands) = maxpatch_primary maxpatches(secondarylands) = maxpatch_secondary maxpatches(crops) = maxpatch_crops - maxpatches(pasture_rangelands) = maxpatch_pasture_range + maxpatches(pasture) = maxpatch_pasture + maxpatches(rangelands) = maxpatch_rangeland endif currentPatch => currentSite%youngest_patch diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index 7d88217b07..8a0fbd4918 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -3,12 +3,13 @@ module FatesLandUseChangeMod ! Controls the transfer and initialization of patch structure to land use types use FatesGlobals , only : fates_log - use FatesConstantsMod , only : primarylands, secondarylands, pasture_rangelands, crops + use FatesConstantsMod , only : primarylands, secondarylands, pasture, rangelands, crops use FatesConstantsMod , only : n_landuse_cats use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue, ifalse use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : hlm_num_luh2_transitions use EDTypesMod , only : area_site => area ! CIME globals @@ -20,6 +21,11 @@ module FatesLandUseChangeMod private ! public :: get_landuse_transition_rates + public :: init_luh2_fates_mapping + + ! module data + integer :: max_luh2_types_per_fates_lu_type = 5 + CHARACTER(len = 5), protected, DIMENSION(n_landuse_cats,max_luh2_types_per_fates_lu_type) :: luh2_fates_luype_map ! 03/10/2023 Created By Charlie Koven ! ============================================================================ @@ -27,7 +33,7 @@ module FatesLandUseChangeMod contains ! ============================================================================ - subroutine get_landuse_transition_rates(site_in, bc_in, landuse_transition_matrix) + subroutine get_landuse_transition_rates(bc_in, landuse_transition_matrix) ! The purpose of this routine is to ingest the land use transition rate information that the host model has read in from a dataset, @@ -35,11 +41,70 @@ subroutine get_landuse_transition_rates(site_in, bc_in, landuse_transition_matri ! disturbance rates. ! !ARGUMENTS: - type(ed_site_type) , intent(in) :: site_in type(bc_in_type) , intent(in) :: bc_in + real(r8), intent(inout) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) + + ! !LOCAL VARIABLES: + integer :: i_donor, i_receiver, i_luh2_transitions + character(5) :: donor_name, receiver_name + character(14) :: transition_name + + ! zero the transition matrix + landuse_transition_matrix(:,:) = 0._r8 + + ! loop over FATES donor and receiver land use types + do i_donor = 1,n_landuse_cats + do i_receiver = 1,n_landuse_cats + + ! ignore diagonals of transition matrix + if ( i_donor .ne. i_receiver ) then + + ! ignore special case of primary -> secondary, which is handled by harvest mechanism + if ( .not. ((i_donor .eq. primarylands) .and. (i_receiver .eq. secondarylands)) ) then + + do i_luh2_transitions = 1, hlm_num_luh2_transitions + + ! transition names are written in form xxxxx_to_yyyyy where x and y are donor and receiver state names + transition_name = bc_in%hlm_luh_transition_names(i_luh2_transitions) + donor_name = transition_name(1:5) + receiver_name = transition_name(10:14) + if (any(luh2_fates_luype_map(:,i_donor) == donor_name) .and. & + any(luh2_fates_luype_map(:,i_receiver) == receiver_name)) then + + landuse_transition_matrix(i_donor,i_receiver) = & + landuse_transition_matrix(i_donor,i_receiver) + bc_in%hlm_luh_transitions(i_luh2_transitions) + + end if + end do + end if + end if + end do + end do end subroutine get_landuse_transition_rates + subroutine init_luh2_fates_mapping + + ! initialize the character mapping of the LUH2 : FATES correspondance + luh2_fates_luype_map(:,:) = '' + + luh2_fates_luype_map(1,primarylands) = 'primf' + luh2_fates_luype_map(2,primarylands) = 'primn' + + luh2_fates_luype_map(1,secondarylands) = 'secdf' + luh2_fates_luype_map(2,secondarylands) = 'secdn' + + luh2_fates_luype_map(1,crops) = 'c3ann' + luh2_fates_luype_map(2,crops) = 'c4ann' + luh2_fates_luype_map(3,crops) = 'c3per' + luh2_fates_luype_map(4,crops) = 'c4per' + luh2_fates_luype_map(5,crops) = 'c3nfx' + + luh2_fates_luype_map(1,pasture) = 'pastr' + + luh2_fates_luype_map(1,rangelands) = 'range' + + end subroutine init_luh2_fates_mapping end module FatesLandUseChangeMod diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 671e72e57c..6f698f61d5 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -31,11 +31,12 @@ module FatesConstantsMod integer, parameter, public :: ifalse = 0 ! Labels for patch disturbance history - integer, parameter, public :: n_landuse_cats = 4 - integer, parameter, public :: primarylands = 1 - integer, parameter, public :: secondarylands = 2 - integer, parameter, public :: pasture_rangelands = 3 - integer, parameter, public :: crops = 4 + integer, parameter, public :: n_landuse_cats = 5 + integer, parameter, public :: primaryland = 1 + integer, parameter, public :: secondaryland = 2 + integer, parameter, public :: rangeland = 3 + integer, parameter, public :: pasture = 4 + integer, parameter, public :: cropland = 5 ! Bareground label for no competition mode integer, parameter, public :: nocomp_bareground = 0 diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 0084ce2259..8598c617eb 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -120,6 +120,10 @@ module FatesInterfaceTypesMod ! harvest_rates in dynHarvestMod ! bc_in%hlm_harvest_rates and bc_in%hlm_harvest_catnames + integer, public :: hlm_num_luh2_states ! number of land use state types provided in LUH2 forcing dataset + + integer, public :: hlm_num_luh2_transitions ! number of land use transition types provided in LUH2 forcing dataset + integer, public :: hlm_sf_nofire_def ! Definition of a no-fire case for hlm_spitfire_mode integer, public :: hlm_sf_scalar_lightning_def ! Definition of a scalar-lightning case for hlm_spitfire_mode diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 9551c04493..8507c983f2 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -734,9 +734,12 @@ variables: double fates_maxpatch_crops ; fates_maxpatch_crops:units = "count" ; fates_maxpatch_crops:long_name = "maximum number of crop patches per site" ; - double fates_maxpatch_pasture_range ; - fates_maxpatch_pasture_range:units = "count" ; - fates_maxpatch_pasture_rangey:long_name = "maximum number of combined pasture and rangeland patches per site" ; + double fates_maxpatch_pasture ; + fates_maxpatch_pasture:units = "count" ; + fates_maxpatch_pasture:long_name = "maximum number of pasture patches per site" ; + double fates_maxpatch_rangeland ; + fates_maxpatch_rangeland:units = "count" ; + fates_maxpatch_rangeland:long_name = "maximum number of rangeland patches per site" ; double fates_maxpatch_primary ; fates_maxpatch_primary:units = "count" ; fates_maxpatch_primary:long_name = "maximum number of primary vegetation patches per site" ; @@ -1518,10 +1521,12 @@ data: fates_maxpatch_crops = 1 ; - fates_maxpatch_pasture_rangeland = 1 ; + fates_maxpatch_pasture = 1 ; fates_maxpatch_primary = 10 ; + fates_maxpatch_rangeland = 1 ; + fates_maxpatch_secondary = 4 ; fates_mort_disturb_frac = 1 ; From 8bedc2b6beb70d68528787227dff6914c46e55e2 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Sun, 26 Mar 2023 17:49:59 -0700 Subject: [PATCH 003/250] more landuse --- biogeochem/EDPatchDynamicsMod.F90 | 4 +++- biogeochem/FatesLandUseChangeMod.F90 | 16 +++++++++++++--- main/EDTypesMod.F90 | 6 +++++- 3 files changed, 21 insertions(+), 5 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 48615c6fc5..0c99086d46 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -203,7 +203,7 @@ subroutine disturbance_rates( site_in, bc_in) real(r8) :: tempsum real(r8) :: harvestable_forest_c(hlm_num_lu_harvest_cats) integer :: harvest_tag(hlm_num_lu_harvest_cats) - real(r8) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) + real(r8) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) ! [m2/m2/year] !---------------------------------------------------------------------------------------------- ! Calculate Mortality Rates (these were previously calculated during growth derivatives) @@ -264,6 +264,8 @@ subroutine disturbance_rates( site_in, bc_in) call get_landuse_transition_rates(bc_in, landuse_transition_matrix) + site_in%landuse_transition_matrix = landuse_transition_matrix + ! --------------------------------------------------------------------------------------------- ! Calculate Disturbance Rates based on the mortality rates just calculated ! --------------------------------------------------------------------------------------------- diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index 8a0fbd4918..e31c845064 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -42,16 +42,26 @@ subroutine get_landuse_transition_rates(bc_in, landuse_transition_matrix) ! !ARGUMENTS: type(bc_in_type) , intent(in) :: bc_in - real(r8), intent(inout) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) + real(r8), intent(inout) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) ! [m2/m2/year] ! !LOCAL VARIABLES: - integer :: i_donor, i_receiver, i_luh2_transitions + integer :: i_donor, i_receiver, i_luh2_transitions, i_luh2_states character(5) :: donor_name, receiver_name character(14) :: transition_name + real(r8) :: urban_fraction ! zero the transition matrix landuse_transition_matrix(:,:) = 0._r8 + !!may need some logic here to ask whether or not ot perform land use cahnge on this timestep. current code occurs every day. + + ! identify urban fraction so that it can be removed. + urban_fraction = 0._r8 + do i_luh2_states = 1, hlm_num_luh2_states + if (bc_in%hlm_luh_state_names(i_luh2_states) .eq. 'urban') then + urban_fraction = bc_in%hlm_luh_states(i_luh2_states) + end do + ! loop over FATES donor and receiver land use types do i_donor = 1,n_landuse_cats do i_receiver = 1,n_landuse_cats @@ -73,7 +83,7 @@ subroutine get_landuse_transition_rates(bc_in, landuse_transition_matrix) any(luh2_fates_luype_map(:,i_receiver) == receiver_name)) then landuse_transition_matrix(i_donor,i_receiver) = & - landuse_transition_matrix(i_donor,i_receiver) + bc_in%hlm_luh_transitions(i_luh2_transitions) + landuse_transition_matrix(i_donor,i_receiver) + bc_in%hlm_luh_transitions(i_luh2_transitions) / (1._r8 - urban_fraction) end if end do diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index ec6f31ec13..09297b5f4c 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -21,6 +21,8 @@ module EDTypesMod use FatesRunningMeanMod, only : rmean_type use FatesInterfaceTypesMod,only : bc_in_type use FatesInterfaceTypesMod,only : bc_out_type + use FatesConstantsMod , only : n_landuse_cats + implicit none private ! By default everything is private @@ -897,7 +899,9 @@ module EDTypesMod real(r8) :: disturbance_rates_secondary_to_secondary(N_DIST_TYPES) ! actual disturbance rates from secondary patches to secondary patches [m2/m2/day] real(r8) :: potential_disturbance_rates(N_DIST_TYPES) ! "potential" disturb rates (i.e. prior to the "which is most" logic) [m2/m2/day] real(r8) :: primary_land_patchfusion_error ! error term in total area of primary patches associated with patch fusion [m2/m2/day] - + + real(r8) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) ! land use transition matrix as read in from HLM and aggregated to FATES land use types [m2/m2/year] + end type ed_site_type ! Make public necessary subroutines and functions From 8c942e8d3b2d4b9631ac28a66f6fcaafdeeedca8 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Mon, 27 Mar 2023 10:12:57 -0700 Subject: [PATCH 004/250] reorganized disturbance loop in spawn patches to avoid need for multiple receiver patches --- biogeochem/EDPatchDynamicsMod.F90 | 1125 ++++++++++++++--------------- 1 file changed, 534 insertions(+), 591 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 0c99086d46..83ba5a8300 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -411,7 +411,7 @@ subroutine spawn_patches( currentSite, bc_in) ! 10) Area checked, and patchno recalculated. ! ! !USES: - + use EDParamsMod , only : ED_val_understorey_death, logging_coll_under_frac use EDCohortDynamicsMod , only : zero_cohort, copy_cohort, terminate_cohorts use FatesConstantsMod , only : rsnbl_math_prec @@ -445,7 +445,7 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: struct_c ! structure carbon [kg] real(r8) :: total_c ! total carbon of plant [kg] real(r8) :: leaf_burn_frac ! fraction of leaves burned in fire - ! for both woody and grass species + ! for both woody and grass species real(r8) :: leaf_m ! leaf mass during partial burn calculations logical :: found_youngest_primary ! logical for finding the first primary forest patch integer :: min_nocomp_pft, max_nocomp_pft, i_nocomp_pft @@ -478,112 +478,78 @@ subroutine spawn_patches( currentSite, bc_in) disturbance_type_loop: do i_disturbance_type = 1,N_DIST_TYPES - ! calculate area of disturbed land, in this timestep, by summing contributions from each existing patch. - currentPatch => currentSite%youngest_patch + landuse_type_loop: do i_landuse_type = 1, n_landuse_cats - site_areadis_primary = 0.0_r8 - site_areadis_secondary = 0.0_r8 + ! calculate area of disturbed land, in this timestep, by summing contributions from each existing patch. + currentPatch => currentSite%youngest_patch - do while(associated(currentPatch)) + site_areadis = 0.0_r8 - cp_nocomp_matches_1_if: if ( hlm_use_nocomp .eq. ifalse .or. & - currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then + ! figure out what land use label the receiver patch for disturbance from patches with + ! this disturbance label and disturbance of this type will have + if ( i_disturbance_type .eq. dtype_ilog) then + receiver_patch_lu_label = secondarylands + else + receiver_patch_lu_label = i_landuse_type + endif - disturbance_rate = currentPatch%disturbance_rates(i_disturbance_type) + patchloop: do while(associated(currentPatch)) - if(disturbance_rate > (1.0_r8 + rsnbl_math_prec)) then - write(fates_log(),*) 'patch disturbance rate > 1 ?',disturbance_rate - call dump_patch(currentPatch) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + cp_nocomp_matches_1_if: if ( hlm_use_nocomp .eq. ifalse .or. & + currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then - ! Only create new patches that have non-negligible amount of land - if((currentPatch%area*disturbance_rate) > nearzero ) then + patchlabel_matches_lutype_if: if (currentPatch%anthro_disturbance_label .eq. i_landuse_type) then - ! figure out whether the receiver patch for disturbance from this patch will be - ! primary or secondary land receiver patch is primary forest only if both the - ! donor patch is primary forest and the current disturbance type is not logging - if ( currentPatch%anthro_disturbance_label .eq. primarylands .and. & - (i_disturbance_type .ne. dtype_ilog) ) then + disturbance_rate = currentPatch%disturbance_rates(i_disturbance_type) - site_areadis_primary = site_areadis_primary + currentPatch%area * disturbance_rate + if(disturbance_rate > (1.0_r8 + rsnbl_math_prec)) then + write(fates_log(),*) 'patch disturbance rate > 1 ?',disturbance_rate + call dump_patch(currentPatch) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - ! track disturbance rates to output to history - currentSite%disturbance_rates_primary_to_primary(i_disturbance_type) = & - currentSite%disturbance_rates_primary_to_primary(i_disturbance_type) + & - currentPatch%area * disturbance_rate * AREA_INV + ! Only create new patches that have non-negligible amount of land + if((currentPatch%area*disturbance_rate) > nearzero ) then - else - site_areadis_secondary = site_areadis_secondary + currentPatch%area * disturbance_rate + site_areadis = site_areadis + currentPatch%area * disturbance_rate - ! track disturbance rates to output to history - if (currentPatch%anthro_disturbance_label .eq. secondarylands) then - currentSite%disturbance_rates_secondary_to_secondary(i_disturbance_type) = & - currentSite%disturbance_rates_secondary_to_secondary(i_disturbance_type) + & + ! track disturbance rates to output to history + currentSite%disturbance_rates(i_disturbance_type) = & + currentSite%disturbance_rates(i_disturbance_type) + & currentPatch%area * disturbance_rate * AREA_INV - else - currentSite%disturbance_rates_primary_to_secondary(i_disturbance_type) = & - currentSite%disturbance_rates_primary_to_secondary(i_disturbance_type) + & - currentPatch%area * disturbance_rate * AREA_INV - endif - - endif - - end if - end if cp_nocomp_matches_1_if - currentPatch => currentPatch%older - enddo ! end loop over patches. sum area disturbed for all patches. - - ! It is possible that no disturbance area was generated - if ( (site_areadis_primary + site_areadis_secondary) > nearzero) then - - age = 0.0_r8 + end if - ! create two empty patches, to absorb newly disturbed primary and secondary forest area - ! first create patch to receive primary forest area - if ( site_areadis_primary .gt. nearzero ) then - allocate(new_patch_primary) + end if patchlabel_matches_lutype_if + end if cp_nocomp_matches_1_if + currentPatch => currentPatch%older + enddo patchloop ! end loop over patches. sum area disturbed for all patches. - call create_patch(currentSite, new_patch_primary, age, & - site_areadis_primary, primarylands, i_nocomp_pft) + ! It is possible that no disturbance area was generated + if ( site_areadis > nearzero) then - ! Initialize the litter pools to zero, these - ! pools will be populated by looping over the existing patches - ! and transfering in mass - do el=1,num_elements - call new_patch_primary%litter(el)%InitConditions(init_leaf_fines=0._r8, & - init_root_fines=0._r8, & - init_ag_cwd=0._r8, & - init_bg_cwd=0._r8, & - init_seed=0._r8, & - init_seed_germ=0._r8) - end do - new_patch_primary%tallest => null() - new_patch_primary%shortest => null() + age = 0.0_r8 - endif + ! create an empty patch, to absorb newly disturbed area + allocate(new_patch) - ! next create patch to receive secondary forest area - if ( site_areadis_secondary .gt. nearzero) then - allocate(new_patch_secondary) - call create_patch(currentSite, new_patch_secondary, age, & - site_areadis_secondary, secondarylands,i_nocomp_pft) + call create_patch(currentSite, new_patch, age, & + site_areadis, receiver_patch_lu_label, i_nocomp_pft) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches ! and transfering in mass do el=1,num_elements - call new_patch_secondary%litter(el)%InitConditions(init_leaf_fines=0._r8, & + call new_patch%litter(el)%InitConditions(init_leaf_fines=0._r8, & init_root_fines=0._r8, & init_ag_cwd=0._r8, & init_bg_cwd=0._r8, & init_seed=0._r8, & init_seed_germ=0._r8) end do - new_patch_secondary%tallest => null() - new_patch_secondary%shortest => null() + new_patch%tallest => null() + new_patch%shortest => null() endif @@ -593,455 +559,385 @@ subroutine spawn_patches( currentSite, bc_in) ! two new pointers. currentPatch => currentSite%oldest_patch - do while(associated(currentPatch)) + patchloop: do while(associated(currentPatch)) cp_nocomp_matches_2_if: if ( hlm_use_nocomp .eq. ifalse .or. & currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then - ! This is the amount of patch area that is disturbed, and donated by the donor - disturbance_rate = currentPatch%disturbance_rates(i_disturbance_type) - patch_site_areadis = currentPatch%area * disturbance_rate - + patchlabel_matches_lutype_if: if (currentPatch%anthro_disturbance_label .eq. i_landuse_type) then - if ( patch_site_areadis > nearzero ) then - ! figure out whether the receiver patch for disturbance from this patch - ! will be primary or secondary land receiver patch is primary forest - ! only if both the donor patch is primary forest and the current - ! disturbance type is not logging - if (currentPatch%anthro_disturbance_label .eq. primarylands .and. & - (i_disturbance_type .ne. dtype_ilog)) then - new_patch => new_patch_primary - else - new_patch => new_patch_secondary - endif + ! This is the amount of patch area that is disturbed, and donated by the donor + disturbance_rate = currentPatch%disturbance_rates(i_disturbance_type) + patch_site_areadis = currentPatch%area * disturbance_rate - if(.not.associated(new_patch))then - write(fates_log(),*) 'Patch spawning has attempted to point to' - write(fates_log(),*) 'an un-allocated patch' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! for the case where the donating patch is secondary forest, if - ! the current disturbance from this patch is non-anthropogenic, - ! we need to average in the time-since-anthropogenic-disturbance - ! from the donor patch into that of the receiver patch - if ( currentPatch%anthro_disturbance_label .eq. secondarylands .and. & - (i_disturbance_type .ne. dtype_ilog) ) then - - new_patch%age_since_anthro_disturbance = new_patch%age_since_anthro_disturbance + & - currentPatch%age_since_anthro_disturbance * (patch_site_areadis / site_areadis_secondary) - - endif + if ( patch_site_areadis > nearzero ) then - ! Transfer the litter existing already in the donor patch to the new patch - ! This call will only transfer non-burned litter to new patch - ! and burned litter to atmosphere. Thus it is important to zero burnt_frac_litter when - ! fire is not the current disturbance regime. - - if(i_disturbance_type .ne. dtype_ifire) then - currentPatch%burnt_frac_litter(:) = 0._r8 - end if - - call TransLitterNewPatch( currentSite, currentPatch, new_patch, patch_site_areadis) - - ! Transfer in litter fluxes from plants in various contexts of death and destruction - - if(i_disturbance_type .eq. dtype_ilog) then - call logging_litter_fluxes(currentSite, currentPatch, & - new_patch, patch_site_areadis,bc_in) - elseif(i_disturbance_type .eq. dtype_ifire) then - call fire_litter_fluxes(currentSite, currentPatch, & - new_patch, patch_site_areadis,bc_in) - else - call mortality_litter_fluxes(currentSite, currentPatch, & - new_patch, patch_site_areadis,bc_in) - endif - - - ! Copy any means or timers from the original patch to the new patch - ! These values will inherit all info from the original patch - ! -------------------------------------------------------------------------- - call new_patch%tveg24%CopyFromDonor(currentPatch%tveg24) - call new_patch%tveg_lpa%CopyFromDonor(currentPatch%tveg_lpa) - - - ! -------------------------------------------------------------------------- - ! The newly formed patch from disturbance (new_patch), has now been given - ! some litter from dead plants and pre-existing litter from the donor patches. - ! - ! Next, we loop through the cohorts in the donor patch, copy them with - ! area modified number density into the new-patch, and apply survivorship. - ! ------------------------------------------------------------------------- - - currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - - allocate(nc) - if(hlm_use_planthydro.eq.itrue) call InitHydrCohort(CurrentSite,nc) - - ! Initialize the PARTEH object and point to the - ! correct boundary condition fields - nc%prt => null() - call InitPRTObject(nc%prt) - call InitPRTBoundaryConditions(nc) - - ! (Keeping as an example) - ! Allocate running mean functions - !allocate(nc%tveg_lpa) - !call nc%tveg_lpa%InitRMean(ema_lpa,init_value=new_patch%tveg_lpa%GetMean()) - - call zero_cohort(nc) - - ! nc is the new cohort that goes in the disturbed patch (new_patch)... currentCohort - ! is the curent cohort that stays in the donor patch (currentPatch) - call copy_cohort(currentCohort, nc) - - !this is the case as the new patch probably doesn't have a closed canopy, and - ! even if it does, that will be sorted out in canopy_structure. - nc%canopy_layer = 1 - nc%canopy_layer_yesterday = 1._r8 - - sapw_c = currentCohort%prt%GetState(sapw_organ, carbon12_element) - struct_c = currentCohort%prt%GetState(struct_organ, carbon12_element) - leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element) - fnrt_c = currentCohort%prt%GetState(fnrt_organ, carbon12_element) - store_c = currentCohort%prt%GetState(store_organ, carbon12_element) - total_c = sapw_c + struct_c + leaf_c + fnrt_c + store_c - - ! treefall mortality is the current disturbance - if(i_disturbance_type .eq. dtype_ifall) then - - if(currentCohort%canopy_layer == 1)then - - ! In the donor patch we are left with fewer trees because the area has decreased - ! the plant density for large trees does not actually decrease in the donor patch - ! because this is the part of the original patch where no trees have actually fallen - ! The diagnostic cmort,bmort,hmort, and frmort rates have already been saved - - currentCohort%n = currentCohort%n * (1.0_r8 - fates_mortality_disturbance_fraction * & - min(1.0_r8,currentCohort%dmort * hlm_freq_day)) - - nc%n = 0.0_r8 ! kill all of the trees who caused the disturbance. - - nc%cmort = nan ! The mortality diagnostics are set to nan - ! because the cohort should dissappear - nc%hmort = nan - nc%bmort = nan - nc%frmort = nan - nc%smort = nan - nc%asmort = nan - nc%dgmort = nan - nc%lmort_direct = nan - nc%lmort_collateral = nan - nc%lmort_infra = nan - nc%l_degrad = nan - - else - ! small trees - if( prt_params%woody(currentCohort%pft) == itrue)then - - - ! Survivorship of undestory woody plants. Two step process. - ! Step 1: Reduce current number of plants to reflect the - ! change in area. - ! The number density per square are doesn't change, - ! but since the patch is smaller and cohort counts - ! are absolute, reduce this number. - - nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + if(.not.associated(new_patch))then + write(fates_log(),*) 'Patch spawning has attempted to point to' + write(fates_log(),*) 'an un-allocated patch' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - ! because the mortality rate due to impact for the cohorts which - ! had been in the understory and are now in the newly- - ! disturbed patch is very high, passing the imort directly to history - ! results in large numerical errors, on account of the sharply - ! reduced number densities. so instead pass this info via a - ! site-level diagnostic variable before reducing the number density. + ! CDK note 03/27 this logic needs to be updated for new logic + ! ! for the case where the donating patch is secondary forest, if + ! ! the current disturbance from this patch is non-anthropogenic, + ! ! we need to average in the time-since-anthropogenic-disturbance + ! ! from the donor patch into that of the receiver patch + ! if ( currentPatch%anthro_disturbance_label .eq. secondarylands .and. & + ! (i_disturbance_type .ne. dtype_ilog) ) then - currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) = & - currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) + & - nc%n * ED_val_understorey_death / hlm_freq_day + ! new_patch%age_since_anthro_disturbance = new_patch%age_since_anthro_disturbance + & + ! currentPatch%age_since_anthro_disturbance * (patch_site_areadis / site_areadis_secondary) + ! endif - currentSite%imort_carbonflux(currentCohort%pft) = & - currentSite%imort_carbonflux(currentCohort%pft) + & - (nc%n * ED_val_understorey_death / hlm_freq_day ) * & - total_c * g_per_kg * days_per_sec * years_per_day * ha_per_m2 - currentSite%imort_abg_flux(currentCohort%size_class, currentCohort%pft) = & - currentSite%imort_abg_flux(currentCohort%size_class, currentCohort%pft) + & - (nc%n * ED_val_understorey_death / hlm_freq_day ) * & - ( (sapw_c + struct_c + store_c) * prt_params%allom_agb_frac(currentCohort%pft) + & - leaf_c ) * & - g_per_kg * days_per_sec * years_per_day * ha_per_m2 + ! Transfer the litter existing already in the donor patch to the new patch + ! This call will only transfer non-burned litter to new patch + ! and burned litter to atmosphere. Thus it is important to zero burnt_frac_litter when + ! fire is not the current disturbance regime. + if(i_disturbance_type .ne. dtype_ifire) then + currentPatch%burnt_frac_litter(:) = 0._r8 + end if - ! Step 2: Apply survivor ship function based on the understory death fraction - ! remaining of understory plants of those that are knocked over - ! by the overstorey trees dying... - nc%n = nc%n * (1.0_r8 - ED_val_understorey_death) + call TransLitterNewPatch( currentSite, currentPatch, new_patch, patch_site_areadis) - ! since the donor patch split and sent a fraction of its members - ! to the new patch and a fraction to be preserved in itself, - ! when reporting diagnostic rates, we must carry over the mortality rates from - ! the donor that were applied before the patch split. Remember this is only - ! for diagnostics. But think of it this way, the rates are weighted by - ! number density in EDCLMLink, and the number density of this new patch is donated - ! so with the number density must come the effective mortality rates. + ! Transfer in litter fluxes from plants in various contexts of death and destruction - nc%cmort = currentCohort%cmort - nc%hmort = currentCohort%hmort - nc%bmort = currentCohort%bmort - nc%frmort = currentCohort%frmort - nc%smort = currentCohort%smort - nc%asmort = currentCohort%asmort - nc%dgmort = currentCohort%dgmort - nc%dmort = currentCohort%dmort - nc%lmort_direct = currentCohort%lmort_direct - nc%lmort_collateral = currentCohort%lmort_collateral - nc%lmort_infra = currentCohort%lmort_infra + if(i_disturbance_type .eq. dtype_ilog) then + call logging_litter_fluxes(currentSite, currentPatch, & + new_patch, patch_site_areadis,bc_in) + elseif(i_disturbance_type .eq. dtype_ifire) then + call fire_litter_fluxes(currentSite, currentPatch, & + new_patch, patch_site_areadis,bc_in) + else + call mortality_litter_fluxes(currentSite, currentPatch, & + new_patch, patch_site_areadis,bc_in) + endif - ! understory trees that might potentially be knocked over in the disturbance. - ! The existing (donor) patch should not have any impact mortality, it should - ! only lose cohorts due to the decrease in area. This is not mortality. - ! Besides, the current and newly created patch sum to unity - currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + ! Copy any means or timers from the original patch to the new patch + ! These values will inherit all info from the original patch + ! -------------------------------------------------------------------------- + call new_patch%tveg24%CopyFromDonor(currentPatch%tveg24) + call new_patch%tveg_lpa%CopyFromDonor(currentPatch%tveg_lpa) + + + ! -------------------------------------------------------------------------- + ! The newly formed patch from disturbance (new_patch), has now been given + ! some litter from dead plants and pre-existing litter from the donor patches. + ! + ! Next, we loop through the cohorts in the donor patch, copy them with + ! area modified number density into the new-patch, and apply survivorship. + ! ------------------------------------------------------------------------- + + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + + allocate(nc) + if(hlm_use_planthydro.eq.itrue) call InitHydrCohort(CurrentSite,nc) + + ! Initialize the PARTEH object and point to the + ! correct boundary condition fields + nc%prt => null() + call InitPRTObject(nc%prt) + call InitPRTBoundaryConditions(nc) + + ! (Keeping as an example) + ! Allocate running mean functions + !allocate(nc%tveg_lpa) + !call nc%tveg_lpa%InitRMean(ema_lpa,init_value=new_patch%tveg_lpa%GetMean()) + + call zero_cohort(nc) + + ! nc is the new cohort that goes in the disturbed patch (new_patch)... currentCohort + ! is the curent cohort that stays in the donor patch (currentPatch) + call copy_cohort(currentCohort, nc) + + !this is the case as the new patch probably doesn't have a closed canopy, and + ! even if it does, that will be sorted out in canopy_structure. + nc%canopy_layer = 1 + nc%canopy_layer_yesterday = 1._r8 + + sapw_c = currentCohort%prt%GetState(sapw_organ, carbon12_element) + struct_c = currentCohort%prt%GetState(struct_organ, carbon12_element) + leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element) + fnrt_c = currentCohort%prt%GetState(fnrt_organ, carbon12_element) + store_c = currentCohort%prt%GetState(store_organ, carbon12_element) + total_c = sapw_c + struct_c + leaf_c + fnrt_c + store_c + + ! treefall mortality is the current disturbance + if(i_disturbance_type .eq. dtype_ifall) then + + if(currentCohort%canopy_layer == 1)then + + ! In the donor patch we are left with fewer trees because the area has decreased + ! the plant density for large trees does not actually decrease in the donor patch + ! because this is the part of the original patch where no trees have actually fallen + ! The diagnostic cmort,bmort,hmort, and frmort rates have already been saved + + currentCohort%n = currentCohort%n * (1.0_r8 - fates_mortality_disturbance_fraction * & + min(1.0_r8,currentCohort%dmort * hlm_freq_day)) + + nc%n = 0.0_r8 ! kill all of the trees who caused the disturbance. + + nc%cmort = nan ! The mortality diagnostics are set to nan + ! because the cohort should dissappear + nc%hmort = nan + nc%bmort = nan + nc%frmort = nan + nc%smort = nan + nc%asmort = nan + nc%dgmort = nan + nc%lmort_direct = nan + nc%lmort_collateral = nan + nc%lmort_infra = nan + nc%l_degrad = nan else - ! grass is not killed by mortality disturbance events. Just move it into the new patch area. - ! Just split the grass into the existing and new patch structures - nc%n = currentCohort%n * patch_site_areadis/currentPatch%area - - ! Those remaining in the existing - currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) - - nc%cmort = currentCohort%cmort - nc%hmort = currentCohort%hmort - nc%bmort = currentCohort%bmort - nc%frmort = currentCohort%frmort - nc%smort = currentCohort%smort - nc%asmort = currentCohort%asmort - nc%dgmort = currentCohort%dgmort - nc%dmort = currentCohort%dmort - nc%lmort_direct = currentCohort%lmort_direct - nc%lmort_collateral = currentCohort%lmort_collateral - nc%lmort_infra = currentCohort%lmort_infra - + ! small trees + if( prt_params%woody(currentCohort%pft) == itrue)then + + + ! Survivorship of undestory woody plants. Two step process. + ! Step 1: Reduce current number of plants to reflect the + ! change in area. + ! The number density per square are doesn't change, + ! but since the patch is smaller and cohort counts + ! are absolute, reduce this number. + + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + + ! because the mortality rate due to impact for the cohorts which + ! had been in the understory and are now in the newly- + ! disturbed patch is very high, passing the imort directly to history + ! results in large numerical errors, on account of the sharply + ! reduced number densities. so instead pass this info via a + ! site-level diagnostic variable before reducing the number density. + + currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) = & + currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) + & + nc%n * ED_val_understorey_death / hlm_freq_day + + + currentSite%imort_carbonflux(currentCohort%pft) = & + currentSite%imort_carbonflux(currentCohort%pft) + & + (nc%n * ED_val_understorey_death / hlm_freq_day ) * & + total_c * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + + currentSite%imort_abg_flux(currentCohort%size_class, currentCohort%pft) = & + currentSite%imort_abg_flux(currentCohort%size_class, currentCohort%pft) + & + (nc%n * ED_val_understorey_death / hlm_freq_day ) * & + ( (sapw_c + struct_c + store_c) * prt_params%allom_agb_frac(currentCohort%pft) + & + leaf_c ) * & + g_per_kg * days_per_sec * years_per_day * ha_per_m2 + + + ! Step 2: Apply survivor ship function based on the understory death fraction + ! remaining of understory plants of those that are knocked over + ! by the overstorey trees dying... + nc%n = nc%n * (1.0_r8 - ED_val_understorey_death) + + ! since the donor patch split and sent a fraction of its members + ! to the new patch and a fraction to be preserved in itself, + ! when reporting diagnostic rates, we must carry over the mortality rates from + ! the donor that were applied before the patch split. Remember this is only + ! for diagnostics. But think of it this way, the rates are weighted by + ! number density in EDCLMLink, and the number density of this new patch is donated + ! so with the number density must come the effective mortality rates. + + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + nc%frmort = currentCohort%frmort + nc%smort = currentCohort%smort + nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort + nc%dmort = currentCohort%dmort + nc%lmort_direct = currentCohort%lmort_direct + nc%lmort_collateral = currentCohort%lmort_collateral + nc%lmort_infra = currentCohort%lmort_infra + + ! understory trees that might potentially be knocked over in the disturbance. + ! The existing (donor) patch should not have any impact mortality, it should + ! only lose cohorts due to the decrease in area. This is not mortality. + ! Besides, the current and newly created patch sum to unity + + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + + else + ! grass is not killed by mortality disturbance events. Just move it into the new patch area. + ! Just split the grass into the existing and new patch structures + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + + ! Those remaining in the existing + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + nc%frmort = currentCohort%frmort + nc%smort = currentCohort%smort + nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort + nc%dmort = currentCohort%dmort + nc%lmort_direct = currentCohort%lmort_direct + nc%lmort_collateral = currentCohort%lmort_collateral + nc%lmort_infra = currentCohort%lmort_infra + + endif endif - endif - - ! Fire is the current disturbance - elseif (i_disturbance_type .eq. dtype_ifire ) then - ! Number of members in the new patch, before we impose fire survivorship - nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + ! Fire is the current disturbance + elseif (i_disturbance_type .eq. dtype_ifire ) then - ! loss of individuals from source patch due to area shrinking - currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + ! Number of members in the new patch, before we impose fire survivorship + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area - levcan = currentCohort%canopy_layer + ! loss of individuals from source patch due to area shrinking + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) - if(levcan==ican_upper) then + levcan = currentCohort%canopy_layer - ! before changing number densities, track total rate of trees that died - ! due to fire, as well as from each fire mortality term - currentSite%fmort_rate_canopy(currentCohort%size_class, currentCohort%pft) = & - currentSite%fmort_rate_canopy(currentCohort%size_class, currentCohort%pft) + & - nc%n * currentCohort%fire_mort / hlm_freq_day + if(levcan==ican_upper) then - currentSite%fmort_carbonflux_canopy(currentCohort%pft) = & - currentSite%fmort_carbonflux_canopy(currentCohort%pft) + & - (nc%n * currentCohort%fire_mort) * & - total_c * g_per_kg * days_per_sec * ha_per_m2 + ! before changing number densities, track total rate of trees that died + ! due to fire, as well as from each fire mortality term + currentSite%fmort_rate_canopy(currentCohort%size_class, currentCohort%pft) = & + currentSite%fmort_rate_canopy(currentCohort%size_class, currentCohort%pft) + & + nc%n * currentCohort%fire_mort / hlm_freq_day - else - currentSite%fmort_rate_ustory(currentCohort%size_class, currentCohort%pft) = & - currentSite%fmort_rate_ustory(currentCohort%size_class, currentCohort%pft) + & - nc%n * currentCohort%fire_mort / hlm_freq_day + currentSite%fmort_carbonflux_canopy(currentCohort%pft) = & + currentSite%fmort_carbonflux_canopy(currentCohort%pft) + & + (nc%n * currentCohort%fire_mort) * & + total_c * g_per_kg * days_per_sec * ha_per_m2 - currentSite%fmort_carbonflux_ustory(currentCohort%pft) = & - currentSite%fmort_carbonflux_ustory(currentCohort%pft) + & + else + currentSite%fmort_rate_ustory(currentCohort%size_class, currentCohort%pft) = & + currentSite%fmort_rate_ustory(currentCohort%size_class, currentCohort%pft) + & + nc%n * currentCohort%fire_mort / hlm_freq_day + + currentSite%fmort_carbonflux_ustory(currentCohort%pft) = & + currentSite%fmort_carbonflux_ustory(currentCohort%pft) + & + (nc%n * currentCohort%fire_mort) * & + total_c * g_per_kg * days_per_sec * ha_per_m2 + end if + + currentSite%fmort_abg_flux(currentCohort%size_class, currentCohort%pft) = & + currentSite%fmort_abg_flux(currentCohort%size_class, currentCohort%pft) + & (nc%n * currentCohort%fire_mort) * & - total_c * g_per_kg * days_per_sec * ha_per_m2 - end if - - currentSite%fmort_abg_flux(currentCohort%size_class, currentCohort%pft) = & - currentSite%fmort_abg_flux(currentCohort%size_class, currentCohort%pft) + & - (nc%n * currentCohort%fire_mort) * & - ( (sapw_c + struct_c + store_c) * prt_params%allom_agb_frac(currentCohort%pft) + & - leaf_c ) * & - g_per_kg * days_per_sec * ha_per_m2 - - - currentSite%fmort_rate_cambial(currentCohort%size_class, currentCohort%pft) = & - currentSite%fmort_rate_cambial(currentCohort%size_class, currentCohort%pft) + & - nc%n * currentCohort%cambial_mort / hlm_freq_day - currentSite%fmort_rate_crown(currentCohort%size_class, currentCohort%pft) = & - currentSite%fmort_rate_crown(currentCohort%size_class, currentCohort%pft) + & - nc%n * currentCohort%crownfire_mort / hlm_freq_day - - ! loss of individual from fire in new patch. - nc%n = nc%n * (1.0_r8 - currentCohort%fire_mort) - - nc%cmort = currentCohort%cmort - nc%hmort = currentCohort%hmort - nc%bmort = currentCohort%bmort - nc%frmort = currentCohort%frmort - nc%smort = currentCohort%smort - nc%asmort = currentCohort%asmort - nc%dgmort = currentCohort%dgmort - nc%dmort = currentCohort%dmort - nc%lmort_direct = currentCohort%lmort_direct - nc%lmort_collateral = currentCohort%lmort_collateral - nc%lmort_infra = currentCohort%lmort_infra - - - ! Some of of the leaf mass from living plants has been - ! burned off. Here, we remove that mass, and - ! tally it in the flux we sent to the atmosphere - - if(prt_params%woody(currentCohort%pft) == itrue)then - leaf_burn_frac = currentCohort%fraction_crown_burned - else + ( (sapw_c + struct_c + store_c) * prt_params%allom_agb_frac(currentCohort%pft) + & + leaf_c ) * & + g_per_kg * days_per_sec * ha_per_m2 - ! Grasses determine their fraction of leaves burned here - leaf_burn_frac = currentPatch%burnt_frac_litter(lg_sf) - endif + currentSite%fmort_rate_cambial(currentCohort%size_class, currentCohort%pft) = & + currentSite%fmort_rate_cambial(currentCohort%size_class, currentCohort%pft) + & + nc%n * currentCohort%cambial_mort / hlm_freq_day + currentSite%fmort_rate_crown(currentCohort%size_class, currentCohort%pft) = & + currentSite%fmort_rate_crown(currentCohort%size_class, currentCohort%pft) + & + nc%n * currentCohort%crownfire_mort / hlm_freq_day - ! Perform a check to make sure that spitfire gave - ! us reasonable mortality and burn fraction rates - - if( (leaf_burn_frac < 0._r8) .or. & - (leaf_burn_frac > 1._r8) .or. & - (currentCohort%fire_mort < 0._r8) .or. & - (currentCohort%fire_mort > 1._r8)) then - write(fates_log(),*) 'unexpected fire fractions' - write(fates_log(),*) prt_params%woody(currentCohort%pft) - write(fates_log(),*) leaf_burn_frac - write(fates_log(),*) currentCohort%fire_mort - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + ! loss of individual from fire in new patch. + nc%n = nc%n * (1.0_r8 - currentCohort%fire_mort) - do el = 1,num_elements + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + nc%frmort = currentCohort%frmort + nc%smort = currentCohort%smort + nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort + nc%dmort = currentCohort%dmort + nc%lmort_direct = currentCohort%lmort_direct + nc%lmort_collateral = currentCohort%lmort_collateral + nc%lmort_infra = currentCohort%lmort_infra - leaf_m = nc%prt%GetState(leaf_organ, element_list(el)) - ! for woody plants burn only leaves - if(int(prt_params%woody(currentCohort%pft)) == itrue)then - leaf_m = nc%prt%GetState(leaf_organ, element_list(el)) + ! Some of of the leaf mass from living plants has been + ! burned off. Here, we remove that mass, and + ! tally it in the flux we sent to the atmosphere + if(prt_params%woody(currentCohort%pft) == itrue)then + leaf_burn_frac = currentCohort%fraction_crown_burned else - ! for grasses burn all aboveground tissues - leaf_m = nc%prt%GetState(leaf_organ, element_list(el)) + & - nc%prt%GetState(sapw_organ, element_list(el)) + & - nc%prt%GetState(struct_organ, element_list(el)) + ! Grasses determine their fraction of leaves burned here + + leaf_burn_frac = currentPatch%burnt_frac_litter(lg_sf) endif - currentSite%mass_balance(el)%burn_flux_to_atm = & - currentSite%mass_balance(el)%burn_flux_to_atm + & - leaf_burn_frac * leaf_m * nc%n - end do + ! Perform a check to make sure that spitfire gave + ! us reasonable mortality and burn fraction rates - ! Here the mass is removed from the plant + if( (leaf_burn_frac < 0._r8) .or. & + (leaf_burn_frac > 1._r8) .or. & + (currentCohort%fire_mort < 0._r8) .or. & + (currentCohort%fire_mort > 1._r8)) then + write(fates_log(),*) 'unexpected fire fractions' + write(fates_log(),*) prt_params%woody(currentCohort%pft) + write(fates_log(),*) leaf_burn_frac + write(fates_log(),*) currentCohort%fire_mort + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - if(int(prt_params%woody(currentCohort%pft)) == itrue)then - call PRTBurnLosses(nc%prt, leaf_organ, leaf_burn_frac) - else - call PRTBurnLosses(nc%prt, leaf_organ, leaf_burn_frac) - call PRTBurnLosses(nc%prt, sapw_organ, leaf_burn_frac) - call PRTBurnLosses(nc%prt, struct_organ, leaf_burn_frac) - endif + do el = 1,num_elements - currentCohort%fraction_crown_burned = 0.0_r8 - nc%fraction_crown_burned = 0.0_r8 + leaf_m = nc%prt%GetState(leaf_organ, element_list(el)) + ! for woody plants burn only leaves + if(int(prt_params%woody(currentCohort%pft)) == itrue)then + leaf_m = nc%prt%GetState(leaf_organ, element_list(el)) + else + ! for grasses burn all aboveground tissues + leaf_m = nc%prt%GetState(leaf_organ, element_list(el)) + & + nc%prt%GetState(sapw_organ, element_list(el)) + & + nc%prt%GetState(struct_organ, element_list(el)) - ! Logging is the current disturbance - elseif (i_disturbance_type .eq. dtype_ilog ) then + endif - ! If this cohort is in the upper canopy. It generated - if(currentCohort%canopy_layer == 1)then + currentSite%mass_balance(el)%burn_flux_to_atm = & + currentSite%mass_balance(el)%burn_flux_to_atm + & + leaf_burn_frac * leaf_m * nc%n + end do - ! calculate the survivorship of disturbed trees because non-harvested - nc%n = currentCohort%n * currentCohort%l_degrad - ! nc%n = (currentCohort%l_degrad / (currentCohort%l_degrad + & - ! currentCohort%lmort_direct + currentCohort%lmort_collateral + - ! currentCohort%lmort_infra) ) * & - ! currentCohort%n * patch_site_areadis/currentPatch%area + ! Here the mass is removed from the plant - ! Reduce counts in the existing/donor patch according to the logging rate - currentCohort%n = currentCohort%n * & - (1.0_r8 - min(1.0_r8,(currentCohort%lmort_direct + & - currentCohort%lmort_collateral + & - currentCohort%lmort_infra + currentCohort%l_degrad))) + if(int(prt_params%woody(currentCohort%pft)) == itrue)then + call PRTBurnLosses(nc%prt, leaf_organ, leaf_burn_frac) + else + call PRTBurnLosses(nc%prt, leaf_organ, leaf_burn_frac) + call PRTBurnLosses(nc%prt, sapw_organ, leaf_burn_frac) + call PRTBurnLosses(nc%prt, struct_organ, leaf_burn_frac) + endif - nc%cmort = currentCohort%cmort - nc%hmort = currentCohort%hmort - nc%bmort = currentCohort%bmort - nc%frmort = currentCohort%frmort - nc%smort = currentCohort%smort - nc%asmort = currentCohort%asmort - nc%dgmort = currentCohort%dgmort - nc%dmort = currentCohort%dmort + currentCohort%fraction_crown_burned = 0.0_r8 + nc%fraction_crown_burned = 0.0_r8 - ! since these are the ones that weren't logged, - ! set the logging mortality rates as zero - nc%lmort_direct = 0._r8 - nc%lmort_collateral = 0._r8 - nc%lmort_infra = 0._r8 - else - ! What to do with cohorts in the understory of a logging generated - ! disturbance patch? + ! Logging is the current disturbance + elseif (i_disturbance_type .eq. dtype_ilog ) then - if(prt_params%woody(currentCohort%pft) == itrue)then + ! If this cohort is in the upper canopy. It generated + if(currentCohort%canopy_layer == 1)then + ! calculate the survivorship of disturbed trees because non-harvested + nc%n = currentCohort%n * currentCohort%l_degrad + ! nc%n = (currentCohort%l_degrad / (currentCohort%l_degrad + & + ! currentCohort%lmort_direct + currentCohort%lmort_collateral + + ! currentCohort%lmort_infra) ) * & + ! currentCohort%n * patch_site_areadis/currentPatch%area - ! Survivorship of undestory woody plants. Two step process. - ! Step 1: Reduce current number of plants to reflect the - ! change in area. - ! The number density per square are doesn't change, - ! but since the patch is smaller - ! and cohort counts are absolute, reduce this number. - nc%n = currentCohort%n * patch_site_areadis/currentPatch%area - - ! because the mortality rate due to impact for the cohorts which had - ! been in the understory and are now in the newly- - ! disturbed patch is very high, passing the imort directly to - ! history results in large numerical errors, on account - ! of the sharply reduced number densities. so instead pass this info - ! via a site-level diagnostic variable before reducing - ! the number density. - currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) = & - currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) + & - nc%n * currentPatch%fract_ldist_not_harvested * & - logging_coll_under_frac / hlm_freq_day - - currentSite%imort_carbonflux(currentCohort%pft) = & - currentSite%imort_carbonflux(currentCohort%pft) + & - (nc%n * currentPatch%fract_ldist_not_harvested * & - logging_coll_under_frac/ hlm_freq_day ) * & - total_c * g_per_kg * days_per_sec * years_per_day * ha_per_m2 - - - ! Step 2: Apply survivor ship function based on the understory death fraction - - ! remaining of understory plants of those that are knocked - ! over by the overstorey trees dying... - ! LOGGING SURVIVORSHIP OF UNDERSTORY PLANTS IS SET AS A NEW PARAMETER - ! in the fatesparameter files - nc%n = nc%n * (1.0_r8 - & - (1.0_r8-currentPatch%fract_ldist_not_harvested) * logging_coll_under_frac) - - ! Step 3: Reduce the number count of cohorts in the - ! original/donor/non-disturbed patch to reflect the area change - currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + ! Reduce counts in the existing/donor patch according to the logging rate + currentCohort%n = currentCohort%n * & + (1.0_r8 - min(1.0_r8,(currentCohort%lmort_direct + & + currentCohort%lmort_collateral + & + currentCohort%lmort_infra + currentCohort%l_degrad))) nc%cmort = currentCohort%cmort nc%hmort = currentCohort%hmort @@ -1051,117 +947,184 @@ subroutine spawn_patches( currentSite, bc_in) nc%asmort = currentCohort%asmort nc%dgmort = currentCohort%dgmort nc%dmort = currentCohort%dmort - nc%lmort_direct = currentCohort%lmort_direct - nc%lmort_collateral = currentCohort%lmort_collateral - nc%lmort_infra = currentCohort%lmort_infra - else + ! since these are the ones that weren't logged, + ! set the logging mortality rates as zero + nc%lmort_direct = 0._r8 + nc%lmort_collateral = 0._r8 + nc%lmort_infra = 0._r8 - ! grass is not killed by mortality disturbance events. - ! Just move it into the new patch area. - ! Just split the grass into the existing and new patch structures - nc%n = currentCohort%n * patch_site_areadis/currentPatch%area - - ! Those remaining in the existing - currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + else - ! No grass impact mortality imposed on the newly created patch - nc%cmort = currentCohort%cmort - nc%hmort = currentCohort%hmort - nc%bmort = currentCohort%bmort - nc%frmort = currentCohort%frmort - nc%smort = currentCohort%smort - nc%asmort = currentCohort%asmort - nc%dgmort = currentCohort%dgmort - nc%dmort = currentCohort%dmort - nc%lmort_direct = currentCohort%lmort_direct - nc%lmort_collateral = currentCohort%lmort_collateral - nc%lmort_infra = currentCohort%lmort_infra + ! What to do with cohorts in the understory of a logging generated + ! disturbance patch? + + if(prt_params%woody(currentCohort%pft) == itrue)then + + + ! Survivorship of undestory woody plants. Two step process. + ! Step 1: Reduce current number of plants to reflect the + ! change in area. + ! The number density per square are doesn't change, + ! but since the patch is smaller + ! and cohort counts are absolute, reduce this number. + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + + ! because the mortality rate due to impact for the cohorts which had + ! been in the understory and are now in the newly- + ! disturbed patch is very high, passing the imort directly to + ! history results in large numerical errors, on account + ! of the sharply reduced number densities. so instead pass this info + ! via a site-level diagnostic variable before reducing + ! the number density. + currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) = & + currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) + & + nc%n * currentPatch%fract_ldist_not_harvested * & + logging_coll_under_frac / hlm_freq_day + + currentSite%imort_carbonflux(currentCohort%pft) = & + currentSite%imort_carbonflux(currentCohort%pft) + & + (nc%n * currentPatch%fract_ldist_not_harvested * & + logging_coll_under_frac/ hlm_freq_day ) * & + total_c * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + + + ! Step 2: Apply survivor ship function based on the understory death fraction + + ! remaining of understory plants of those that are knocked + ! over by the overstorey trees dying... + ! LOGGING SURVIVORSHIP OF UNDERSTORY PLANTS IS SET AS A NEW PARAMETER + ! in the fatesparameter files + nc%n = nc%n * (1.0_r8 - & + (1.0_r8-currentPatch%fract_ldist_not_harvested) * logging_coll_under_frac) + + ! Step 3: Reduce the number count of cohorts in the + ! original/donor/non-disturbed patch to reflect the area change + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + nc%frmort = currentCohort%frmort + nc%smort = currentCohort%smort + nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort + nc%dmort = currentCohort%dmort + nc%lmort_direct = currentCohort%lmort_direct + nc%lmort_collateral = currentCohort%lmort_collateral + nc%lmort_infra = currentCohort%lmort_infra + + else + + ! grass is not killed by mortality disturbance events. + ! Just move it into the new patch area. + ! Just split the grass into the existing and new patch structures + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + + ! Those remaining in the existing + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + + ! No grass impact mortality imposed on the newly created patch + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + nc%frmort = currentCohort%frmort + nc%smort = currentCohort%smort + nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort + nc%dmort = currentCohort%dmort + nc%lmort_direct = currentCohort%lmort_direct + nc%lmort_collateral = currentCohort%lmort_collateral + nc%lmort_infra = currentCohort%lmort_infra + + endif ! is/is-not woody + + endif ! Select canopy layer - endif ! is/is-not woody + else + write(fates_log(),*) 'unknown disturbance mode?' + write(fates_log(),*) 'i_disturbance_type: ',i_disturbance_type + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if ! Select disturbance mode - endif ! Select canopy layer + if (nc%n > 0.0_r8) then + storebigcohort => new_patch%tallest + storesmallcohort => new_patch%shortest + if(associated(new_patch%tallest))then + tnull = 0 + else + tnull = 1 + new_patch%tallest => nc + nc%taller => null() + endif - else - write(fates_log(),*) 'unknown disturbance mode?' - write(fates_log(),*) 'i_disturbance_type: ',i_disturbance_type - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if ! Select disturbance mode + if(associated(new_patch%shortest))then + snull = 0 + else + snull = 1 + new_patch%shortest => nc + nc%shorter => null() + endif + nc%patchptr => new_patch + call insert_cohort(nc, new_patch%tallest, new_patch%shortest, & + tnull, snull, storebigcohort, storesmallcohort) - if (nc%n > 0.0_r8) then - storebigcohort => new_patch%tallest - storesmallcohort => new_patch%shortest - if(associated(new_patch%tallest))then - tnull = 0 + new_patch%tallest => storebigcohort + new_patch%shortest => storesmallcohort else - tnull = 1 - new_patch%tallest => nc - nc%taller => null() - endif - if(associated(new_patch%shortest))then - snull = 0 - else - snull = 1 - new_patch%shortest => nc - nc%shorter => null() + ! Get rid of the new temporary cohort + call DeallocateCohort(nc) + deallocate(nc, stat=istat, errmsg=smsg) + if (istat/=0) then + write(fates_log(),*) 'dealloc005: fail on deallocate(nc):'//trim(smsg) + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif endif - nc%patchptr => new_patch - call insert_cohort(nc, new_patch%tallest, new_patch%shortest, & - tnull, snull, storebigcohort, storesmallcohort) - new_patch%tallest => storebigcohort - new_patch%shortest => storesmallcohort - else + currentCohort => currentCohort%taller + enddo ! currentCohort + call sort_cohorts(currentPatch) - ! Get rid of the new temporary cohort - call DeallocateCohort(nc) - deallocate(nc, stat=istat, errmsg=smsg) - if (istat/=0) then - write(fates_log(),*) 'dealloc005: fail on deallocate(nc):'//trim(smsg) - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - endif + !update area of donor patch + oldarea = currentPatch%area + currentPatch%area = currentPatch%area - patch_site_areadis - currentCohort => currentCohort%taller - enddo ! currentCohort - call sort_cohorts(currentPatch) - - !update area of donor patch - oldarea = currentPatch%area - currentPatch%area = currentPatch%area - patch_site_areadis - - ! for all disturbance rates that haven't been resolved yet, increase their amount so that - ! they are the same amount of gridcell-scale disturbance relative to the original patch size - if (i_disturbance_type .ne. N_DIST_TYPES) then - do i_dist2 = i_disturbance_type+1,N_DIST_TYPES - currentPatch%disturbance_rates(i_dist2) = currentPatch%disturbance_rates(i_dist2) & - * oldarea / currentPatch%area - end do - end if + ! for all disturbance rates that haven't been resolved yet, increase their amount so that + ! they are the same amount of gridcell-scale disturbance relative to the original patch size + if (i_disturbance_type .ne. N_DIST_TYPES) then + do i_dist2 = i_disturbance_type+1,N_DIST_TYPES + currentPatch%disturbance_rates(i_dist2) = currentPatch%disturbance_rates(i_dist2) & + * oldarea / currentPatch%area + end do + end if + + ! sort out the cohorts, since some of them may be so small as to need removing. + ! the first call to terminate cohorts removes sparse number densities, + ! the second call removes for all other reasons (sparse culling must happen + ! before fusion) + call terminate_cohorts(currentSite, currentPatch, 1,16,bc_in) + call fuse_cohorts(currentSite,currentPatch, bc_in) + call terminate_cohorts(currentSite, currentPatch, 2,16,bc_in) + call sort_cohorts(currentPatch) - ! sort out the cohorts, since some of them may be so small as to need removing. - ! the first call to terminate cohorts removes sparse number densities, - ! the second call removes for all other reasons (sparse culling must happen - ! before fusion) - call terminate_cohorts(currentSite, currentPatch, 1,16,bc_in) - call fuse_cohorts(currentSite,currentPatch, bc_in) - call terminate_cohorts(currentSite, currentPatch, 2,16,bc_in) - call sort_cohorts(currentPatch) + end if ! if ( new_patch%area > nearzero ) then - end if ! if ( new_patch%area > nearzero ) then + end if patchlabel_matches_lutype_if end if cp_nocomp_matches_2_if currentPatch => currentPatch%younger - enddo ! currentPatch patch loop. + enddo patchloop ! currentPatch patch loop. !*************************/ !** INSERT NEW PATCH(ES) INTO LINKED LIST !*************************/ - if ( site_areadis_primary .gt. nearzero) then + if ( site_areadis .gt. nearzero) then currentPatch => currentSite%youngest_patch + +!!!CDK 3/27 need change this logic. put the new patch as younger than any patches with the same labels ! insert new youngest primary patch after all the secondary patches, if there are any. ! this requires first finding the current youngest primary to insert the new one ahead of if (currentPatch%anthro_disturbance_label .eq. secondarylands ) then @@ -1178,60 +1141,40 @@ subroutine spawn_patches( currentSite, bc_in) ! the case where we've found a youngest primary patch new_patch_primary%older => currentPatch new_patch_primary%younger => currentPatch%younger - currentPatch%younger%older => new_patch_primary - currentPatch%younger => new_patch_primary + currentPatch%younger%older => new_patch + currentPatch%younger => new_patch else ! the case where we haven't, because the patches are all secondaary, ! and are putting a primary patch at the oldest end of the ! linked list (not sure how this could happen, but who knows...) new_patch_primary%older => null() new_patch_primary%younger => currentSite%oldest_patch - currentSite%oldest_patch%older => new_patch_primary - currentSite%oldest_patch => new_patch_primary + currentSite%oldest_patch%older => new_patch + currentSite%oldest_patch => new_patch endif else ! the case where there are no secondary patches at the start of the linked list (prior logic) new_patch_primary%older => currentPatch new_patch_primary%younger => null() - currentPatch%younger => new_patch_primary - currentSite%youngest_patch => new_patch_primary + currentPatch%younger => new_patch + currentSite%youngest_patch => new_patch endif - endif - - ! insert first secondary at the start of the list - if ( site_areadis_secondary .gt. nearzero) then - currentPatch => currentSite%youngest_patch - new_patch_secondary%older => currentPatch - new_patch_secondary%younger=> null() - currentPatch%younger => new_patch_secondary - currentSite%youngest_patch => new_patch_secondary - endif + ! sort out the cohorts, since some of them may be so small as to need removing. + ! the first call to terminate cohorts removes sparse number densities, + ! the second call removes for all other reasons (sparse culling must happen + ! before fusion) - ! sort out the cohorts, since some of them may be so small as to need removing. - ! the first call to terminate cohorts removes sparse number densities, - ! the second call removes for all other reasons (sparse culling must happen - ! before fusion) - - if ( site_areadis_primary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_primary, 1,17, bc_in) - call fuse_cohorts(currentSite,new_patch_primary, bc_in) - call terminate_cohorts(currentSite, new_patch_primary, 2,17, bc_in) - call sort_cohorts(new_patch_primary) - endif - - if ( site_areadis_secondary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_secondary, 1,18,bc_in) - call fuse_cohorts(currentSite,new_patch_secondary, bc_in) - call terminate_cohorts(currentSite, new_patch_secondary, 2,18,bc_in) - call sort_cohorts(new_patch_secondary) + call terminate_cohorts(currentSite, new_patch, 1,17, bc_in) + call fuse_cohorts(currentSite,new_patch, bc_in) + call terminate_cohorts(currentSite, new_patch, 2,17, bc_in) + call sort_cohorts(new_patch) endif - endif !end new_patch area - - call check_patch_area(currentSite) - call set_patchno(currentSite) + call check_patch_area(currentSite) + call set_patchno(currentSite) + end do landuse_type_loop end do disturbance_type_loop From 79c25fbce43e796bd3183b97f0186e17232b32b4 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Mon, 27 Mar 2023 18:07:00 -0400 Subject: [PATCH 005/250] first attempt to apply the transition matrix in the disturbance code --- biogeochem/EDPatchDynamicsMod.F90 | 1203 +++++++++++++++-------------- main/EDTypesMod.F90 | 3 +- 2 files changed, 624 insertions(+), 582 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 83ba5a8300..b94729c587 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -29,6 +29,7 @@ module EDPatchDynamicsMod use EDTypesMod , only : dtype_ifall use EDTypesMod , only : dtype_ilog use EDTypesMod , only : dtype_ifire + use EDTypesMod , only : dtype_ilandusechange use EDTypesMod , only : ican_upper use PRTGenericMod , only : num_elements use PRTGenericMod , only : element_list @@ -264,8 +265,6 @@ subroutine disturbance_rates( site_in, bc_in) call get_landuse_transition_rates(bc_in, landuse_transition_matrix) - site_in%landuse_transition_matrix = landuse_transition_matrix - ! --------------------------------------------------------------------------------------------- ! Calculate Disturbance Rates based on the mortality rates just calculated ! --------------------------------------------------------------------------------------------- @@ -296,6 +295,9 @@ subroutine disturbance_rates( site_in, bc_in) dist_rate_ldist_notharvested = 0.0_r8 + currentPatch%landuse_transition_rates(1:n_landuse_cats) = & + landuse_transition_matrix(currentPatch%anthro_disturbance_label,1:n_landuse_cats) + currentCohort => currentPatch%shortest do while(associated(currentCohort)) @@ -380,11 +382,14 @@ subroutine disturbance_rates( site_in, bc_in) endif ! if the sum of all disturbance rates is such that they will exceed total patch area on this day, then reduce them all proportionally. - if ( sum(currentPatch%disturbance_rates(:)) .gt. 1.0_r8 ) then - tempsum = sum(currentPatch%disturbance_rates(:)) + if ( (sum(currentPatch%disturbance_rates(:)) + sum(currentPatch%landuse_transition_rates(1:n_landuse_cats))) .gt. 1.0_r8 ) then + tempsum = sum(currentPatch%disturbance_rates(:)) + sum(currentPatch%landuse_transition_rates(1:n_landuse_cats)) do i_dist = 1,N_DIST_TYPES currentPatch%disturbance_rates(i_dist) = currentPatch%disturbance_rates(i_dist) / tempsum end do + do i_dist = 1,n_landuse_cats + currentPatch%landuse_transition_rates(i_dist) = currentPatch%landuse_transition_rates(i_dist) / tempsum + end do endif currentPatch => currentPatch%younger @@ -478,529 +483,481 @@ subroutine spawn_patches( currentSite, bc_in) disturbance_type_loop: do i_disturbance_type = 1,N_DIST_TYPES - landuse_type_loop: do i_landuse_type = 1, n_landuse_cats - - ! calculate area of disturbed land, in this timestep, by summing contributions from each existing patch. - currentPatch => currentSite%youngest_patch - - site_areadis = 0.0_r8 - - ! figure out what land use label the receiver patch for disturbance from patches with - ! this disturbance label and disturbance of this type will have - if ( i_disturbance_type .eq. dtype_ilog) then - receiver_patch_lu_label = secondarylands - else - receiver_patch_lu_label = i_landuse_type - endif - - patchloop: do while(associated(currentPatch)) - - cp_nocomp_matches_1_if: if ( hlm_use_nocomp .eq. ifalse .or. & - currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then - - patchlabel_matches_lutype_if: if (currentPatch%anthro_disturbance_label .eq. i_landuse_type) then - - disturbance_rate = currentPatch%disturbance_rates(i_disturbance_type) - - if(disturbance_rate > (1.0_r8 + rsnbl_math_prec)) then - write(fates_log(),*) 'patch disturbance rate > 1 ?',disturbance_rate - call dump_patch(currentPatch) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Only create new patches that have non-negligible amount of land - if((currentPatch%area*disturbance_rate) > nearzero ) then - - site_areadis = site_areadis + currentPatch%area * disturbance_rate - - ! track disturbance rates to output to history - currentSite%disturbance_rates(i_disturbance_type) = & - currentSite%disturbance_rates(i_disturbance_type) + & - currentPatch%area * disturbance_rate * AREA_INV + if ( i_disturbance_type .eq. dtype_ilandusechange) then + n_luctype = n_landuse_cats + else + n_luctype = 1 + endif + landusechange_type_loop: do i_landusechange_type = 1, n_luctype - end if + landuse_type_loop: do i_donorpatch_landuse_type = 1, n_landuse_cats +s + ! calculate area of disturbed land, in this timestep, by summing contributions from each existing patch. + currentPatch => currentSite%youngest_patch - end if patchlabel_matches_lutype_if - end if cp_nocomp_matches_1_if - currentPatch => currentPatch%older - enddo patchloop ! end loop over patches. sum area disturbed for all patches. + site_areadis = 0.0_r8 - ! It is possible that no disturbance area was generated - if ( site_areadis > nearzero) then + ! figure out what land use label the receiver patch for disturbance from patches with + ! this disturbance label and disturbance of this type will have + if ( i_disturbance_type .eq. dtype_ilog) then + receiver_patch_lu_label = secondarylands + else + receiver_patch_lu_label = i_donorpatch_landuse_type + endif - age = 0.0_r8 + patchloop: do while(associated(currentPatch)) - ! create an empty patch, to absorb newly disturbed area - allocate(new_patch) + cp_nocomp_matches_1_if: if ( hlm_use_nocomp .eq. ifalse .or. & + currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then - call create_patch(currentSite, new_patch, age, & - site_areadis, receiver_patch_lu_label, i_nocomp_pft) + patchlabel_matches_lutype_if: if (currentPatch%anthro_disturbance_label .eq. i_donorpatch_landuse_type) then - ! Initialize the litter pools to zero, these - ! pools will be populated by looping over the existing patches - ! and transfering in mass - do el=1,num_elements - call new_patch%litter(el)%InitConditions(init_leaf_fines=0._r8, & - init_root_fines=0._r8, & - init_ag_cwd=0._r8, & - init_bg_cwd=0._r8, & - init_seed=0._r8, & - init_seed_germ=0._r8) - end do - new_patch%tallest => null() - new_patch%shortest => null() + if ( i_disturbance_type .ne. dtype_ilandusechange) then + disturbance_rate = currentPatch%disturbance_rates(i_disturbance_type) + else + disturbance_rate = currentPatch%landuse_transition_rates(i_landusechange_type) + endif - endif + if(disturbance_rate > (1.0_r8 + rsnbl_math_prec)) then + write(fates_log(),*) 'patch disturbance rate > 1 ?',disturbance_rate + call dump_patch(currentPatch) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - ! loop round all the patches that contribute surviving indivduals and litter - ! pools to the new patch. We only loop the pre-existing patches, so - ! quit the loop if the current patch is either null, or matches the - ! two new pointers. + ! Only create new patches that have non-negligible amount of land + if((currentPatch%area*disturbance_rate) > nearzero ) then - currentPatch => currentSite%oldest_patch - patchloop: do while(associated(currentPatch)) + site_areadis = site_areadis + currentPatch%area * disturbance_rate - cp_nocomp_matches_2_if: if ( hlm_use_nocomp .eq. ifalse .or. & - currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then + ! track disturbance rates to output to history + currentSite%disturbance_rates(i_disturbance_type) = & + currentSite%disturbance_rates(i_disturbance_type) + & + currentPatch%area * disturbance_rate * AREA_INV - patchlabel_matches_lutype_if: if (currentPatch%anthro_disturbance_label .eq. i_landuse_type) then + end if - ! This is the amount of patch area that is disturbed, and donated by the donor - disturbance_rate = currentPatch%disturbance_rates(i_disturbance_type) - patch_site_areadis = currentPatch%area * disturbance_rate + end if patchlabel_matches_lutype_if + end if cp_nocomp_matches_1_if + currentPatch => currentPatch%older + enddo patchloop ! end loop over patches. sum area disturbed for all patches. + ! It is possible that no disturbance area was generated + if ( site_areadis > nearzero) then - if ( patch_site_areadis > nearzero ) then + age = 0.0_r8 - if(.not.associated(new_patch))then - write(fates_log(),*) 'Patch spawning has attempted to point to' - write(fates_log(),*) 'an un-allocated patch' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + ! create an empty patch, to absorb newly disturbed area + allocate(new_patch) - ! CDK note 03/27 this logic needs to be updated for new logic - ! ! for the case where the donating patch is secondary forest, if - ! ! the current disturbance from this patch is non-anthropogenic, - ! ! we need to average in the time-since-anthropogenic-disturbance - ! ! from the donor patch into that of the receiver patch - ! if ( currentPatch%anthro_disturbance_label .eq. secondarylands .and. & - ! (i_disturbance_type .ne. dtype_ilog) ) then + call create_patch(currentSite, new_patch, age, & + site_areadis, receiver_patch_lu_label, i_nocomp_pft) - ! new_patch%age_since_anthro_disturbance = new_patch%age_since_anthro_disturbance + & - ! currentPatch%age_since_anthro_disturbance * (patch_site_areadis / site_areadis_secondary) + ! Initialize the litter pools to zero, these + ! pools will be populated by looping over the existing patches + ! and transfering in mass + do el=1,num_elements + call new_patch%litter(el)%InitConditions(init_leaf_fines=0._r8, & + init_root_fines=0._r8, & + init_ag_cwd=0._r8, & + init_bg_cwd=0._r8, & + init_seed=0._r8, & + init_seed_germ=0._r8) + end do + new_patch%tallest => null() + new_patch%shortest => null() - ! endif + endif + ! loop round all the patches that contribute surviving indivduals and litter + ! pools to the new patch. We only loop the pre-existing patches, so + ! quit the loop if the current patch is either null, or matches the + ! two new pointers. - ! Transfer the litter existing already in the donor patch to the new patch - ! This call will only transfer non-burned litter to new patch - ! and burned litter to atmosphere. Thus it is important to zero burnt_frac_litter when - ! fire is not the current disturbance regime. + currentPatch => currentSite%oldest_patch + patchloop: do while(associated(currentPatch)) - if(i_disturbance_type .ne. dtype_ifire) then - currentPatch%burnt_frac_litter(:) = 0._r8 - end if + cp_nocomp_matches_2_if: if ( hlm_use_nocomp .eq. ifalse .or. & + currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then - call TransLitterNewPatch( currentSite, currentPatch, new_patch, patch_site_areadis) + patchlabel_matches_lutype_if: if (currentPatch%anthro_disturbance_label .eq. i_donorpatch_landuse_type) then - ! Transfer in litter fluxes from plants in various contexts of death and destruction - if(i_disturbance_type .eq. dtype_ilog) then - call logging_litter_fluxes(currentSite, currentPatch, & - new_patch, patch_site_areadis,bc_in) - elseif(i_disturbance_type .eq. dtype_ifire) then - call fire_litter_fluxes(currentSite, currentPatch, & - new_patch, patch_site_areadis,bc_in) + ! This is the amount of patch area that is disturbed, and donated by the donor + if ( i_disturbance_type .ne. dtype_ilandusechange) then + disturbance_rate = currentPatch%disturbance_rates(i_disturbance_type) else - call mortality_litter_fluxes(currentSite, currentPatch, & - new_patch, patch_site_areadis,bc_in) + disturbance_rate = currentPatch%landuse_transition_rates(i_landusechange_type) endif + patch_site_areadis = currentPatch%area * disturbance_rate - ! Copy any means or timers from the original patch to the new patch - ! These values will inherit all info from the original patch - ! -------------------------------------------------------------------------- - call new_patch%tveg24%CopyFromDonor(currentPatch%tveg24) - call new_patch%tveg_lpa%CopyFromDonor(currentPatch%tveg_lpa) - - - ! -------------------------------------------------------------------------- - ! The newly formed patch from disturbance (new_patch), has now been given - ! some litter from dead plants and pre-existing litter from the donor patches. - ! - ! Next, we loop through the cohorts in the donor patch, copy them with - ! area modified number density into the new-patch, and apply survivorship. - ! ------------------------------------------------------------------------- - - currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - - allocate(nc) - if(hlm_use_planthydro.eq.itrue) call InitHydrCohort(CurrentSite,nc) - - ! Initialize the PARTEH object and point to the - ! correct boundary condition fields - nc%prt => null() - call InitPRTObject(nc%prt) - call InitPRTBoundaryConditions(nc) - - ! (Keeping as an example) - ! Allocate running mean functions - !allocate(nc%tveg_lpa) - !call nc%tveg_lpa%InitRMean(ema_lpa,init_value=new_patch%tveg_lpa%GetMean()) - - call zero_cohort(nc) - - ! nc is the new cohort that goes in the disturbed patch (new_patch)... currentCohort - ! is the curent cohort that stays in the donor patch (currentPatch) - call copy_cohort(currentCohort, nc) - - !this is the case as the new patch probably doesn't have a closed canopy, and - ! even if it does, that will be sorted out in canopy_structure. - nc%canopy_layer = 1 - nc%canopy_layer_yesterday = 1._r8 - - sapw_c = currentCohort%prt%GetState(sapw_organ, carbon12_element) - struct_c = currentCohort%prt%GetState(struct_organ, carbon12_element) - leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element) - fnrt_c = currentCohort%prt%GetState(fnrt_organ, carbon12_element) - store_c = currentCohort%prt%GetState(store_organ, carbon12_element) - total_c = sapw_c + struct_c + leaf_c + fnrt_c + store_c - - ! treefall mortality is the current disturbance - if(i_disturbance_type .eq. dtype_ifall) then - - if(currentCohort%canopy_layer == 1)then - - ! In the donor patch we are left with fewer trees because the area has decreased - ! the plant density for large trees does not actually decrease in the donor patch - ! because this is the part of the original patch where no trees have actually fallen - ! The diagnostic cmort,bmort,hmort, and frmort rates have already been saved - - currentCohort%n = currentCohort%n * (1.0_r8 - fates_mortality_disturbance_fraction * & - min(1.0_r8,currentCohort%dmort * hlm_freq_day)) - - nc%n = 0.0_r8 ! kill all of the trees who caused the disturbance. - - nc%cmort = nan ! The mortality diagnostics are set to nan - ! because the cohort should dissappear - nc%hmort = nan - nc%bmort = nan - nc%frmort = nan - nc%smort = nan - nc%asmort = nan - nc%dgmort = nan - nc%lmort_direct = nan - nc%lmort_collateral = nan - nc%lmort_infra = nan - nc%l_degrad = nan - - else - ! small trees - if( prt_params%woody(currentCohort%pft) == itrue)then - - - ! Survivorship of undestory woody plants. Two step process. - ! Step 1: Reduce current number of plants to reflect the - ! change in area. - ! The number density per square are doesn't change, - ! but since the patch is smaller and cohort counts - ! are absolute, reduce this number. - nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + if ( patch_site_areadis > nearzero ) then - ! because the mortality rate due to impact for the cohorts which - ! had been in the understory and are now in the newly- - ! disturbed patch is very high, passing the imort directly to history - ! results in large numerical errors, on account of the sharply - ! reduced number densities. so instead pass this info via a - ! site-level diagnostic variable before reducing the number density. - - currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) = & - currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) + & - nc%n * ED_val_understorey_death / hlm_freq_day + if(.not.associated(new_patch))then + write(fates_log(),*) 'Patch spawning has attempted to point to' + write(fates_log(),*) 'an un-allocated patch' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + ! for the case where the donating patch is not primary, if + ! the current disturbance from this patch is non-anthropogenic, + ! we need to average in the time-since-anthropogenic-disturbance + ! from the donor patch into that of the receiver patch + if ( currentPatch%anthro_disturbance_label .gt. primarylands .and. & + (i_disturbance_type .lt. dtype_ilog) ) then - currentSite%imort_carbonflux(currentCohort%pft) = & - currentSite%imort_carbonflux(currentCohort%pft) + & - (nc%n * ED_val_understorey_death / hlm_freq_day ) * & - total_c * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + new_patch%age_since_anthro_disturbance = new_patch%age_since_anthro_disturbance + & + currentPatch%age_since_anthro_disturbance * (patch_site_areadis / site_areadis) + endif - currentSite%imort_abg_flux(currentCohort%size_class, currentCohort%pft) = & - currentSite%imort_abg_flux(currentCohort%size_class, currentCohort%pft) + & - (nc%n * ED_val_understorey_death / hlm_freq_day ) * & - ( (sapw_c + struct_c + store_c) * prt_params%allom_agb_frac(currentCohort%pft) + & - leaf_c ) * & - g_per_kg * days_per_sec * years_per_day * ha_per_m2 + ! Transfer the litter existing already in the donor patch to the new patch + ! This call will only transfer non-burned litter to new patch + ! and burned litter to atmosphere. Thus it is important to zero burnt_frac_litter when + ! fire is not the current disturbance regime. + if(i_disturbance_type .ne. dtype_ifire) then + currentPatch%burnt_frac_litter(:) = 0._r8 + end if - ! Step 2: Apply survivor ship function based on the understory death fraction - ! remaining of understory plants of those that are knocked over - ! by the overstorey trees dying... - nc%n = nc%n * (1.0_r8 - ED_val_understorey_death) + call TransLitterNewPatch( currentSite, currentPatch, new_patch, patch_site_areadis) - ! since the donor patch split and sent a fraction of its members - ! to the new patch and a fraction to be preserved in itself, - ! when reporting diagnostic rates, we must carry over the mortality rates from - ! the donor that were applied before the patch split. Remember this is only - ! for diagnostics. But think of it this way, the rates are weighted by - ! number density in EDCLMLink, and the number density of this new patch is donated - ! so with the number density must come the effective mortality rates. + ! Transfer in litter fluxes from plants in various contexts of death and destruction - nc%cmort = currentCohort%cmort - nc%hmort = currentCohort%hmort - nc%bmort = currentCohort%bmort - nc%frmort = currentCohort%frmort - nc%smort = currentCohort%smort - nc%asmort = currentCohort%asmort - nc%dgmort = currentCohort%dgmort - nc%dmort = currentCohort%dmort - nc%lmort_direct = currentCohort%lmort_direct - nc%lmort_collateral = currentCohort%lmort_collateral - nc%lmort_infra = currentCohort%lmort_infra + ! CDK what do we do here for land use transitions? + if(i_disturbance_type .eq. dtype_ilog) then + call logging_litter_fluxes(currentSite, currentPatch, & + new_patch, patch_site_areadis,bc_in) + elseif(i_disturbance_type .eq. dtype_ifire) then + call fire_litter_fluxes(currentSite, currentPatch, & + new_patch, patch_site_areadis,bc_in) + else + call mortality_litter_fluxes(currentSite, currentPatch, & + new_patch, patch_site_areadis,bc_in) + endif - ! understory trees that might potentially be knocked over in the disturbance. - ! The existing (donor) patch should not have any impact mortality, it should - ! only lose cohorts due to the decrease in area. This is not mortality. - ! Besides, the current and newly created patch sum to unity - currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + ! Copy any means or timers from the original patch to the new patch + ! These values will inherit all info from the original patch + ! -------------------------------------------------------------------------- + call new_patch%tveg24%CopyFromDonor(currentPatch%tveg24) + call new_patch%tveg_lpa%CopyFromDonor(currentPatch%tveg_lpa) + + + ! -------------------------------------------------------------------------- + ! The newly formed patch from disturbance (new_patch), has now been given + ! some litter from dead plants and pre-existing litter from the donor patches. + ! + ! Next, we loop through the cohorts in the donor patch, copy them with + ! area modified number density into the new-patch, and apply survivorship. + ! ------------------------------------------------------------------------- + + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + + allocate(nc) + if(hlm_use_planthydro.eq.itrue) call InitHydrCohort(CurrentSite,nc) + + ! Initialize the PARTEH object and point to the + ! correct boundary condition fields + nc%prt => null() + call InitPRTObject(nc%prt) + call InitPRTBoundaryConditions(nc) + + ! (Keeping as an example) + ! Allocate running mean functions + !allocate(nc%tveg_lpa) + !call nc%tveg_lpa%InitRMean(ema_lpa,init_value=new_patch%tveg_lpa%GetMean()) + + call zero_cohort(nc) + + ! nc is the new cohort that goes in the disturbed patch (new_patch)... currentCohort + ! is the curent cohort that stays in the donor patch (currentPatch) + call copy_cohort(currentCohort, nc) + + !this is the case as the new patch probably doesn't have a closed canopy, and + ! even if it does, that will be sorted out in canopy_structure. + nc%canopy_layer = 1 + nc%canopy_layer_yesterday = 1._r8 + + sapw_c = currentCohort%prt%GetState(sapw_organ, carbon12_element) + struct_c = currentCohort%prt%GetState(struct_organ, carbon12_element) + leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element) + fnrt_c = currentCohort%prt%GetState(fnrt_organ, carbon12_element) + store_c = currentCohort%prt%GetState(store_organ, carbon12_element) + total_c = sapw_c + struct_c + leaf_c + fnrt_c + store_c + + ! treefall mortality is the current disturbance + if(i_disturbance_type .eq. dtype_ifall) then + + if(currentCohort%canopy_layer == 1)then + + ! In the donor patch we are left with fewer trees because the area has decreased + ! the plant density for large trees does not actually decrease in the donor patch + ! because this is the part of the original patch where no trees have actually fallen + ! The diagnostic cmort,bmort,hmort, and frmort rates have already been saved + + currentCohort%n = currentCohort%n * (1.0_r8 - fates_mortality_disturbance_fraction * & + min(1.0_r8,currentCohort%dmort * hlm_freq_day)) + + nc%n = 0.0_r8 ! kill all of the trees who caused the disturbance. + + nc%cmort = nan ! The mortality diagnostics are set to nan + ! because the cohort should dissappear + nc%hmort = nan + nc%bmort = nan + nc%frmort = nan + nc%smort = nan + nc%asmort = nan + nc%dgmort = nan + nc%lmort_direct = nan + nc%lmort_collateral = nan + nc%lmort_infra = nan + nc%l_degrad = nan else - ! grass is not killed by mortality disturbance events. Just move it into the new patch area. - ! Just split the grass into the existing and new patch structures - nc%n = currentCohort%n * patch_site_areadis/currentPatch%area - - ! Those remaining in the existing - currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) - - nc%cmort = currentCohort%cmort - nc%hmort = currentCohort%hmort - nc%bmort = currentCohort%bmort - nc%frmort = currentCohort%frmort - nc%smort = currentCohort%smort - nc%asmort = currentCohort%asmort - nc%dgmort = currentCohort%dgmort - nc%dmort = currentCohort%dmort - nc%lmort_direct = currentCohort%lmort_direct - nc%lmort_collateral = currentCohort%lmort_collateral - nc%lmort_infra = currentCohort%lmort_infra - + ! small trees + if( prt_params%woody(currentCohort%pft) == itrue)then + + + ! Survivorship of undestory woody plants. Two step process. + ! Step 1: Reduce current number of plants to reflect the + ! change in area. + ! The number density per square are doesn't change, + ! but since the patch is smaller and cohort counts + ! are absolute, reduce this number. + + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + + ! because the mortality rate due to impact for the cohorts which + ! had been in the understory and are now in the newly- + ! disturbed patch is very high, passing the imort directly to history + ! results in large numerical errors, on account of the sharply + ! reduced number densities. so instead pass this info via a + ! site-level diagnostic variable before reducing the number density. + + currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) = & + currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) + & + nc%n * ED_val_understorey_death / hlm_freq_day + + + currentSite%imort_carbonflux(currentCohort%pft) = & + currentSite%imort_carbonflux(currentCohort%pft) + & + (nc%n * ED_val_understorey_death / hlm_freq_day ) * & + total_c * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + + currentSite%imort_abg_flux(currentCohort%size_class, currentCohort%pft) = & + currentSite%imort_abg_flux(currentCohort%size_class, currentCohort%pft) + & + (nc%n * ED_val_understorey_death / hlm_freq_day ) * & + ( (sapw_c + struct_c + store_c) * prt_params%allom_agb_frac(currentCohort%pft) + & + leaf_c ) * & + g_per_kg * days_per_sec * years_per_day * ha_per_m2 + + + ! Step 2: Apply survivor ship function based on the understory death fraction + ! remaining of understory plants of those that are knocked over + ! by the overstorey trees dying... + nc%n = nc%n * (1.0_r8 - ED_val_understorey_death) + + ! since the donor patch split and sent a fraction of its members + ! to the new patch and a fraction to be preserved in itself, + ! when reporting diagnostic rates, we must carry over the mortality rates from + ! the donor that were applied before the patch split. Remember this is only + ! for diagnostics. But think of it this way, the rates are weighted by + ! number density in EDCLMLink, and the number density of this new patch is donated + ! so with the number density must come the effective mortality rates. + + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + nc%frmort = currentCohort%frmort + nc%smort = currentCohort%smort + nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort + nc%dmort = currentCohort%dmort + nc%lmort_direct = currentCohort%lmort_direct + nc%lmort_collateral = currentCohort%lmort_collateral + nc%lmort_infra = currentCohort%lmort_infra + + ! understory trees that might potentially be knocked over in the disturbance. + ! The existing (donor) patch should not have any impact mortality, it should + ! only lose cohorts due to the decrease in area. This is not mortality. + ! Besides, the current and newly created patch sum to unity + + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + + else + ! grass is not killed by mortality disturbance events. Just move it into the new patch area. + ! Just split the grass into the existing and new patch structures + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + + ! Those remaining in the existing + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + nc%frmort = currentCohort%frmort + nc%smort = currentCohort%smort + nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort + nc%dmort = currentCohort%dmort + nc%lmort_direct = currentCohort%lmort_direct + nc%lmort_collateral = currentCohort%lmort_collateral + nc%lmort_infra = currentCohort%lmort_infra + + endif endif - endif - ! Fire is the current disturbance - elseif (i_disturbance_type .eq. dtype_ifire ) then + ! Fire is the current disturbance + elseif (i_disturbance_type .eq. dtype_ifire ) then - ! Number of members in the new patch, before we impose fire survivorship - nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + ! Number of members in the new patch, before we impose fire survivorship + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area - ! loss of individuals from source patch due to area shrinking - currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + ! loss of individuals from source patch due to area shrinking + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) - levcan = currentCohort%canopy_layer + levcan = currentCohort%canopy_layer - if(levcan==ican_upper) then + if(levcan==ican_upper) then - ! before changing number densities, track total rate of trees that died - ! due to fire, as well as from each fire mortality term - currentSite%fmort_rate_canopy(currentCohort%size_class, currentCohort%pft) = & - currentSite%fmort_rate_canopy(currentCohort%size_class, currentCohort%pft) + & - nc%n * currentCohort%fire_mort / hlm_freq_day + ! before changing number densities, track total rate of trees that died + ! due to fire, as well as from each fire mortality term + currentSite%fmort_rate_canopy(currentCohort%size_class, currentCohort%pft) = & + currentSite%fmort_rate_canopy(currentCohort%size_class, currentCohort%pft) + & + nc%n * currentCohort%fire_mort / hlm_freq_day - currentSite%fmort_carbonflux_canopy(currentCohort%pft) = & - currentSite%fmort_carbonflux_canopy(currentCohort%pft) + & - (nc%n * currentCohort%fire_mort) * & - total_c * g_per_kg * days_per_sec * ha_per_m2 + currentSite%fmort_carbonflux_canopy(currentCohort%pft) = & + currentSite%fmort_carbonflux_canopy(currentCohort%pft) + & + (nc%n * currentCohort%fire_mort) * & + total_c * g_per_kg * days_per_sec * ha_per_m2 - else - currentSite%fmort_rate_ustory(currentCohort%size_class, currentCohort%pft) = & - currentSite%fmort_rate_ustory(currentCohort%size_class, currentCohort%pft) + & - nc%n * currentCohort%fire_mort / hlm_freq_day - - currentSite%fmort_carbonflux_ustory(currentCohort%pft) = & - currentSite%fmort_carbonflux_ustory(currentCohort%pft) + & + else + currentSite%fmort_rate_ustory(currentCohort%size_class, currentCohort%pft) = & + currentSite%fmort_rate_ustory(currentCohort%size_class, currentCohort%pft) + & + nc%n * currentCohort%fire_mort / hlm_freq_day + + currentSite%fmort_carbonflux_ustory(currentCohort%pft) = & + currentSite%fmort_carbonflux_ustory(currentCohort%pft) + & + (nc%n * currentCohort%fire_mort) * & + total_c * g_per_kg * days_per_sec * ha_per_m2 + end if + + currentSite%fmort_abg_flux(currentCohort%size_class, currentCohort%pft) = & + currentSite%fmort_abg_flux(currentCohort%size_class, currentCohort%pft) + & (nc%n * currentCohort%fire_mort) * & - total_c * g_per_kg * days_per_sec * ha_per_m2 - end if - - currentSite%fmort_abg_flux(currentCohort%size_class, currentCohort%pft) = & - currentSite%fmort_abg_flux(currentCohort%size_class, currentCohort%pft) + & - (nc%n * currentCohort%fire_mort) * & - ( (sapw_c + struct_c + store_c) * prt_params%allom_agb_frac(currentCohort%pft) + & - leaf_c ) * & - g_per_kg * days_per_sec * ha_per_m2 - - - currentSite%fmort_rate_cambial(currentCohort%size_class, currentCohort%pft) = & - currentSite%fmort_rate_cambial(currentCohort%size_class, currentCohort%pft) + & - nc%n * currentCohort%cambial_mort / hlm_freq_day - currentSite%fmort_rate_crown(currentCohort%size_class, currentCohort%pft) = & - currentSite%fmort_rate_crown(currentCohort%size_class, currentCohort%pft) + & - nc%n * currentCohort%crownfire_mort / hlm_freq_day - - ! loss of individual from fire in new patch. - nc%n = nc%n * (1.0_r8 - currentCohort%fire_mort) - - nc%cmort = currentCohort%cmort - nc%hmort = currentCohort%hmort - nc%bmort = currentCohort%bmort - nc%frmort = currentCohort%frmort - nc%smort = currentCohort%smort - nc%asmort = currentCohort%asmort - nc%dgmort = currentCohort%dgmort - nc%dmort = currentCohort%dmort - nc%lmort_direct = currentCohort%lmort_direct - nc%lmort_collateral = currentCohort%lmort_collateral - nc%lmort_infra = currentCohort%lmort_infra - - - ! Some of of the leaf mass from living plants has been - ! burned off. Here, we remove that mass, and - ! tally it in the flux we sent to the atmosphere - - if(prt_params%woody(currentCohort%pft) == itrue)then - leaf_burn_frac = currentCohort%fraction_crown_burned - else + ( (sapw_c + struct_c + store_c) * prt_params%allom_agb_frac(currentCohort%pft) + & + leaf_c ) * & + g_per_kg * days_per_sec * ha_per_m2 - ! Grasses determine their fraction of leaves burned here - leaf_burn_frac = currentPatch%burnt_frac_litter(lg_sf) - endif + currentSite%fmort_rate_cambial(currentCohort%size_class, currentCohort%pft) = & + currentSite%fmort_rate_cambial(currentCohort%size_class, currentCohort%pft) + & + nc%n * currentCohort%cambial_mort / hlm_freq_day + currentSite%fmort_rate_crown(currentCohort%size_class, currentCohort%pft) = & + currentSite%fmort_rate_crown(currentCohort%size_class, currentCohort%pft) + & + nc%n * currentCohort%crownfire_mort / hlm_freq_day - ! Perform a check to make sure that spitfire gave - ! us reasonable mortality and burn fraction rates - - if( (leaf_burn_frac < 0._r8) .or. & - (leaf_burn_frac > 1._r8) .or. & - (currentCohort%fire_mort < 0._r8) .or. & - (currentCohort%fire_mort > 1._r8)) then - write(fates_log(),*) 'unexpected fire fractions' - write(fates_log(),*) prt_params%woody(currentCohort%pft) - write(fates_log(),*) leaf_burn_frac - write(fates_log(),*) currentCohort%fire_mort - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + ! loss of individual from fire in new patch. + nc%n = nc%n * (1.0_r8 - currentCohort%fire_mort) - do el = 1,num_elements + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + nc%frmort = currentCohort%frmort + nc%smort = currentCohort%smort + nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort + nc%dmort = currentCohort%dmort + nc%lmort_direct = currentCohort%lmort_direct + nc%lmort_collateral = currentCohort%lmort_collateral + nc%lmort_infra = currentCohort%lmort_infra - leaf_m = nc%prt%GetState(leaf_organ, element_list(el)) - ! for woody plants burn only leaves - if(int(prt_params%woody(currentCohort%pft)) == itrue)then - leaf_m = nc%prt%GetState(leaf_organ, element_list(el)) + ! Some of of the leaf mass from living plants has been + ! burned off. Here, we remove that mass, and + ! tally it in the flux we sent to the atmosphere + if(prt_params%woody(currentCohort%pft) == itrue)then + leaf_burn_frac = currentCohort%fraction_crown_burned else - ! for grasses burn all aboveground tissues - leaf_m = nc%prt%GetState(leaf_organ, element_list(el)) + & - nc%prt%GetState(sapw_organ, element_list(el)) + & - nc%prt%GetState(struct_organ, element_list(el)) + ! Grasses determine their fraction of leaves burned here + + leaf_burn_frac = currentPatch%burnt_frac_litter(lg_sf) endif - currentSite%mass_balance(el)%burn_flux_to_atm = & - currentSite%mass_balance(el)%burn_flux_to_atm + & - leaf_burn_frac * leaf_m * nc%n - end do + ! Perform a check to make sure that spitfire gave + ! us reasonable mortality and burn fraction rates - ! Here the mass is removed from the plant + if( (leaf_burn_frac < 0._r8) .or. & + (leaf_burn_frac > 1._r8) .or. & + (currentCohort%fire_mort < 0._r8) .or. & + (currentCohort%fire_mort > 1._r8)) then + write(fates_log(),*) 'unexpected fire fractions' + write(fates_log(),*) prt_params%woody(currentCohort%pft) + write(fates_log(),*) leaf_burn_frac + write(fates_log(),*) currentCohort%fire_mort + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - if(int(prt_params%woody(currentCohort%pft)) == itrue)then - call PRTBurnLosses(nc%prt, leaf_organ, leaf_burn_frac) - else - call PRTBurnLosses(nc%prt, leaf_organ, leaf_burn_frac) - call PRTBurnLosses(nc%prt, sapw_organ, leaf_burn_frac) - call PRTBurnLosses(nc%prt, struct_organ, leaf_burn_frac) - endif + do el = 1,num_elements - currentCohort%fraction_crown_burned = 0.0_r8 - nc%fraction_crown_burned = 0.0_r8 + leaf_m = nc%prt%GetState(leaf_organ, element_list(el)) + ! for woody plants burn only leaves + if(int(prt_params%woody(currentCohort%pft)) == itrue)then + leaf_m = nc%prt%GetState(leaf_organ, element_list(el)) + else + ! for grasses burn all aboveground tissues + leaf_m = nc%prt%GetState(leaf_organ, element_list(el)) + & + nc%prt%GetState(sapw_organ, element_list(el)) + & + nc%prt%GetState(struct_organ, element_list(el)) - ! Logging is the current disturbance - elseif (i_disturbance_type .eq. dtype_ilog ) then + endif - ! If this cohort is in the upper canopy. It generated - if(currentCohort%canopy_layer == 1)then + currentSite%mass_balance(el)%burn_flux_to_atm = & + currentSite%mass_balance(el)%burn_flux_to_atm + & + leaf_burn_frac * leaf_m * nc%n + end do - ! calculate the survivorship of disturbed trees because non-harvested - nc%n = currentCohort%n * currentCohort%l_degrad - ! nc%n = (currentCohort%l_degrad / (currentCohort%l_degrad + & - ! currentCohort%lmort_direct + currentCohort%lmort_collateral + - ! currentCohort%lmort_infra) ) * & - ! currentCohort%n * patch_site_areadis/currentPatch%area + ! Here the mass is removed from the plant - ! Reduce counts in the existing/donor patch according to the logging rate - currentCohort%n = currentCohort%n * & - (1.0_r8 - min(1.0_r8,(currentCohort%lmort_direct + & - currentCohort%lmort_collateral + & - currentCohort%lmort_infra + currentCohort%l_degrad))) + if(int(prt_params%woody(currentCohort%pft)) == itrue)then + call PRTBurnLosses(nc%prt, leaf_organ, leaf_burn_frac) + else + call PRTBurnLosses(nc%prt, leaf_organ, leaf_burn_frac) + call PRTBurnLosses(nc%prt, sapw_organ, leaf_burn_frac) + call PRTBurnLosses(nc%prt, struct_organ, leaf_burn_frac) + endif - nc%cmort = currentCohort%cmort - nc%hmort = currentCohort%hmort - nc%bmort = currentCohort%bmort - nc%frmort = currentCohort%frmort - nc%smort = currentCohort%smort - nc%asmort = currentCohort%asmort - nc%dgmort = currentCohort%dgmort - nc%dmort = currentCohort%dmort + currentCohort%fraction_crown_burned = 0.0_r8 + nc%fraction_crown_burned = 0.0_r8 - ! since these are the ones that weren't logged, - ! set the logging mortality rates as zero - nc%lmort_direct = 0._r8 - nc%lmort_collateral = 0._r8 - nc%lmort_infra = 0._r8 - else - ! What to do with cohorts in the understory of a logging generated - ! disturbance patch? + ! Logging is the current disturbance + elseif (i_disturbance_type .eq. dtype_ilog ) then - if(prt_params%woody(currentCohort%pft) == itrue)then + ! If this cohort is in the upper canopy. It generated + if(currentCohort%canopy_layer == 1)then + ! calculate the survivorship of disturbed trees because non-harvested + nc%n = currentCohort%n * currentCohort%l_degrad + ! nc%n = (currentCohort%l_degrad / (currentCohort%l_degrad + & + ! currentCohort%lmort_direct + currentCohort%lmort_collateral + + ! currentCohort%lmort_infra) ) * & + ! currentCohort%n * patch_site_areadis/currentPatch%area - ! Survivorship of undestory woody plants. Two step process. - ! Step 1: Reduce current number of plants to reflect the - ! change in area. - ! The number density per square are doesn't change, - ! but since the patch is smaller - ! and cohort counts are absolute, reduce this number. - nc%n = currentCohort%n * patch_site_areadis/currentPatch%area - - ! because the mortality rate due to impact for the cohorts which had - ! been in the understory and are now in the newly- - ! disturbed patch is very high, passing the imort directly to - ! history results in large numerical errors, on account - ! of the sharply reduced number densities. so instead pass this info - ! via a site-level diagnostic variable before reducing - ! the number density. - currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) = & - currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) + & - nc%n * currentPatch%fract_ldist_not_harvested * & - logging_coll_under_frac / hlm_freq_day - - currentSite%imort_carbonflux(currentCohort%pft) = & - currentSite%imort_carbonflux(currentCohort%pft) + & - (nc%n * currentPatch%fract_ldist_not_harvested * & - logging_coll_under_frac/ hlm_freq_day ) * & - total_c * g_per_kg * days_per_sec * years_per_day * ha_per_m2 - - - ! Step 2: Apply survivor ship function based on the understory death fraction - - ! remaining of understory plants of those that are knocked - ! over by the overstorey trees dying... - ! LOGGING SURVIVORSHIP OF UNDERSTORY PLANTS IS SET AS A NEW PARAMETER - ! in the fatesparameter files - nc%n = nc%n * (1.0_r8 - & - (1.0_r8-currentPatch%fract_ldist_not_harvested) * logging_coll_under_frac) - - ! Step 3: Reduce the number count of cohorts in the - ! original/donor/non-disturbed patch to reflect the area change - currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + ! Reduce counts in the existing/donor patch according to the logging rate + currentCohort%n = currentCohort%n * & + (1.0_r8 - min(1.0_r8,(currentCohort%lmort_direct + & + currentCohort%lmort_collateral + & + currentCohort%lmort_infra + currentCohort%l_degrad))) nc%cmort = currentCohort%cmort nc%hmort = currentCohort%hmort @@ -1010,172 +967,256 @@ subroutine spawn_patches( currentSite, bc_in) nc%asmort = currentCohort%asmort nc%dgmort = currentCohort%dgmort nc%dmort = currentCohort%dmort - nc%lmort_direct = currentCohort%lmort_direct - nc%lmort_collateral = currentCohort%lmort_collateral - nc%lmort_infra = currentCohort%lmort_infra - - else - ! grass is not killed by mortality disturbance events. - ! Just move it into the new patch area. - ! Just split the grass into the existing and new patch structures - nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + ! since these are the ones that weren't logged, + ! set the logging mortality rates as zero + nc%lmort_direct = 0._r8 + nc%lmort_collateral = 0._r8 + nc%lmort_infra = 0._r8 - ! Those remaining in the existing - currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + else - ! No grass impact mortality imposed on the newly created patch - nc%cmort = currentCohort%cmort - nc%hmort = currentCohort%hmort - nc%bmort = currentCohort%bmort - nc%frmort = currentCohort%frmort - nc%smort = currentCohort%smort - nc%asmort = currentCohort%asmort - nc%dgmort = currentCohort%dgmort - nc%dmort = currentCohort%dmort - nc%lmort_direct = currentCohort%lmort_direct - nc%lmort_collateral = currentCohort%lmort_collateral - nc%lmort_infra = currentCohort%lmort_infra + ! What to do with cohorts in the understory of a logging generated + ! disturbance patch? + + if(prt_params%woody(currentCohort%pft) == itrue)then + + + ! Survivorship of undestory woody plants. Two step process. + ! Step 1: Reduce current number of plants to reflect the + ! change in area. + ! The number density per square are doesn't change, + ! but since the patch is smaller + ! and cohort counts are absolute, reduce this number. + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + + ! because the mortality rate due to impact for the cohorts which had + ! been in the understory and are now in the newly- + ! disturbed patch is very high, passing the imort directly to + ! history results in large numerical errors, on account + ! of the sharply reduced number densities. so instead pass this info + ! via a site-level diagnostic variable before reducing + ! the number density. + currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) = & + currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) + & + nc%n * currentPatch%fract_ldist_not_harvested * & + logging_coll_under_frac / hlm_freq_day + + currentSite%imort_carbonflux(currentCohort%pft) = & + currentSite%imort_carbonflux(currentCohort%pft) + & + (nc%n * currentPatch%fract_ldist_not_harvested * & + logging_coll_under_frac/ hlm_freq_day ) * & + total_c * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + + + ! Step 2: Apply survivor ship function based on the understory death fraction + + ! remaining of understory plants of those that are knocked + ! over by the overstorey trees dying... + ! LOGGING SURVIVORSHIP OF UNDERSTORY PLANTS IS SET AS A NEW PARAMETER + ! in the fatesparameter files + nc%n = nc%n * (1.0_r8 - & + (1.0_r8-currentPatch%fract_ldist_not_harvested) * logging_coll_under_frac) + + ! Step 3: Reduce the number count of cohorts in the + ! original/donor/non-disturbed patch to reflect the area change + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + nc%frmort = currentCohort%frmort + nc%smort = currentCohort%smort + nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort + nc%dmort = currentCohort%dmort + nc%lmort_direct = currentCohort%lmort_direct + nc%lmort_collateral = currentCohort%lmort_collateral + nc%lmort_infra = currentCohort%lmort_infra + + else + + ! grass is not killed by mortality disturbance events. + ! Just move it into the new patch area. + ! Just split the grass into the existing and new patch structures + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + + ! Those remaining in the existing + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + + ! No grass impact mortality imposed on the newly created patch + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + nc%frmort = currentCohort%frmort + nc%smort = currentCohort%smort + nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort + nc%dmort = currentCohort%dmort + nc%lmort_direct = currentCohort%lmort_direct + nc%lmort_collateral = currentCohort%lmort_collateral + nc%lmort_infra = currentCohort%lmort_infra + + endif ! is/is-not woody + + endif ! Select canopy layer + + + elseif (i_disturbance_type .eq. dtype_ilandusechange ) then + + ! Number of members in the new patch, before we impose LUC survivorship + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + + ! loss of individuals from source patch due to area shrinking + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + + ! now apply survivorship based on the type of landuse transition - endif ! is/is-not woody + else + write(fates_log(),*) 'unknown disturbance mode?' + write(fates_log(),*) 'i_disturbance_type: ',i_disturbance_type + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if ! Select disturbance mode - endif ! Select canopy layer + if (nc%n > 0.0_r8) then + storebigcohort => new_patch%tallest + storesmallcohort => new_patch%shortest + if(associated(new_patch%tallest))then + tnull = 0 + else + tnull = 1 + new_patch%tallest => nc + nc%taller => null() + endif - else - write(fates_log(),*) 'unknown disturbance mode?' - write(fates_log(),*) 'i_disturbance_type: ',i_disturbance_type - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if ! Select disturbance mode + if(associated(new_patch%shortest))then + snull = 0 + else + snull = 1 + new_patch%shortest => nc + nc%shorter => null() + endif + nc%patchptr => new_patch + call insert_cohort(nc, new_patch%tallest, new_patch%shortest, & + tnull, snull, storebigcohort, storesmallcohort) - if (nc%n > 0.0_r8) then - storebigcohort => new_patch%tallest - storesmallcohort => new_patch%shortest - if(associated(new_patch%tallest))then - tnull = 0 + new_patch%tallest => storebigcohort + new_patch%shortest => storesmallcohort else - tnull = 1 - new_patch%tallest => nc - nc%taller => null() - endif - if(associated(new_patch%shortest))then - snull = 0 - else - snull = 1 - new_patch%shortest => nc - nc%shorter => null() + ! Get rid of the new temporary cohort + call DeallocateCohort(nc) + deallocate(nc, stat=istat, errmsg=smsg) + if (istat/=0) then + write(fates_log(),*) 'dealloc005: fail on deallocate(nc):'//trim(smsg) + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif endif - nc%patchptr => new_patch - call insert_cohort(nc, new_patch%tallest, new_patch%shortest, & - tnull, snull, storebigcohort, storesmallcohort) - new_patch%tallest => storebigcohort - new_patch%shortest => storesmallcohort - else + currentCohort => currentCohort%taller + enddo ! currentCohort + call sort_cohorts(currentPatch) - ! Get rid of the new temporary cohort - call DeallocateCohort(nc) - deallocate(nc, stat=istat, errmsg=smsg) - if (istat/=0) then - write(fates_log(),*) 'dealloc005: fail on deallocate(nc):'//trim(smsg) - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - endif + !update area of donor patch + oldarea = currentPatch%area + currentPatch%area = currentPatch%area - patch_site_areadis - currentCohort => currentCohort%taller - enddo ! currentCohort - call sort_cohorts(currentPatch) - - !update area of donor patch - oldarea = currentPatch%area - currentPatch%area = currentPatch%area - patch_site_areadis - - ! for all disturbance rates that haven't been resolved yet, increase their amount so that - ! they are the same amount of gridcell-scale disturbance relative to the original patch size - if (i_disturbance_type .ne. N_DIST_TYPES) then - do i_dist2 = i_disturbance_type+1,N_DIST_TYPES - currentPatch%disturbance_rates(i_dist2) = currentPatch%disturbance_rates(i_dist2) & - * oldarea / currentPatch%area - end do - end if + ! for all disturbance rates that haven't been resolved yet, increase their amount so that + ! they are the same amount of gridcell-scale disturbance relative to the original patch size + if (i_disturbance_type .lt. N_DIST_TYPES) then + do i_dist2 = i_disturbance_type+1,N_DIST_TYPES-1 + currentPatch%disturbance_rates(i_dist2) = currentPatch%disturbance_rates(i_dist2) & + * oldarea / currentPatch%area + end do + do i_dist = 1,n_landuse_cats + currentPatch%landuse_transition_rates(i_dist) = currentPatch%landuse_transition_rates(i_dist) & + * oldarea / currentPatch%area + end do + else + do i_dist = i_lu_change+1,n_landuse_cats + currentPatch%landuse_transition_rates(i_dist) = currentPatch%landuse_transition_rates(i_dist) & + * oldarea / currentPatch%area + end do + end if - ! sort out the cohorts, since some of them may be so small as to need removing. - ! the first call to terminate cohorts removes sparse number densities, - ! the second call removes for all other reasons (sparse culling must happen - ! before fusion) - call terminate_cohorts(currentSite, currentPatch, 1,16,bc_in) - call fuse_cohorts(currentSite,currentPatch, bc_in) - call terminate_cohorts(currentSite, currentPatch, 2,16,bc_in) - call sort_cohorts(currentPatch) + ! sort out the cohorts, since some of them may be so small as to need removing. + ! the first call to terminate cohorts removes sparse number densities, + ! the second call removes for all other reasons (sparse culling must happen + ! before fusion) + call terminate_cohorts(currentSite, currentPatch, 1,16,bc_in) + call fuse_cohorts(currentSite,currentPatch, bc_in) + call terminate_cohorts(currentSite, currentPatch, 2,16,bc_in) + call sort_cohorts(currentPatch) - end if ! if ( new_patch%area > nearzero ) then + end if ! if ( new_patch%area > nearzero ) then - end if patchlabel_matches_lutype_if + end if patchlabel_matches_lutype_if - end if cp_nocomp_matches_2_if - currentPatch => currentPatch%younger + end if cp_nocomp_matches_2_if + currentPatch => currentPatch%younger - enddo patchloop ! currentPatch patch loop. + enddo patchloop ! currentPatch patch loop. - !*************************/ - !** INSERT NEW PATCH(ES) INTO LINKED LIST - !*************************/ + !*************************/ + !** INSERT NEW PATCH(ES) INTO LINKED LIST + !*************************/ - if ( site_areadis .gt. nearzero) then - currentPatch => currentSite%youngest_patch + if ( site_areadis .gt. nearzero) then + currentPatch => currentSite%youngest_patch !!!CDK 3/27 need change this logic. put the new patch as younger than any patches with the same labels - ! insert new youngest primary patch after all the secondary patches, if there are any. - ! this requires first finding the current youngest primary to insert the new one ahead of - if (currentPatch%anthro_disturbance_label .eq. secondarylands ) then - found_youngest_primary = .false. - do while(associated(currentPatch) .and. .not. found_youngest_primary) - currentPatch => currentPatch%older - if (associated(currentPatch)) then - if (currentPatch%anthro_disturbance_label .eq. primarylands) then - found_youngest_primary = .true. + ! insert new youngest primary patch after all the secondary patches, if there are any. + ! this requires first finding the current youngest primary to insert the new one ahead of + if (currentPatch%anthro_disturbance_label .eq. secondarylands ) then + found_youngest_primary = .false. + do while(associated(currentPatch) .and. .not. found_youngest_primary) + currentPatch => currentPatch%older + if (associated(currentPatch)) then + if (currentPatch%anthro_disturbance_label .eq. primarylands) then + found_youngest_primary = .true. + endif endif + end do + if (associated(currentPatch)) then + ! the case where we've found a youngest primary patch + new_patch_primary%older => currentPatch + new_patch_primary%younger => currentPatch%younger + currentPatch%younger%older => new_patch + currentPatch%younger => new_patch + else + ! the case where we haven't, because the patches are all secondaary, + ! and are putting a primary patch at the oldest end of the + ! linked list (not sure how this could happen, but who knows...) + new_patch_primary%older => null() + new_patch_primary%younger => currentSite%oldest_patch + currentSite%oldest_patch%older => new_patch + currentSite%oldest_patch => new_patch endif - end do - if (associated(currentPatch)) then - ! the case where we've found a youngest primary patch + else + ! the case where there are no secondary patches at the start of the linked list (prior logic) new_patch_primary%older => currentPatch - new_patch_primary%younger => currentPatch%younger - currentPatch%younger%older => new_patch + new_patch_primary%younger => null() currentPatch%younger => new_patch - else - ! the case where we haven't, because the patches are all secondaary, - ! and are putting a primary patch at the oldest end of the - ! linked list (not sure how this could happen, but who knows...) - new_patch_primary%older => null() - new_patch_primary%younger => currentSite%oldest_patch - currentSite%oldest_patch%older => new_patch - currentSite%oldest_patch => new_patch + currentSite%youngest_patch => new_patch endif - else - ! the case where there are no secondary patches at the start of the linked list (prior logic) - new_patch_primary%older => currentPatch - new_patch_primary%younger => null() - currentPatch%younger => new_patch - currentSite%youngest_patch => new_patch - endif - ! sort out the cohorts, since some of them may be so small as to need removing. - ! the first call to terminate cohorts removes sparse number densities, - ! the second call removes for all other reasons (sparse culling must happen - ! before fusion) + ! sort out the cohorts, since some of them may be so small as to need removing. + ! the first call to terminate cohorts removes sparse number densities, + ! the second call removes for all other reasons (sparse culling must happen + ! before fusion) - call terminate_cohorts(currentSite, new_patch, 1,17, bc_in) - call fuse_cohorts(currentSite,new_patch, bc_in) - call terminate_cohorts(currentSite, new_patch, 2,17, bc_in) - call sort_cohorts(new_patch) - endif + call terminate_cohorts(currentSite, new_patch, 1,17, bc_in) + call fuse_cohorts(currentSite,new_patch, bc_in) + call terminate_cohorts(currentSite, new_patch, 2,17, bc_in) + call sort_cohorts(new_patch) + endif - call check_patch_area(currentSite) - call set_patchno(currentSite) - end do landuse_type_loop + call check_patch_area(currentSite) + call set_patchno(currentSite) + end do landuse_type_loop + end do landusechange_type_loop end do disturbance_type_loop end do nocomp_pft_loop @@ -2090,7 +2131,7 @@ subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) ! assign anthropgenic disturbance category and label new_patch%anthro_disturbance_label = label - if (label .eq. secondarylands) then + if (label .gt. primarylands) then new_patch%age_since_anthro_disturbance = age else new_patch%age_since_anthro_disturbance = fates_unset_r8 diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 09297b5f4c..597236a431 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -123,10 +123,11 @@ module EDTypesMod ! BIOLOGY/BIOGEOCHEMISTRY integer , parameter, public :: num_vegtemp_mem = 10 ! Window of time over which we track temp for cold sensecence (days) - integer , parameter, public :: N_DIST_TYPES = 3 ! Disturbance Modes 1) tree-fall, 2) fire, 3) logging + integer , parameter, public :: N_DIST_TYPES = 4 ! Disturbance Modes 1) tree-fall, 2) fire, 3) logging, 4) land-use change integer , parameter, public :: dtype_ifall = 1 ! index for naturally occuring tree-fall generated event integer , parameter, public :: dtype_ifire = 2 ! index for fire generated disturbance event integer , parameter, public :: dtype_ilog = 3 ! index for logging generated disturbance event + integer , parameter, public :: dtype_ilandusechange = 4 ! index for land use change disturbance (not including logging) ! Phenology status flag definitions (cold type is cstat, dry type is dstat) From 58b78d5a77a440e6c65cd68578fdc991154301af Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Tue, 28 Mar 2023 11:47:34 -0400 Subject: [PATCH 006/250] added land clearing rulest --- biogeochem/FatesLandUseChangeMod.F90 | 81 ++++++++++++++++++++++++++++ 1 file changed, 81 insertions(+) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index e31c845064..7222b23d4d 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -22,6 +22,7 @@ module FatesLandUseChangeMod ! public :: get_landuse_transition_rates public :: init_luh2_fates_mapping + public :: get_landusechange_rules ! module data integer :: max_luh2_types_per_fates_lu_type = 5 @@ -117,4 +118,84 @@ subroutine init_luh2_fates_mapping end subroutine init_luh2_fates_mapping + + subroutine get_landusechange_rules(clearing_vector) + + ! the purpose of this is to define a ruleset for when to clear the vegetation in transitioning from one land use type to another + + integer, intent(out) :: clearing_vector(n_landuse_cats) + integer, parameter :: ruleset = 1 ! ruleset to apply from table 1 of Ma et al (2020) https://doi.org/10.5194/gmd-13-3203-2020 + + ! clearing vector applies to the receiver land use type of the newly-transferred patch area + ! values of clearing vector: 0 => do not clear; 1 => clear if preceding land is forested; 2 => clear always + ! in table 1 of Ma et al., 0 = 'O', 1 = 'F', 2 = 'X' + + clearing_vector(:) = 0 + + select case(ruleset) + + case(1) + + clearing_vector(crops) = 2 + clearing_vector(pasture) = 2 + clearing_vector(rangelands) = 1 + + case(2) + + clearing_vector(crops) = 2 + clearing_vector(pasture) = 1 + clearing_vector(rangelands) = 1 + + case(3) + + clearing_vector(crops) = 2 + clearing_vector(pasture) = 2 + clearing_vector(rangelands) = 2 + + case(4) + + clearing_vector(crops) = 2 + clearing_vector(pasture) = 2 + clearing_vector(rangelands) = 0 + + case(5) + + clearing_vector(crops) = 2 + clearing_vector(pasture) = 0 + clearing_vector(rangelands) = 2 + + case(6) + + clearing_vector(crops) = 2 + clearing_vector(pasture) = 0 + clearing_vector(rangelands) = 0 + + case(7) + + clearing_vector(crops) = 0 + clearing_vector(pasture) = 2 + clearing_vector(rangelands) = 2 + + case(8) + + clearing_vector(crops) = 0 + clearing_vector(pasture) = 2 + clearing_vector(rangelands) = 0 + + case(9) + + clearing_vector(crops) = 0 + clearing_vector(pasture) = 0 + clearing_vector(rangelands) = 2 + + case(default) + + write(fates_log(),*) 'unknown clearing ruleset?' + write(fates_log(),*) 'ruleset: ', ruleset + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end select + + end subroutine get_landusechange_rules + end module FatesLandUseChangeMod From 2361d93a6bf422cbcdf0f7104980a3a9b70b8d7c Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Tue, 28 Mar 2023 12:25:50 -0400 Subject: [PATCH 007/250] revised and included the clearing ruleset --- biogeochem/EDPatchDynamicsMod.F90 | 11 +++++ biogeochem/FatesLandUseChangeMod.F90 | 68 ++++++++++++++-------------- 2 files changed, 46 insertions(+), 33 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index b94729c587..f686df6df9 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -457,6 +457,8 @@ subroutine spawn_patches( currentSite, bc_in) integer :: i_disturbance_type, i_dist2 ! iterators for looping over disturbance types real(r8) :: disturbance_rate ! rate of disturbance being resolved [fraction of patch area / day] real(r8) :: oldarea ! old patch area prior to disturbance + logical :: clearing_matrix(n_landuse_cats,n_landuse_cats) ! do we clear vegetation when transferring from one LU type to another? + !--------------------------------------------------------------------- storesmallcohort => null() ! storage of the smallest cohort for insertion routine @@ -475,6 +477,9 @@ subroutine spawn_patches( currentSite, bc_in) currentSite%disturbance_rates_primary_to_secondary(1:N_DIST_TYPES) = 0._r8 currentSite%disturbance_rates_secondary_to_secondary(1:N_DIST_TYPES) = 0._r8 + ! get rules for vegetation clearing during land use change + call get_landusechange_rules(clearing_matrix) + ! in the nocomp cases, since every patch has a PFT identity, it can only receive patch area from patches ! that have the same identity. In order to allow this, we have this very high level loop over nocomp PFTs ! and only do the disturbance for any patches that have that nocomp PFT identity. @@ -1071,6 +1076,12 @@ subroutine spawn_patches( currentSite, bc_in) currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) ! now apply survivorship based on the type of landuse transition + if ( clearing_matrix(i_donorpatch_landuse_type,receiver_patch_lu_label) ) then + ! kill everything + + + + end if else write(fates_log(),*) 'unknown disturbance mode?' diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index 7222b23d4d..b30cfb600f 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -119,74 +119,76 @@ subroutine init_luh2_fates_mapping end subroutine init_luh2_fates_mapping - subroutine get_landusechange_rules(clearing_vector) + subroutine get_landusechange_rules(clearing_matrix) ! the purpose of this is to define a ruleset for when to clear the vegetation in transitioning from one land use type to another - integer, intent(out) :: clearing_vector(n_landuse_cats) + logical, intent(out) :: clearing_matrix(n_landuse_cats,n_landuse_cats) integer, parameter :: ruleset = 1 ! ruleset to apply from table 1 of Ma et al (2020) https://doi.org/10.5194/gmd-13-3203-2020 - ! clearing vector applies to the receiver land use type of the newly-transferred patch area - ! values of clearing vector: 0 => do not clear; 1 => clear if preceding land is forested; 2 => clear always - ! in table 1 of Ma et al., 0 = 'O', 1 = 'F', 2 = 'X' + ! clearing matrix applies from the donor to the receiver land use type of the newly-transferred patch area + ! values of clearing matrix: false => do not clear; true => clear - clearing_vector(:) = 0 + clearing_matrix(:,:) = .false. select case(ruleset) case(1) - clearing_vector(crops) = 2 - clearing_vector(pasture) = 2 - clearing_vector(rangelands) = 1 + clearing_matrix(:,crops) = .true. + clearing_matrix(:,pasture) = .true. + clearing_matrix(pasture,rangelands) = .true. + clearing_matrix(crops,rangelands) = .true. case(2) - clearing_vector(crops) = 2 - clearing_vector(pasture) = 1 - clearing_vector(rangelands) = 1 + clearing_matrix(:,crops) = .true. + clearing_matrix(rangelands,pasture) = .true. + clearing_matrix(crops,pasture) = .true. + clearing_matrix(pasture,rangelands) = .true. + clearing_matrix(crops,rangelands) = .true. case(3) - clearing_vector(crops) = 2 - clearing_vector(pasture) = 2 - clearing_vector(rangelands) = 2 + clearing_matrix(:,crops) = .true. + clearing_matrix(:,pasture) = .true. + clearing_matrix(:,rangelands) = .true. case(4) - clearing_vector(crops) = 2 - clearing_vector(pasture) = 2 - clearing_vector(rangelands) = 0 + clearing_matrix(:,crops) = .true. + clearing_matrix(:,pasture) = .true. + clearing_matrix(:,rangelands) = .false. case(5) - clearing_vector(crops) = 2 - clearing_vector(pasture) = 0 - clearing_vector(rangelands) = 2 + clearing_matrix(:,crops) = .true. + clearing_matrix(:,pasture) = .false. + clearing_matrix(:,rangelands) = .true. case(6) - clearing_vector(crops) = 2 - clearing_vector(pasture) = 0 - clearing_vector(rangelands) = 0 + clearing_matrix(:,crops) = .true. + clearing_matrix(:,pasture) = .false. + clearing_matrix(:,rangelands) = .false. case(7) - clearing_vector(crops) = 0 - clearing_vector(pasture) = 2 - clearing_vector(rangelands) = 2 + clearing_matrix(:,crops) = .false. + clearing_matrix(:,pasture) = .true. + clearing_matrix(:,rangelands) = .true. case(8) - clearing_vector(crops) = 0 - clearing_vector(pasture) = 2 - clearing_vector(rangelands) = 0 + clearing_matrix(:,crops) = .false. + clearing_matrix(:,pasture) = .true. + clearing_matrix(:,rangelands) = .false. case(9) - clearing_vector(crops) = 0 - clearing_vector(pasture) = 0 - clearing_vector(rangelands) = 2 + clearing_matrix(:,crops) = .false. + clearing_matrix(:,pasture) = .false. + clearing_matrix(:,rangelands) = .true. case(default) From ebf3516fb2f59161c9212fd281ecc853c4185933 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 31 Mar 2023 09:30:46 -0700 Subject: [PATCH 008/250] more updates to disturbance code --- biogeochem/EDPatchDynamicsMod.F90 | 53 +++++++++++++++++-------------- 1 file changed, 30 insertions(+), 23 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index f686df6df9..4745f64901 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -599,7 +599,7 @@ subroutine spawn_patches( currentSite, bc_in) patch_site_areadis = currentPatch%area * disturbance_rate - if ( patch_site_areadis > nearzero ) then + areadis_gt_zero_if: if ( patch_site_areadis > nearzero ) then if(.not.associated(new_patch))then write(fates_log(),*) 'Patch spawning has attempted to point to' @@ -632,15 +632,21 @@ subroutine spawn_patches( currentSite, bc_in) ! Transfer in litter fluxes from plants in various contexts of death and destruction ! CDK what do we do here for land use transitions? - if(i_disturbance_type .eq. dtype_ilog) then + + select case(disturbance_type) + case (dtype_ilog) call logging_litter_fluxes(currentSite, currentPatch, & new_patch, patch_site_areadis,bc_in) - elseif(i_disturbance_type .eq. dtype_ifire) then + case (dtype_ifire) call fire_litter_fluxes(currentSite, currentPatch, & new_patch, patch_site_areadis,bc_in) - else + case (dtype_ifall) call mortality_litter_fluxes(currentSite, currentPatch, & new_patch, patch_site_areadis,bc_in) + case (dtype_ilandusechange) + call landusechange_litter_fluxes(currentSite, currentPatch, & + new_patch, patch_site_areadis,bc_in, & + clearing_matrix(i_donorpatch_landuse_type,receiver_patch_lu_label)) endif @@ -694,10 +700,11 @@ subroutine spawn_patches( currentSite, bc_in) store_c = currentCohort%prt%GetState(store_organ, carbon12_element) total_c = sapw_c + struct_c + leaf_c + fnrt_c + store_c - ! treefall mortality is the current disturbance - if(i_disturbance_type .eq. dtype_ifall) then - - if(currentCohort%canopy_layer == 1)then + disttype_case: select case(disturbance_type) + ! treefall mortality is the current disturbance + case (dtype_ifall) + + in_canopy_if: if(currentCohort%canopy_layer == 1)then ! In the donor patch we are left with fewer trees because the area has decreased ! the plant density for large trees does not actually decrease in the donor patch @@ -724,7 +731,7 @@ subroutine spawn_patches( currentSite, bc_in) else ! small trees - if( prt_params%woody(currentCohort%pft) == itrue)then + woody_if: if( prt_params%woody(currentCohort%pft) == itrue)then ! Survivorship of undestory woody plants. Two step process. @@ -813,11 +820,11 @@ subroutine spawn_patches( currentSite, bc_in) nc%lmort_collateral = currentCohort%lmort_collateral nc%lmort_infra = currentCohort%lmort_infra - endif - endif + endif woody_if + endif in_canopy_if ! Fire is the current disturbance - elseif (i_disturbance_type .eq. dtype_ifire ) then + case (dtype_ifire) ! Number of members in the new patch, before we impose fire survivorship nc%n = currentCohort%n * patch_site_areadis/currentPatch%area @@ -946,10 +953,10 @@ subroutine spawn_patches( currentSite, bc_in) ! Logging is the current disturbance - elseif (i_disturbance_type .eq. dtype_ilog ) then + case (dtype_ilog) ! If this cohort is in the upper canopy. It generated - if(currentCohort%canopy_layer == 1)then + in_canopy_if: if(currentCohort%canopy_layer == 1)then ! calculate the survivorship of disturbed trees because non-harvested nc%n = currentCohort%n * currentCohort%l_degrad @@ -984,7 +991,7 @@ subroutine spawn_patches( currentSite, bc_in) ! What to do with cohorts in the understory of a logging generated ! disturbance patch? - if(prt_params%woody(currentCohort%pft) == itrue)then + woody_if: if(prt_params%woody(currentCohort%pft) == itrue)then ! Survivorship of undestory woody plants. Two step process. @@ -1062,12 +1069,12 @@ subroutine spawn_patches( currentSite, bc_in) nc%lmort_collateral = currentCohort%lmort_collateral nc%lmort_infra = currentCohort%lmort_infra - endif ! is/is-not woody + endif woody_if ! is/is-not woody - endif ! Select canopy layer + endif in_canopy_if ! Select canopy layer - elseif (i_disturbance_type .eq. dtype_ilandusechange ) then + case (dtype_ilandusechange) ! Number of members in the new patch, before we impose LUC survivorship nc%n = currentCohort%n * patch_site_areadis/currentPatch%area @@ -1083,13 +1090,13 @@ subroutine spawn_patches( currentSite, bc_in) end if - else + case default write(fates_log(),*) 'unknown disturbance mode?' write(fates_log(),*) 'i_disturbance_type: ',i_disturbance_type call endrun(msg=errMsg(sourcefile, __LINE__)) - end if ! Select disturbance mode + end select disttype_case ! Select disturbance mode - if (nc%n > 0.0_r8) then + cohort_n_gt_zero: if (nc%n > 0.0_r8) then storebigcohort => new_patch%tallest storesmallcohort => new_patch%shortest if(associated(new_patch%tallest))then @@ -1122,7 +1129,7 @@ subroutine spawn_patches( currentSite, bc_in) write(fates_log(),*) 'dealloc005: fail on deallocate(nc):'//trim(smsg) call endrun(msg=errMsg(sourcefile, __LINE__)) endif - endif + endif cohort_n_gt_zero currentCohort => currentCohort%taller enddo ! currentCohort @@ -1159,7 +1166,7 @@ subroutine spawn_patches( currentSite, bc_in) call terminate_cohorts(currentSite, currentPatch, 2,16,bc_in) call sort_cohorts(currentPatch) - end if ! if ( new_patch%area > nearzero ) then + end if areadis_gt_zero_if ! if ( new_patch%area > nearzero ) then end if patchlabel_matches_lutype_if From 6e04f6e68f14a043df667d6a62bd380e69a83fb8 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Thu, 6 Apr 2023 16:49:31 -0700 Subject: [PATCH 009/250] added new subroutine to deal with litter fluxes during LU transition with clearing --- biogeochem/EDPatchDynamicsMod.F90 | 268 +++++++++++++++++++++++++++++- 1 file changed, 265 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 08fbfad583..6f0e283de9 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -144,6 +144,7 @@ module EDPatchDynamicsMod real(r8), parameter :: existing_litt_localization = 1.0_r8 real(r8), parameter :: treefall_localization = 0.0_r8 real(r8), parameter :: burn_localization = 0.0_r8 + real(r8), parameter :: landusechange_localization = 1.0_r8 integer :: istat ! return status code character(len=255) :: smsg ! Message string for deallocation errors @@ -1086,9 +1087,7 @@ subroutine spawn_patches( currentSite, bc_in) ! now apply survivorship based on the type of landuse transition if ( clearing_matrix(i_donorpatch_landuse_type,receiver_patch_lu_label) ) then ! kill everything - - - + currentCohort%n = 0._r8 end if case default @@ -2075,6 +2074,269 @@ subroutine mortality_litter_fluxes(currentSite, currentPatch, & return end subroutine mortality_litter_fluxes + ! ============================================================================ + + subroutine landusechange_litter_fluxes(currentSite, currentPatch, & + newPatch, patch_site_areadis, bc_in, & + clearing_matrix_element) + ! + ! !DESCRIPTION: + ! CWD pool from land use change. + ! Carbon going from felled trees into CWD pool + ! Either kill everything or nothing on disturbed land, depending on clearing matrix + ! + ! !USES: + use SFParamsMod, only : SF_VAL_CWD_FRAC + ! + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite + type(ed_patch_type) , intent(inout), target :: currentPatch ! Donor Patch + type(ed_patch_type) , intent(inout), target :: newPatch ! New Patch + real(r8) , intent(in) :: patch_site_areadis ! Area being donated + type(bc_in_type) , intent(in) :: bc_in + logical , intent(in) :: clearing_matrix_element ! whether or not to clear vegetation + + ! + ! !LOCAL VARIABLES: + + type(ed_cohort_type), pointer :: currentCohort + type(litter_type), pointer :: new_litt + type(litter_type), pointer :: curr_litt + type(site_massbal_type), pointer :: site_mass + type(site_fluxdiags_type), pointer :: flux_diags + + real(r8) :: donatable_mass ! non-burned litter mass provided by the donor [kg] + ! some may or may not be retained by the donor + real(r8) :: burned_mass ! the mass of litter that was supposed to be provided + ! by the donor, but was burned [kg] + real(r8) :: remainder_area ! current patch's remaining area after donation [m2] + real(r8) :: retain_frac ! the fraction of litter mass retained by the donor patch + real(r8) :: bcroot ! amount of below ground coarse root per cohort kg + real(r8) :: bstem ! amount of above ground stem biomass per cohort kg + real(r8) :: leaf_burn_frac ! fraction of leaves burned + real(r8) :: leaf_m ! leaf mass [kg] + real(r8) :: fnrt_m ! fineroot mass [kg] + real(r8) :: sapw_m ! sapwood mass [kg] + real(r8) :: store_m ! storage mass [kg] + real(r8) :: struct_m ! structure mass [kg] + real(r8) :: repro_m ! Reproductive mass (seeds/flowers) [kg] + real(r8) :: num_dead_trees ! total number of dead trees passed in with the burn area + real(r8) :: num_live_trees ! total number of live trees passed in with the burn area + real(r8) :: donate_m2 ! area normalization for litter mass destined to new patch [m-2] + real(r8) :: retain_m2 ! area normalization for litter mass staying in donor patch [m-2] + real(r8) :: dcmpy_frac ! fraction of mass going to each decomposability partition + integer :: el ! element loop index + integer :: sl ! soil layer index + integer :: c ! loop index for coarse woody debris pools + integer :: pft ! loop index for plant functional types + integer :: dcmpy ! loop index for decomposability pool + integer :: element_id ! parteh compatible global element index + real(r8) :: trunk_product_site ! flux of carbon in trunk products exported off site [ kgC/site ] + ! (note we are accumulating over the patch, but scale is site level) + real(r8) :: woodproduct_mass ! mass that ends up in wood products [kg] + + ! the following two parameters are new to this logic. + real(r8), parameter :: burn_frac_landusetransition = 0.5_r8 ! what fraction of plant fines are burned during a land use transition? + real(r8), parameter :: woodproduct_frac_landusetransition = 0.5_r8 ! what fraction of trunk carbon is turned into wood products during a land use transition? + + !--------------------------------------------------------------------- + + clear_veg_if: if (clearing_matrix_element) then + + ! If plant hydraulics are turned on, account for water leaving the plant-soil + ! mass balance through the dead trees + if (hlm_use_planthydro == itrue) then + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + num_dead_trees = (currentCohort%n*patch_site_areadis/currentPatch%area) + call AccumulateMortalityWaterStorage(currentSite,currentCohort,num_dead_trees) + currentCohort => currentCohort%taller + end do + end if + + + ! If/when sending litter fluxes to the donor patch, we divide the total + ! mass sent to that patch, by the area it will have remaining + ! after it donates area. + ! i.e. subtract the area it is donating. + + remainder_area = currentPatch%area - patch_site_areadis + + ! Calculate the fraction of litter to be retained versus donated + ! vis-a-vis the new and donor patch (if the area remaining + ! in the original donor patch is small, don't bother + ! retaining anything.) + retain_frac = (1.0_r8-landusechange_localization) * & + remainder_area/(newPatch%area+remainder_area) + + if(remainder_area > rsnbl_math_prec) then + retain_m2 = retain_frac/remainder_area + donate_m2 = (1.0_r8-retain_frac)/newPatch%area + else + retain_m2 = 0._r8 + donate_m2 = 1.0_r8/newPatch%area + end if + + do el = 1,num_elements + + ! Zero some site level accumulator diagnsotics + trunk_product_site = 0.0_r8 + + element_id = element_list(el) + site_mass => currentSite%mass_balance(el) + flux_diags => currentSite%flux_diags(el) + curr_litt => currentPatch%litter(el) ! Litter pool of "current" patch + new_litt => newPatch%litter(el) ! Litter pool of "new" patch + + ! ----------------------------------------------------------------------------- + ! PART 1) Handle mass fluxes associated with plants that died in the land use transition + ! ------------------------------------------------------------------------------ + + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + + pft = currentCohort%pft + + ! Number of trees that died because of the land use transition, per m2 of ground. + ! Divide their litter into the four litter streams, and spread + ! across ground surface. + ! ----------------------------------------------------------------------- + + fnrt_m = currentCohort%prt%GetState(fnrt_organ, element_id) + store_m = currentCohort%prt%GetState(store_organ, element_id) + repro_m = currentCohort%prt%GetState(repro_organ, element_id) + + if (prt_params%woody(currentCohort%pft) == itrue) then + ! Assumption: for woody plants fluxes from deadwood and sapwood go together in CWD pool + leaf_m = currentCohort%prt%GetState(leaf_organ,element_id) + sapw_m = currentCohort%prt%GetState(sapw_organ,element_id) + struct_m = currentCohort%prt%GetState(struct_organ,element_id) + else + ! for non-woody plants all stem fluxes go into the same leaf litter pool + leaf_m = currentCohort%prt%GetState(leaf_organ,element_id) + & + currentCohort%prt%GetState(sapw_organ,element_id) + & + currentCohort%prt%GetState(struct_organ,element_id) + sapw_m = 0._r8 + struct_m = 0._r8 + end if + + + ! Absolute number of dead trees being transfered in with the donated area + num_dead_trees = (currentCohort%n * & + patch_site_areadis/currentPatch%area) + + ! Contribution of dead trees to leaf litter + donatable_mass = num_dead_trees * (leaf_m+repro_m) * & + (1.0_r8-burn_frac_landusetransition) + + ! Contribution of dead trees to leaf burn-flux + burned_mass = num_dead_trees * (leaf_m+repro_m) * burn_frac_landusetransition + + do dcmpy=1,ndcmpy + dcmpy_frac = GetDecompyFrac(pft,leaf_organ,dcmpy) + new_litt%leaf_fines(dcmpy) = new_litt%leaf_fines(dcmpy) + & + donatable_mass*donate_m2*dcmpy_frac + curr_litt%leaf_fines(dcmpy) = curr_litt%leaf_fines(dcmpy) + & + donatable_mass*retain_m2*dcmpy_frac + end do + + site_mass%burn_flux_to_atm = site_mass%burn_flux_to_atm + burned_mass + + call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil, & + bc_in%max_rooting_depth_index_col) + + ! Contribution of dead trees to root litter (no root burn flux to atm) + do dcmpy=1,ndcmpy + dcmpy_frac = GetDecompyFrac(pft,fnrt_organ,dcmpy) + do sl = 1,currentSite%nlevsoil + donatable_mass = num_dead_trees * (fnrt_m+store_m) * currentSite%rootfrac_scr(sl) + new_litt%root_fines(dcmpy,sl) = new_litt%root_fines(dcmpy,sl) + & + donatable_mass*donate_m2*dcmpy_frac + curr_litt%root_fines(dcmpy,sl) = curr_litt%root_fines(dcmpy,sl) + & + donatable_mass*retain_m2*dcmpy_frac + end do + end do + + ! Track as diagnostic fluxes + flux_diags%leaf_litter_input(pft) = & + flux_diags%leaf_litter_input(pft) + & + num_dead_trees * (leaf_m+repro_m) * (1.0_r8-burn_frac_landusetransition) + + flux_diags%root_litter_input(pft) = & + flux_diags%root_litter_input(pft) + & + (fnrt_m + store_m) * num_dead_trees + + ! coarse root biomass per tree + bcroot = (sapw_m + struct_m) * (1.0_r8 - prt_params%allom_agb_frac(pft) ) + + ! below ground coarse woody debris from felled trees + do c = 1,ncwd + do sl = 1,currentSite%nlevsoil + donatable_mass = num_dead_trees * SF_val_CWD_frac(c) * & + bcroot * currentSite%rootfrac_scr(sl) + + new_litt%bg_cwd(c,sl) = new_litt%bg_cwd(c,sl) + & + donatable_mass * donate_m2 + curr_litt%bg_cwd(c,sl) = curr_litt%bg_cwd(c,sl) + & + donatable_mass * retain_m2 + + ! track diagnostics + flux_diags%cwd_bg_input(c) = & + flux_diags%cwd_bg_input(c) + & + donatable_mass + enddo + end do + + ! stem biomass per tree + bstem = (sapw_m + struct_m) * prt_params%allom_agb_frac(pft) + + ! Above ground coarse woody debris from twigs and small branches + ! a portion of this pool may burn + ! a portion may also be carried offsite as wood product + do c = 1,ncwd + donatable_mass = num_dead_trees * SF_val_CWD_frac(c) * bstem + if (c == 1 .or. c == 2) then ! these pools can burn + donatable_mass = donatable_mass * (1.0_r8-burn_frac_landusetransition) + burned_mass = num_dead_trees * SF_val_CWD_frac(c) * bstem * & + burn_frac_landusetransition + + site_mass%burn_flux_to_atm = site_mass%burn_flux_to_atm + burned_mass + else ! all other pools can end up as timber products but not burn + donatable_mass = donatable_mass * (1.0_r8-woodproduct_frac_landusetransition) + + woodproduct_mass = num_dead_trees * SF_val_CWD_frac(c) * bstem * & + woodproduct_frac_landusetransition + + trunk_product_site = trunk_product_site + & + woodproduct_mass + + site_mass%wood_product = site_mass%wood_product + & + woodproduct_mass + endif + new_litt%ag_cwd(c) = new_litt%ag_cwd(c) + donatable_mass * donate_m2 + curr_litt%ag_cwd(c) = curr_litt%ag_cwd(c) + donatable_mass * retain_m2 + flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + donatable_mass + enddo + + currentCohort => currentCohort%taller + enddo + + ! Update the amount of carbon exported from the site through logging. + + if(element_id .eq. carbon12_element) then + currentSite%resources_management%trunk_product_site = & + currentSite%resources_management%trunk_product_site + & + trunk_product_site + end if + + + end do + + end if clear_veg_if + return + end subroutine landusechange_litter_fluxes + + ! ============================================================================ subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) From ee338711c7f328fe808333b4715db34303cdc0e8 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 7 Apr 2023 09:51:00 -0700 Subject: [PATCH 010/250] starting to add land use initialization logic --- biogeochem/FatesLandUseChangeMod.F90 | 37 ++++++++++++++++++++++++++++ main/EDInitMod.F90 | 23 +++++++++++++++++ 2 files changed, 60 insertions(+) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index b30cfb600f..de5b928ea3 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -23,6 +23,7 @@ module FatesLandUseChangeMod public :: get_landuse_transition_rates public :: init_luh2_fates_mapping public :: get_landusechange_rules + public :: get_luh_statedata ! module data integer :: max_luh2_types_per_fates_lu_type = 5 @@ -95,6 +96,8 @@ subroutine get_landuse_transition_rates(bc_in, landuse_transition_matrix) end subroutine get_landuse_transition_rates + !---------------------------------------------------------------------------------------------------- + subroutine init_luh2_fates_mapping ! initialize the character mapping of the LUH2 : FATES correspondance @@ -118,6 +121,7 @@ subroutine init_luh2_fates_mapping end subroutine init_luh2_fates_mapping + !---------------------------------------------------------------------------------------------------- subroutine get_landusechange_rules(clearing_matrix) @@ -200,4 +204,37 @@ subroutine get_landusechange_rules(clearing_matrix) end subroutine get_landusechange_rules + !---------------------------------------------------------------------------------------------------- + + subroutine get_luh_statedata(bc_in, state_vector) + + type(bc_in_type) , intent(in) :: bc_in + real(r8), intent(out) :: state_vector(n_landuse_cats) ! [m2/m2] + real(r8) :: urban_fraction + integer :: i_luh2_states + integer :: ii + + ! zero state vector + state_vector(:) = 0._r8 + + ! identify urban fraction so that it can be removed. + urban_fraction = 0._r8 + do i_luh2_states = 1, hlm_num_luh2_states + if (bc_in%hlm_luh_state_names(i_luh2_states) .eq. 'urban') then + urban_fraction = bc_in%hlm_luh_states(i_luh2_states) + end do + + ! loop over all states and add up the ones that correspond to a given fates land use type + do i_luh2_states = 1, hlm_num_luh2_states + state_name = bc_in%hlm_luh_state_names(i_luh2_states) + do ii = 1, max_luh2_types_per_fates_lu_type + if (state_name .eq. luh2_fates_luype_map(i_luh2_states, ii)) then + state_vector(i_luh2_states) = state_vector(i_luh2_states) + & + bc_in%hlm_luh_states(i_luh2_states) / (1._r8 - urban_fraction) + end if + end do + end do + + end subroutine get_luh_statedata + end module FatesLandUseChangeMod diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 45b3ac7551..74e2dc5cd5 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -80,6 +80,7 @@ module EDInitMod use PRTGenericMod, only : SetState use FatesSizeAgeTypeIndicesMod,only : get_age_class_index use DamageMainMod, only : undamaged_class + use FatesInterfaceTypesMod , only : hlm_num_luh2_transitions ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg @@ -523,6 +524,10 @@ subroutine init_patches( nsites, sites, bc_in) real(r8) :: newparea real(r8) :: tota !check on area integer :: is_first_patch + integer :: n_luh_states + integer :: luh_state_counter + real(r8) :: state_vector(n_landuse_cats) ! [m2/m2] + type(ed_site_type), pointer :: sitep type(ed_patch_type), pointer :: newppft(:) @@ -582,7 +587,25 @@ subroutine init_patches( nsites, sites, bc_in) num_new_patches = 1 end if !nocomp + ! read in luh state data to determine initial land use types + if (use_luh) then + call get_luh_statedata(bc_in(s), state_vector) + n_luh_states = 0 + do i_lu = 1, hlm_num_luh2_transitions + if ( state_vector(i_lu) .gt. nearzero ) then + n_luh_states = n_luh_states +1 + end do + + if (n_luh_states .eq. 0) then + write(fates_log(),*) 'error. n_luh_states .eq. 0.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + num_new_patches = num_new_patches * n_luh_states + endif + is_first_patch = itrue + luh_state_counter = 0 do n = start_patch, num_new_patches ! set the PFT index for patches if in nocomp mode. From 9b32d879a1bb9f6a65a5717527bbfaade79e9cd5 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 7 Apr 2023 09:54:14 -0700 Subject: [PATCH 011/250] logic fix --- biogeochem/EDPatchDynamicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 6f0e283de9..10ddb3544a 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1087,7 +1087,7 @@ subroutine spawn_patches( currentSite, bc_in) ! now apply survivorship based on the type of landuse transition if ( clearing_matrix(i_donorpatch_landuse_type,receiver_patch_lu_label) ) then ! kill everything - currentCohort%n = 0._r8 + nc%n = 0._r8 end if case default From 83664fa7f3b54d2622f7a1b8f79d1deccd87c72e Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 7 Apr 2023 12:35:53 -0700 Subject: [PATCH 012/250] more initialization --- biogeochem/FatesLandUseChangeMod.F90 | 74 ++++++++++-------- main/EDInitMod.F90 | 113 +++++++++++++++------------ 2 files changed, 106 insertions(+), 81 deletions(-) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index de5b928ea3..cb5d58d8b5 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -55,45 +55,48 @@ subroutine get_landuse_transition_rates(bc_in, landuse_transition_matrix) ! zero the transition matrix landuse_transition_matrix(:,:) = 0._r8 - !!may need some logic here to ask whether or not ot perform land use cahnge on this timestep. current code occurs every day. - - ! identify urban fraction so that it can be removed. - urban_fraction = 0._r8 - do i_luh2_states = 1, hlm_num_luh2_states - if (bc_in%hlm_luh_state_names(i_luh2_states) .eq. 'urban') then - urban_fraction = bc_in%hlm_luh_states(i_luh2_states) - end do + use_luh_if: if ( hlm_use_luh ) then + + !!may need some logic here to ask whether or not ot perform land use cahnge on this timestep. current code occurs every day. + + ! identify urban fraction so that it can be removed. + urban_fraction = 0._r8 + do i_luh2_states = 1, hlm_num_luh2_states + if (bc_in%hlm_luh_state_names(i_luh2_states) .eq. 'urban') then + urban_fraction = bc_in%hlm_luh_states(i_luh2_states) + end if + end do - ! loop over FATES donor and receiver land use types - do i_donor = 1,n_landuse_cats - do i_receiver = 1,n_landuse_cats + ! loop over FATES donor and receiver land use types + donor_loop: do i_donor = 1,n_landuse_cats + receiver_loop: do i_receiver = 1,n_landuse_cats - ! ignore diagonals of transition matrix - if ( i_donor .ne. i_receiver ) then + ! ignore diagonals of transition matrix + not_diagonal: if ( i_donor .ne. i_receiver ) then - ! ignore special case of primary -> secondary, which is handled by harvest mechanism - if ( .not. ((i_donor .eq. primarylands) .and. (i_receiver .eq. secondarylands)) ) then + ! ignore special case of primary -> secondary, which is handled by harvest mechanism + not_primary_to_secondary: if ( .not. ((i_donor .eq. primarylands) .and. (i_receiver .eq. secondarylands)) ) then - do i_luh2_transitions = 1, hlm_num_luh2_transitions + transitions_loop: do i_luh2_transitions = 1, hlm_num_luh2_transitions - ! transition names are written in form xxxxx_to_yyyyy where x and y are donor and receiver state names - transition_name = bc_in%hlm_luh_transition_names(i_luh2_transitions) - donor_name = transition_name(1:5) - receiver_name = transition_name(10:14) + ! transition names are written in form xxxxx_to_yyyyy where x and y are donor and receiver state names + transition_name = bc_in%hlm_luh_transition_names(i_luh2_transitions) + donor_name = transition_name(1:5) + receiver_name = transition_name(10:14) - if (any(luh2_fates_luype_map(:,i_donor) == donor_name) .and. & - any(luh2_fates_luype_map(:,i_receiver) == receiver_name)) then + if (any(luh2_fates_luype_map(:,i_donor) == donor_name) .and. & + any(luh2_fates_luype_map(:,i_receiver) == receiver_name)) then - landuse_transition_matrix(i_donor,i_receiver) = & - landuse_transition_matrix(i_donor,i_receiver) + bc_in%hlm_luh_transitions(i_luh2_transitions) / (1._r8 - urban_fraction) - - end if - end do - end if - end if - end do - end do + landuse_transition_matrix(i_donor,i_receiver) = & + landuse_transition_matrix(i_donor,i_receiver) + bc_in%hlm_luh_transitions(i_luh2_transitions) / (1._r8 - urban_fraction) + end if + end do transitions_loop + end if not_primary_to_secondary + end if not_diagonal + end do receiver_loop + end do donor_loop + end if use_luh_if end subroutine get_landuse_transition_rates !---------------------------------------------------------------------------------------------------- @@ -222,6 +225,7 @@ subroutine get_luh_statedata(bc_in, state_vector) do i_luh2_states = 1, hlm_num_luh2_states if (bc_in%hlm_luh_state_names(i_luh2_states) .eq. 'urban') then urban_fraction = bc_in%hlm_luh_states(i_luh2_states) + end if end do ! loop over all states and add up the ones that correspond to a given fates land use type @@ -235,6 +239,14 @@ subroutine get_luh_statedata(bc_in, state_vector) end do end do + ! check to ensure total area == 1, and correct if not + if ( abs(sum(state_vector(:)) - 1._r8) .gt. nearzero ) then + write(fates_log(),*) 'warning: sum(state_vector) = ', sum(state_vector(:)) + do ii = 1, n_landuse_cats + state_vector(ii) = state_vector(ii) / sum(state_vector(:)) + end do + end if + end subroutine get_luh_statedata end module FatesLandUseChangeMod diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 74e2dc5cd5..93503ca9a6 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -46,6 +46,7 @@ module EDInitMod use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog use FatesInterfaceTypesMod , only : hlm_use_tree_damage use FatesInterfaceTypesMod , only : hlm_use_sp + use FatesInterfaceTypesMod , only : hlm_use_luh use FatesInterfaceTypesMod , only : numpft use FatesInterfaceTypesMod , only : nleafage use FatesInterfaceTypesMod , only : nlevsclass @@ -566,7 +567,7 @@ subroutine init_patches( nsites, sites, bc_in) else - do s = 1, nsites + sites_loop: do s = 1, nsites sites(s)%sp_tlai(:) = 0._r8 sites(s)%sp_tsai(:) = 0._r8 sites(s)%sp_htop(:) = 0._r8 @@ -588,12 +589,13 @@ subroutine init_patches( nsites, sites, bc_in) end if !nocomp ! read in luh state data to determine initial land use types - if (use_luh) then + if (hlm_use_luh) then call get_luh_statedata(bc_in(s), state_vector) n_luh_states = 0 do i_lu = 1, hlm_num_luh2_transitions if ( state_vector(i_lu) .gt. nearzero ) then n_luh_states = n_luh_states +1 + end if end do if (n_luh_states .eq. 0) then @@ -601,12 +603,15 @@ subroutine init_patches( nsites, sites, bc_in) call endrun(msg=errMsg(sourcefile, __LINE__)) endif - num_new_patches = num_new_patches * n_luh_states + else + state_vector(:) = 0._r8 + state_vector(primarylands) = 1._r8 + n_luh_states = 1 endif is_first_patch = itrue luh_state_counter = 0 - do n = start_patch, num_new_patches + new_patch_nocomp_loop: do n = start_patch, num_new_patches ! set the PFT index for patches if in nocomp mode. if(hlm_use_nocomp.eq.itrue)then @@ -631,51 +636,59 @@ subroutine init_patches( nsites, sites, bc_in) newparea = area end if !nocomp mode - if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode - allocate(newp) - - call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) - - if(is_first_patch.eq.itrue)then !is this the first patch? - ! set poointers for first patch (or only patch, if nocomp is false) - newp%patchno = 1 - newp%younger => null() - newp%older => null() - sites(s)%youngest_patch => newp - sites(s)%oldest_patch => newp - is_first_patch = ifalse - else - ! Set pointers for N>1 patches. Note this only happens when nocomp mode s on. - ! The new patch is the 'youngest' one, arbitrarily. - newp%patchno = nocomp_pft - newp%older => sites(s)%youngest_patch - newp%younger => null() - sites(s)%youngest_patch%younger => newp - sites(s)%youngest_patch => newp - end if - - ! Initialize the litter pools to zero, these - ! pools will be populated by looping over the existing patches - ! and transfering in mass - do el=1,num_elements - call newp%litter(el)%InitConditions(init_leaf_fines=0._r8, & - init_root_fines=0._r8, & - init_ag_cwd=0._r8, & - init_bg_cwd=0._r8, & - init_seed=0._r8, & - init_seed_germ=0._r8) - end do - - sitep => sites(s) - if(hlm_use_sp.eq.itrue)then - if(nocomp_pft.ne.0)then !don't initialize cohorts for SP bare ground patch - call init_cohorts(sitep, newp, bc_in(s)) - end if - else ! normal non SP case always call init cohorts - call init_cohorts(sitep, newp, bc_in(s)) - end if - end if - end do !no new patches + luh_state_loop: do i_lu_state = 1, n_landuse_cats + lu_state_present_if: if ( state_vector(i_lu_state) .gt. nearzero ) then + + newparea_withlanduse = newparea / state_vector(i_lu_state) + ! for now, spread nocomp PFTs evenly across land use types + + new_patch_area_gt_zero: if(newparea_withlanduse.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode + allocate(newp) + + call create_patch(sites(s), newp, age, newparea_withlanduse, i_lu_state, nocomp_pft) + + if(is_first_patch.eq.itrue)then !is this the first patch? + ! set poointers for first patch (or only patch, if nocomp is false) + newp%patchno = 1 + newp%younger => null() + newp%older => null() + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp + is_first_patch = ifalse + else + ! Set pointers for N>1 patches. Note this only happens when nocomp mode s on. + ! The new patch is the 'youngest' one, arbitrarily. + newp%patchno = nocomp_pft + (i_lu_state-1) * numpft + newp%older => sites(s)%youngest_patch + newp%younger => null() + sites(s)%youngest_patch%younger => newp + sites(s)%youngest_patch => newp + end if + + ! Initialize the litter pools to zero, these + ! pools will be populated by looping over the existing patches + ! and transfering in mass + do el=1,num_elements + call newp%litter(el)%InitConditions(init_leaf_fines=0._r8, & + init_root_fines=0._r8, & + init_ag_cwd=0._r8, & + init_bg_cwd=0._r8, & + init_seed=0._r8, & + init_seed_germ=0._r8) + end do + + sitep => sites(s) + if(hlm_use_sp.eq.itrue)then + if(nocomp_pft.ne.0)then !don't initialize cohorts for SP bare ground patch + call init_cohorts(sitep, newp, bc_in(s)) + end if + else ! normal non SP case always call init cohorts + call init_cohorts(sitep, newp, bc_in(s)) + end if + end if new_patch_area_gt_zero + end if lu_state_present_if + end do luh_state_loop + end do new_patch_nocomp_loop !no new patches !check if the total area adds to the same as site area tota = 0.0_r8 @@ -711,7 +724,7 @@ subroutine init_patches( nsites, sites, bc_in) call set_patchno(sites(s)) - enddo !s + enddo sites_loop !s end if ! zero all the patch fire variables for the first timestep From abc531106e52d0f0242f969d859a7a9c388e8e61 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 7 Apr 2023 12:44:09 -0700 Subject: [PATCH 013/250] adding hlm_use_luh switch --- biogeochem/FatesLandUseChangeMod.F90 | 2 +- main/EDInitMod.F90 | 2 +- main/FatesInterfaceTypesMod.F90 | 2 ++ 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index cb5d58d8b5..0c1011650b 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -55,7 +55,7 @@ subroutine get_landuse_transition_rates(bc_in, landuse_transition_matrix) ! zero the transition matrix landuse_transition_matrix(:,:) = 0._r8 - use_luh_if: if ( hlm_use_luh ) then + use_luh_if: if ( hlm_use_luh .eq. itrue ) then !!may need some logic here to ask whether or not ot perform land use cahnge on this timestep. current code occurs every day. diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 93503ca9a6..bf46def72d 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -589,7 +589,7 @@ subroutine init_patches( nsites, sites, bc_in) end if !nocomp ! read in luh state data to determine initial land use types - if (hlm_use_luh) then + if (hlm_use_luh .eq. itrue) then call get_luh_statedata(bc_in(s), state_vector) n_luh_states = 0 do i_lu = 1, hlm_num_luh2_transitions diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 8598c617eb..583ca77c0e 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -120,6 +120,7 @@ module FatesInterfaceTypesMod ! harvest_rates in dynHarvestMod ! bc_in%hlm_harvest_rates and bc_in%hlm_harvest_catnames + integer, public :: hlm_use_luh ! flag to signal whether or not to use luh2 drivers integer, public :: hlm_num_luh2_states ! number of land use state types provided in LUH2 forcing dataset integer, public :: hlm_num_luh2_transitions ! number of land use transition types provided in LUH2 forcing dataset @@ -530,6 +531,7 @@ module FatesInterfaceTypesMod ! Land use ! --------------------------------------------------------------------------------- + logical real(r8),allocatable :: hlm_harvest_rates(:) ! annual harvest rate per cat from hlm for a site character(len=64), allocatable :: hlm_harvest_catnames(:) ! names of hlm_harvest d1 real(r8),allocatable :: hlm_luh_states(:) From dbf3538e8bcb4c4a083f0bc3051e1771d380f86c Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 7 Apr 2023 12:45:11 -0700 Subject: [PATCH 014/250] bugfix --- main/FatesInterfaceTypesMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 583ca77c0e..1a0152146d 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -531,7 +531,6 @@ module FatesInterfaceTypesMod ! Land use ! --------------------------------------------------------------------------------- - logical real(r8),allocatable :: hlm_harvest_rates(:) ! annual harvest rate per cat from hlm for a site character(len=64), allocatable :: hlm_harvest_catnames(:) ! names of hlm_harvest d1 real(r8),allocatable :: hlm_luh_states(:) From f7c207025b5f2b31edff41f68634e5bbbd42f845 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 7 Apr 2023 14:12:02 -0700 Subject: [PATCH 015/250] fix for relative vs absolute land use transition rates --- biogeochem/EDPatchDynamicsMod.F90 | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 10ddb3544a..e69d3f76c8 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -206,7 +206,7 @@ subroutine disturbance_rates( site_in, bc_in) real(r8) :: harvestable_forest_c(hlm_num_lu_harvest_cats) integer :: harvest_tag(hlm_num_lu_harvest_cats) real(r8) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) ! [m2/m2/year] - + real(r8) :: current_fates_landuse_state_vector(n_landuse_cats) ! [m2/m2] !---------------------------------------------------------------------------------------------- ! Calculate Mortality Rates (these were previously calculated during growth derivatives) ! And the same rates in understory plants have already been applied to %dndt @@ -266,6 +266,16 @@ subroutine disturbance_rates( site_in, bc_in) call get_landuse_transition_rates(bc_in, landuse_transition_matrix) + ! calculate total area in each landuse category + current_fates_landuse_state_vector(:) = 0._r8 + currentPatch => site_in%oldest_patch + do while (associated(currentPatch)) + current_fates_landuse_state_vector(currentPatch%labelanthro_disturbance_label) = & + current_fates_landuse_state_vector(currentPatch%labelanthro_disturbance_label) + & + currentPatch%area/AREA + currentPatch => currentPatch%younger + end do + ! --------------------------------------------------------------------------------------------- ! Calculate Disturbance Rates based on the mortality rates just calculated ! --------------------------------------------------------------------------------------------- @@ -296,9 +306,10 @@ subroutine disturbance_rates( site_in, bc_in) dist_rate_ldist_notharvested = 0.0_r8 - currentPatch%landuse_transition_rates(1:n_landuse_cats) = & - landuse_transition_matrix(currentPatch%anthro_disturbance_label,1:n_landuse_cats) - + currentPatch%landuse_transition_rates(1:n_landuse_cats) = min(1._r8, & + landuse_transition_matrix(currentPatch%anthro_disturbance_label,1:n_landuse_cats) / & + current_fates_landuse_state_vector(currentPatch%labelanthro_disturbance_label)) + currentCohort => currentPatch%shortest do while(associated(currentCohort)) From 31ad7a133f580e499fdd8682184bcf3c6706cf61 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 7 Apr 2023 14:25:23 -0700 Subject: [PATCH 016/250] name changes to patch%land_use_label and primaryforest to primarylands (and secondary) --- biogeochem/EDLoggingMortalityMod.F90 | 44 +++++++++---------- biogeochem/EDMortalityFunctionsMod.F90 | 2 +- biogeochem/EDPatchDynamicsMod.F90 | 58 +++++++++++++------------- main/EDInitMod.F90 | 2 +- main/EDMainMod.F90 | 6 +-- main/EDTypesMod.F90 | 4 +- main/FatesHistoryInterfaceMod.F90 | 36 ++++++++-------- main/FatesInventoryInitMod.F90 | 4 +- main/FatesRestartInterfaceMod.F90 | 8 ++-- 9 files changed, 82 insertions(+), 82 deletions(-) diff --git a/biogeochem/EDLoggingMortalityMod.F90 b/biogeochem/EDLoggingMortalityMod.F90 index a98dd055cf..db8064a35f 100644 --- a/biogeochem/EDLoggingMortalityMod.F90 +++ b/biogeochem/EDLoggingMortalityMod.F90 @@ -62,7 +62,7 @@ module EDLoggingMortalityMod use PRTGenericMod , only : sapw_organ, struct_organ, leaf_organ use PRTGenericMod , only : fnrt_organ, store_organ, repro_organ use FatesAllometryMod , only : set_root_fraction - use FatesConstantsMod , only : primaryforest, secondaryforest, secondary_age_threshold + use FatesConstantsMod , only : primarylands, secondarylands, secondary_age_threshold use FatesConstantsMod , only : fates_tiny use FatesConstantsMod , only : months_per_year, days_per_sec, years_per_day, g_per_kg use FatesConstantsMod , only : hlm_harvest_area_fraction @@ -198,7 +198,7 @@ subroutine LoggingMortality_frac( pft_i, dbh, canopy_layer, lmort_direct, & lmort_collateral,lmort_infra, l_degrad, & hlm_harvest_rates, hlm_harvest_catnames, & hlm_harvest_units, & - patch_anthro_disturbance_label, secondary_age, & + patch_land_use_label, secondary_age, & frac_site_primary, harvestable_forest_c, & harvest_tag) @@ -209,7 +209,7 @@ subroutine LoggingMortality_frac( pft_i, dbh, canopy_layer, lmort_direct, & real(r8), intent(in) :: hlm_harvest_rates(:) ! annual harvest rate per hlm category character(len=64), intent(in) :: hlm_harvest_catnames(:) ! names of hlm harvest categories integer, intent(in) :: hlm_harvest_units ! unit type of hlm harvest rates: [area vs. mass] - integer, intent(in) :: patch_anthro_disturbance_label ! patch level anthro_disturbance_label + integer, intent(in) :: patch_land_use_label ! patch level land_use_label real(r8), intent(in) :: secondary_age ! patch level age_since_anthro_disturbance real(r8), intent(in) :: harvestable_forest_c(:) ! total harvestable forest carbon ! of all hlm harvest categories @@ -264,7 +264,7 @@ subroutine LoggingMortality_frac( pft_i, dbh, canopy_layer, lmort_direct, & ! HARVEST_SH3 = harvest from secondary non-forest (assume this is young for biomass) ! Get the area-based harvest rates based on info passed to FATES from the boundary condition - call get_harvest_rate_area (patch_anthro_disturbance_label, hlm_harvest_catnames, & + call get_harvest_rate_area (patch_land_use_label, hlm_harvest_catnames, & hlm_harvest_rates, frac_site_primary, secondary_age, harvest_rate) ! For area-based harvest, harvest_tag shall always be 2 (not applicable). @@ -279,7 +279,7 @@ subroutine LoggingMortality_frac( pft_i, dbh, canopy_layer, lmort_direct, & ! 2=use carbon from hlm ! shall call another subroutine, which transfers biomass/carbon into fraction - call get_harvest_rate_carbon (patch_anthro_disturbance_label, hlm_harvest_catnames, & + call get_harvest_rate_carbon (patch_land_use_label, hlm_harvest_catnames, & hlm_harvest_rates, secondary_age, harvestable_forest_c, & harvest_rate, harvest_tag, cur_harvest_tag) @@ -347,7 +347,7 @@ end subroutine LoggingMortality_frac ! ============================================================================ - subroutine get_harvest_rate_area (patch_anthro_disturbance_label, hlm_harvest_catnames, hlm_harvest_rates, & + subroutine get_harvest_rate_area (patch_land_use_label, hlm_harvest_catnames, hlm_harvest_rates, & frac_site_primary, secondary_age, harvest_rate) @@ -360,7 +360,7 @@ subroutine get_harvest_rate_area (patch_anthro_disturbance_label, hlm_harvest_ca ! Arguments real(r8), intent(in) :: hlm_harvest_rates(:) ! annual harvest rate per hlm category character(len=64), intent(in) :: hlm_harvest_catnames(:) ! names of hlm harvest categories - integer, intent(in) :: patch_anthro_disturbance_label ! patch level anthro_disturbance_label + integer, intent(in) :: patch_land_use_label ! patch level land_use_label real(r8), intent(in) :: secondary_age ! patch level age_since_anthro_disturbance real(r8), intent(in) :: frac_site_primary real(r8), intent(out) :: harvest_rate @@ -373,17 +373,17 @@ subroutine get_harvest_rate_area (patch_anthro_disturbance_label, hlm_harvest_ca ! We do account forest only since non-forest harvest has geographical mismatch to LUH2 dataset harvest_rate = 0._r8 do h_index = 1,hlm_num_lu_harvest_cats - if (patch_anthro_disturbance_label .eq. primaryforest) then + if (patch_land_use_label .eq. primarylands) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_VH1" .or. & hlm_harvest_catnames(h_index) .eq. "HARVEST_VH2") then harvest_rate = harvest_rate + hlm_harvest_rates(h_index) endif - else if (patch_anthro_disturbance_label .eq. secondaryforest .and. & + else if (patch_land_use_label .eq. secondarylands .and. & secondary_age >= secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH1") then harvest_rate = harvest_rate + hlm_harvest_rates(h_index) endif - else if (patch_anthro_disturbance_label .eq. secondaryforest .and. & + else if (patch_land_use_label .eq. secondarylands .and. & secondary_age < secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH2" .or. & hlm_harvest_catnames(h_index) .eq. "HARVEST_SH3") then @@ -395,7 +395,7 @@ subroutine get_harvest_rate_area (patch_anthro_disturbance_label, hlm_harvest_ca ! Normalize by site-level primary or secondary forest fraction ! since harvest_rate is specified as a fraction of the gridcell ! also need to put a cap so as not to harvest more primary or secondary area than there is in a gridcell - if (patch_anthro_disturbance_label .eq. primaryforest) then + if (patch_land_use_label .eq. primarylands) then if (frac_site_primary .gt. fates_tiny) then harvest_rate = min((harvest_rate / frac_site_primary),frac_site_primary) else @@ -510,18 +510,18 @@ subroutine get_harvestable_carbon (csite, site_area, hlm_harvest_catnames, harve ! since we have not separated forest vs. non-forest ! all carbon belongs to the forest categories do h_index = 1,hlm_num_lu_harvest_cats - if (currentPatch%anthro_disturbance_label .eq. primaryforest) then + if (currentPatch%land_use_label .eq. primarylands) then ! Primary if(hlm_harvest_catnames(h_index) .eq. "HARVEST_VH1") then harvestable_forest_c(h_index) = harvestable_forest_c(h_index) + harvestable_patch_c end if - else if (currentPatch%anthro_disturbance_label .eq. secondaryforest .and. & + else if (currentPatch%land_use_label .eq. secondarylands .and. & currentPatch%age_since_anthro_disturbance >= secondary_age_threshold) then ! Secondary mature if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH1") then harvestable_forest_c(h_index) = harvestable_forest_c(h_index) + harvestable_patch_c end if - else if (currentPatch%anthro_disturbance_label .eq. secondaryforest .and. & + else if (currentPatch%land_use_label .eq. secondarylands .and. & currentPatch%age_since_anthro_disturbance < secondary_age_threshold) then ! Secondary young if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH2") then @@ -536,7 +536,7 @@ end subroutine get_harvestable_carbon ! ============================================================================ - subroutine get_harvest_rate_carbon (patch_anthro_disturbance_label, hlm_harvest_catnames, & + subroutine get_harvest_rate_carbon (patch_land_use_label, hlm_harvest_catnames, & hlm_harvest_rates, secondary_age, harvestable_forest_c, & harvest_rate, harvest_tag, cur_harvest_tag) @@ -549,7 +549,7 @@ subroutine get_harvest_rate_carbon (patch_anthro_disturbance_label, hlm_harvest_ ! Arguments real(r8), intent(in) :: hlm_harvest_rates(:) ! annual harvest rate per hlm category character(len=64), intent(in) :: hlm_harvest_catnames(:) ! names of hlm harvest categories - integer, intent(in) :: patch_anthro_disturbance_label ! patch level anthro_disturbance_label + integer, intent(in) :: patch_land_use_label ! patch level land_use_label real(r8), intent(in) :: secondary_age ! patch level age_since_anthro_disturbance real(r8), intent(in) :: harvestable_forest_c(:) ! site level forest c matching criteria available for harvest, kgC site-1 real(r8), intent(out) :: harvest_rate ! area fraction @@ -583,17 +583,17 @@ subroutine get_harvest_rate_carbon (patch_anthro_disturbance_label, hlm_harvest_ ! mature and secondary young). ! Get the harvest rate from HLM do h_index = 1,hlm_num_lu_harvest_cats - if (patch_anthro_disturbance_label .eq. primaryforest) then + if (patch_land_use_label .eq. primarylands) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_VH1" .or. & hlm_harvest_catnames(h_index) .eq. "HARVEST_VH2") then harvest_rate_c = harvest_rate_c + hlm_harvest_rates(h_index) endif - else if (patch_anthro_disturbance_label .eq. secondaryforest .and. & + else if (patch_land_use_label .eq. secondarylands .and. & secondary_age >= secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH1") then harvest_rate_c = harvest_rate_c + hlm_harvest_rates(h_index) endif - else if (patch_anthro_disturbance_label .eq. secondaryforest .and. & + else if (patch_land_use_label .eq. secondarylands .and. & secondary_age < secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH2" .or. & hlm_harvest_catnames(h_index) .eq. "HARVEST_SH3") then @@ -605,7 +605,7 @@ subroutine get_harvest_rate_carbon (patch_anthro_disturbance_label, hlm_harvest_ ! Determine harvest status (succesful or not) ! Here only three categories are used do h_index = 1,hlm_num_lu_harvest_cats - if (patch_anthro_disturbance_label .eq. primaryforest) then + if (patch_land_use_label .eq. primarylands) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_VH1" ) then if(harvestable_forest_c(h_index) >= harvest_rate_c) then harvest_rate_supply = harvest_rate_supply + harvestable_forest_c(h_index) @@ -614,7 +614,7 @@ subroutine get_harvest_rate_carbon (patch_anthro_disturbance_label, hlm_harvest_ harvest_tag(h_index) = 1 end if end if - else if (patch_anthro_disturbance_label .eq. secondaryforest .and. & + else if (patch_land_use_label .eq. secondarylands .and. & secondary_age >= secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH1" ) then if(harvestable_forest_c(h_index) >= harvest_rate_c) then @@ -624,7 +624,7 @@ subroutine get_harvest_rate_carbon (patch_anthro_disturbance_label, hlm_harvest_ harvest_tag(h_index) = 1 end if end if - else if (patch_anthro_disturbance_label .eq. secondaryforest .and. & + else if (patch_land_use_label .eq. secondarylands .and. & secondary_age < secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH2" ) then if(harvestable_forest_c(h_index) >= harvest_rate_c) then diff --git a/biogeochem/EDMortalityFunctionsMod.F90 b/biogeochem/EDMortalityFunctionsMod.F90 index db5122a8d9..0ba5ec9006 100644 --- a/biogeochem/EDMortalityFunctionsMod.F90 +++ b/biogeochem/EDMortalityFunctionsMod.F90 @@ -277,7 +277,7 @@ subroutine Mortality_Derivative( currentSite, currentCohort, bc_in, frac_site_pr bc_in%hlm_harvest_rates, & bc_in%hlm_harvest_catnames, & bc_in%hlm_harvest_units, & - currentCohort%patchptr%anthro_disturbance_label, & + currentCohort%patchptr%land_use_label, & currentCohort%patchptr%age_since_anthro_disturbance, & frac_site_primary, harvestable_forest_c, harvest_tag) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index e69d3f76c8..257d12a6de 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -245,7 +245,7 @@ subroutine disturbance_rates( site_in, bc_in) bc_in%hlm_harvest_rates, & bc_in%hlm_harvest_catnames, & bc_in%hlm_harvest_units, & - currentPatch%anthro_disturbance_label, & + currentPatch%land_use_label, & currentPatch%age_since_anthro_disturbance, & frac_site_primary, & harvestable_forest_c, & @@ -270,8 +270,8 @@ subroutine disturbance_rates( site_in, bc_in) current_fates_landuse_state_vector(:) = 0._r8 currentPatch => site_in%oldest_patch do while (associated(currentPatch)) - current_fates_landuse_state_vector(currentPatch%labelanthro_disturbance_label) = & - current_fates_landuse_state_vector(currentPatch%labelanthro_disturbance_label) + & + current_fates_landuse_state_vector(currentPatch%land_use_label) = & + current_fates_landuse_state_vector(currentPatch%land_use_label) + & currentPatch%area/AREA currentPatch => currentPatch%younger end do @@ -307,8 +307,8 @@ subroutine disturbance_rates( site_in, bc_in) dist_rate_ldist_notharvested = 0.0_r8 currentPatch%landuse_transition_rates(1:n_landuse_cats) = min(1._r8, & - landuse_transition_matrix(currentPatch%anthro_disturbance_label,1:n_landuse_cats) / & - current_fates_landuse_state_vector(currentPatch%labelanthro_disturbance_label)) + landuse_transition_matrix(currentPatch%land_use_label,1:n_landuse_cats) / & + current_fates_landuse_state_vector(currentPatch%land_use_label)) currentCohort => currentPatch%shortest do while(associated(currentCohort)) @@ -350,11 +350,11 @@ subroutine disturbance_rates( site_in, bc_in) ! The canopy is NOT closed. if(bc_in%hlm_harvest_units == hlm_harvest_carbon) then - call get_harvest_rate_carbon (currentPatch%anthro_disturbance_label, bc_in%hlm_harvest_catnames, & + call get_harvest_rate_carbon (currentPatch%land_use_label, bc_in%hlm_harvest_catnames, & bc_in%hlm_harvest_rates, currentPatch%age_since_anthro_disturbance, harvestable_forest_c, & harvest_rate, harvest_tag) else - call get_harvest_rate_area (currentPatch%anthro_disturbance_label, bc_in%hlm_harvest_catnames, & + call get_harvest_rate_area (currentPatch%land_use_label, bc_in%hlm_harvest_catnames, & bc_in%hlm_harvest_rates, frac_site_primary, currentPatch%age_since_anthro_disturbance, harvest_rate) end if @@ -528,7 +528,7 @@ subroutine spawn_patches( currentSite, bc_in) cp_nocomp_matches_1_if: if ( hlm_use_nocomp .eq. ifalse .or. & currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then - patchlabel_matches_lutype_if: if (currentPatch%anthro_disturbance_label .eq. i_donorpatch_landuse_type) then + patchlabel_matches_lutype_if: if (currentPatch%land_use_label .eq. i_donorpatch_landuse_type) then if ( i_disturbance_type .ne. dtype_ilandusechange) then disturbance_rate = currentPatch%disturbance_rates(i_disturbance_type) @@ -598,7 +598,7 @@ subroutine spawn_patches( currentSite, bc_in) cp_nocomp_matches_2_if: if ( hlm_use_nocomp .eq. ifalse .or. & currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then - patchlabel_matches_lutype_if: if (currentPatch%anthro_disturbance_label .eq. i_donorpatch_landuse_type) then + patchlabel_matches_lutype_if: if (currentPatch%land_use_label .eq. i_donorpatch_landuse_type) then ! This is the amount of patch area that is disturbed, and donated by the donor @@ -623,7 +623,7 @@ subroutine spawn_patches( currentSite, bc_in) ! the current disturbance from this patch is non-anthropogenic, ! we need to average in the time-since-anthropogenic-disturbance ! from the donor patch into that of the receiver patch - if ( currentPatch%anthro_disturbance_label .gt. primarylands .and. & + if ( currentPatch%land_use_label .gt. primarylands .and. & (i_disturbance_type .lt. dtype_ilog) ) then new_patch%age_since_anthro_disturbance = new_patch%age_since_anthro_disturbance + & @@ -1196,12 +1196,12 @@ subroutine spawn_patches( currentSite, bc_in) !!!CDK 3/27 need change this logic. put the new patch as younger than any patches with the same labels ! insert new youngest primary patch after all the secondary patches, if there are any. ! this requires first finding the current youngest primary to insert the new one ahead of - if (currentPatch%anthro_disturbance_label .eq. secondarylands ) then + if (currentPatch%land_use_label .eq. secondarylands ) then found_youngest_primary = .false. do while(associated(currentPatch) .and. .not. found_youngest_primary) currentPatch => currentPatch%older if (associated(currentPatch)) then - if (currentPatch%anthro_disturbance_label .eq. primarylands) then + if (currentPatch%land_use_label .eq. primarylands) then found_youngest_primary = .true. endif endif @@ -2424,7 +2424,7 @@ subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) new_patch%area = areap ! assign anthropgenic disturbance category and label - new_patch%anthro_disturbance_label = label + new_patch%land_use_label = label if (label .gt. primarylands) then new_patch%age_since_anthro_disturbance = age else @@ -2661,10 +2661,10 @@ subroutine fuse_patches( csite, bc_in ) currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - nopatches(currentPatch%anthro_disturbance_label) = & - nopatches(currentPatch%anthro_disturbance_label) + 1 + nopatches(currentPatch%land_use_label) = & + nopatches(currentPatch%land_use_label) + 1 - if (currentPatch%anthro_disturbance_label .eq. primarylands) then + if (currentPatch%land_use_label .eq. primarylands) then primary_land_fraction_beforefusion = primary_land_fraction_beforefusion + & currentPatch%area * AREA_INV endif @@ -2725,8 +2725,8 @@ subroutine fuse_patches( csite, bc_in ) ! only fuse patches whose anthropogenic disturbance category matches ! ! that of the outer loop that we are in ! !--------------------------------------------------------------------! - anthro_dist_labels_match_if: if ( tpp%anthro_disturbance_label .eq. i_disttype .and. & - currentPatch%anthro_disturbance_label .eq. i_disttype) then + anthro_dist_labels_match_if: if ( tpp%land_use_label .eq. i_disttype .and. & + currentPatch%land_use_label .eq. i_disttype) then nocomp_pft_labels_match_if: if (hlm_use_nocomp .eq. ifalse .or. & (tpp%nocomp_pft_label .eq. i_pftlabel .and. & @@ -2862,7 +2862,7 @@ subroutine fuse_patches( csite, bc_in ) nopatches(i_disttype) = 0 currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - if (currentPatch%anthro_disturbance_label .eq. i_disttype) then + if (currentPatch%land_use_label .eq. i_disttype) then nopatches(i_disttype) = nopatches(i_disttype) +1 endif currentPatch => currentPatch%older @@ -2898,7 +2898,7 @@ subroutine fuse_patches( csite, bc_in ) currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - if (currentPatch%anthro_disturbance_label .eq. primarylands) then + if (currentPatch%land_use_label .eq. primarylands) then primary_land_fraction_afterfusion = primary_land_fraction_afterfusion + & currentPatch%area * AREA_INV endif @@ -2956,8 +2956,8 @@ subroutine fuse_2_patches(csite, dp, rp) call rp%litter(el)%FuseLitter(rp%area,dp%area,dp%litter(el)) end do - if ( rp%anthro_disturbance_label .ne. dp%anthro_disturbance_label) then - write(fates_log(),*) 'trying to fuse patches with different anthro_disturbance_label values' + if ( rp%land_use_label .ne. dp%land_use_label) then + write(fates_log(),*) 'trying to fuse patches with different land_use_label values' call endrun(msg=errMsg(sourcefile, __LINE__)) endif @@ -3131,7 +3131,7 @@ subroutine terminate_patches(currentSite) do while(associated(patchpointer)) if ( .not.associated(currentPatch,patchpointer) .and. & patchpointer%nocomp_pft_label .eq. currentPatch%nocomp_pft_label .and. & - patchpointer%anthro_disturbance_label .eq. currentPatch%anthro_disturbance_label .and. & + patchpointer%land_use_label .eq. currentPatch%land_use_label .and. & .not. gotfused) then call fuse_2_patches(currentSite, patchpointer, currentPatch) @@ -3145,7 +3145,7 @@ subroutine terminate_patches(currentSite) if ( .not. gotfused ) then !! somehow didn't find a patch to fuse with. write(fates_log(),*) 'Warning. small nocomp patch wasnt able to find another patch to fuse with.', & - currentPatch%nocomp_pft_label, currentPatch%anthro_disturbance_label + currentPatch%nocomp_pft_label, currentPatch%land_use_label endif else nocomp_if @@ -3173,7 +3173,7 @@ subroutine terminate_patches(currentSite) olderPatch => currentPatch%older - distlabel_1_if: if (currentPatch%anthro_disturbance_label .eq. olderPatch%anthro_disturbance_label) then + distlabel_1_if: if (currentPatch%land_use_label .eq. olderPatch%land_use_label) then call fuse_2_patches(currentSite, olderPatch, currentPatch) @@ -3189,7 +3189,7 @@ subroutine terminate_patches(currentSite) ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its older sibling ! and then allow them to fuse together. - currentPatch%anthro_disturbance_label = olderPatch%anthro_disturbance_label + currentPatch%land_use_label = olderPatch%land_use_label call fuse_2_patches(currentSite, olderPatch, currentPatch) gotfused = .true. endif countcycles_if @@ -3204,7 +3204,7 @@ subroutine terminate_patches(currentSite) youngerPatch => currentPatch%younger - distlabel_2_if: if (currentPatch%anthro_disturbance_label .eq. youngerPatch% anthro_disturbance_label) then + distlabel_2_if: if (currentPatch%land_use_label .eq. youngerPatch% land_use_label) then call fuse_2_patches(currentSite, youngerPatch, currentPatch) @@ -3214,7 +3214,7 @@ subroutine terminate_patches(currentSite) if (count_cycles .gt. 0) then ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its younger sibling - currentPatch%anthro_disturbance_label = youngerPatch%anthro_disturbance_label + currentPatch%land_use_label = youngerPatch%land_use_label call fuse_2_patches(currentSite, youngerPatch, currentPatch) gotfused = .true. endif ! count cycles @@ -3481,7 +3481,7 @@ subroutine get_frac_site_primary(site_in, frac_site_primary) frac_site_primary = 0._r8 currentPatch => site_in%oldest_patch do while (associated(currentPatch)) - if (currentPatch%anthro_disturbance_label .eq. primarylands) then + if (currentPatch%land_use_label .eq. primarylands) then frac_site_primary = frac_site_primary + currentPatch%area * AREA_INV endif currentPatch => currentPatch%younger diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index bf46def72d..51f0f08953 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -8,7 +8,7 @@ module EDInitMod use FatesConstantsMod , only : ifalse use FatesConstantsMod , only : itrue use FatesConstantsMod , only : fates_unset_int - use FatesConstantsMod , only : primaryforest + use FatesConstantsMod , only : primarylands use FatesConstantsMod , only : nearzero use FatesGlobals , only : endrun => fates_endrun use EDTypesMod , only : nclmax diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 427a687f8c..471a774002 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -75,7 +75,7 @@ module EDMainMod use EDTypesMod , only : phen_dstat_moiston use EDTypesMod , only : phen_dstat_timeon use FatesConstantsMod , only : itrue,ifalse - use FatesConstantsMod , only : primaryforest, secondaryforest + use FatesConstantsMod , only : primarylands, secondarylands use FatesConstantsMod , only : nearzero use FatesConstantsMod , only : m2_per_ha use FatesConstantsMod , only : sec_per_day @@ -448,7 +448,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) endif ! add age increment to secondary forest patches as well - if (currentPatch%anthro_disturbance_label .eq. secondaryforest) then + if (currentPatch%land_use_label .ne. primarylands) then currentPatch%age_since_anthro_disturbance = & currentPatch%age_since_anthro_disturbance + hlm_freq_day endif @@ -972,7 +972,7 @@ subroutine TotalBalanceCheck (currentSite, call_index ) write(fates_log(),*) 'BG CWD (by layer): ', sum(litt%bg_cwd,dim=1) write(fates_log(),*) 'leaf litter:',sum(litt%leaf_fines) write(fates_log(),*) 'root litter (by layer): ',sum(litt%root_fines,dim=1) - write(fates_log(),*) 'anthro_disturbance_label: ',currentPatch%anthro_disturbance_label + write(fates_log(),*) 'land_use_label: ',currentPatch%land_use_label write(fates_log(),*) 'use_this_pft: ', currentSite%use_this_pft(:) if(print_cohorts)then write(fates_log(),*) '---- Biomass by cohort and organ -----' diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index f45cf0d630..b848f94d5d 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -433,7 +433,7 @@ module EDTypesMod real(r8) :: area ! patch area: m2 integer :: countcohorts ! Number of cohorts in patch integer :: ncl_p ! Number of occupied canopy layers - integer :: anthro_disturbance_label ! patch label for anthropogenic disturbance classification + integer :: land_use_label ! patch label for land use classification (primarylands, secondarylands, etc) real(r8) :: age_since_anthro_disturbance ! average age for secondary forest since last anthropogenic disturbance @@ -1102,7 +1102,7 @@ subroutine dump_patch(cpatch) write(fates_log(),*) 'pa%c_stomata = ',cpatch%c_stomata write(fates_log(),*) 'pa%c_lblayer = ',cpatch%c_lblayer write(fates_log(),*) 'pa%disturbance_rates = ',cpatch%disturbance_rates(:) - write(fates_log(),*) 'pa%anthro_disturbance_label = ',cpatch%anthro_disturbance_label + write(fates_log(),*) 'pa%land_use_label = ',cpatch%land_use_label write(fates_log(),*) '----------------------------------------' do el = 1,num_elements write(fates_log(),*) 'element id: ',element_list(el) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index cf66408133..0a860c0ab1 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -80,7 +80,7 @@ module FatesHistoryInterfaceMod use FatesConstantsMod , only : umol_per_mol,mol_per_umol use FatesConstantsMod , only : pa_per_mpa use FatesLitterMod , only : litter_type - use FatesConstantsMod , only : secondaryforest + use FatesConstantsMod , only : secondarylands use PRTGenericMod , only : leaf_organ, fnrt_organ, sapw_organ use PRTGenericMod , only : struct_organ, store_organ, repro_organ @@ -596,7 +596,7 @@ module FatesHistoryInterfaceMod integer :: ih_c_stomata_si_age integer :: ih_c_lblayer_si_age integer :: ih_agesince_anthrodist_si_age - integer :: ih_secondaryforest_area_si_age + integer :: ih_secondarylands_area_si_age integer :: ih_area_burnt_si_age ! integer :: ih_fire_rate_of_spread_front_si_age integer :: ih_fire_intensity_si_age @@ -2446,7 +2446,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_biomass_secondary_forest_si => this%hvars(ih_biomass_secondary_forest_si)%r81d, & hio_woodproduct_si => this%hvars(ih_woodproduct_si)%r81d, & hio_agesince_anthrodist_si_age => this%hvars(ih_agesince_anthrodist_si_age)%r82d, & - hio_secondaryforest_area_si_age => this%hvars(ih_secondaryforest_area_si_age)%r82d, & + hio_secondarylands_area_si_age => this%hvars(ih_secondarylands_area_si_age)%r82d, & hio_area_burnt_si_age => this%hvars(ih_area_burnt_si_age)%r82d, & ! hio_fire_rate_of_spread_front_si_age => this%hvars(ih_fire_rate_of_spread_front_si_age)%r82d, & hio_fire_intensity_si_age => this%hvars(ih_fire_intensity_si_age)%r82d, & @@ -2641,7 +2641,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! Increment the number of patches per site hio_npatches_si(io_si) = hio_npatches_si(io_si) + 1._r8 - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondarylands ) then hio_npatches_sec_si(io_si) = hio_npatches_sec_si(io_si) + 1._r8 end if @@ -2680,7 +2680,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) endif ! some diagnostics on secondary forest area and its age distribution - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondarylands ) then hio_fraction_secondary_forest_si(io_si) = hio_fraction_secondary_forest_si(io_si) + & cpatch%area * AREA_INV @@ -2690,13 +2690,13 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_agesince_anthrodist_si_age(io_si,ageclass_since_anthrodist) & + cpatch%area * AREA_INV - hio_secondaryforest_area_si_age(io_si,cpatch%age_class) = & - hio_secondaryforest_area_si_age(io_si,cpatch%age_class) & + hio_secondarylands_area_si_age(io_si,cpatch%age_class) = & + hio_secondarylands_area_si_age(io_si,cpatch%age_class) & + cpatch%area * AREA_INV endif ! Secondary forest mean LAI - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondarylands ) then hio_lai_secondary_si(io_si) = hio_lai_secondary_si(io_si) & + sum(cpatch%tlai_profile(:,:,:)) * cpatch%total_canopy_area end if @@ -2766,7 +2766,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! Increment the number of cohorts per site hio_ncohorts_si(io_si) = hio_ncohorts_si(io_si) + 1._r8 - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondarylands ) then hio_ncohorts_sec_si(io_si) = hio_ncohorts_sec_si(io_si) + 1._r8 end if @@ -2882,7 +2882,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_nindivs_si_pft(io_si,ft) = hio_nindivs_si_pft(io_si,ft) + & ccohort%n * AREA_INV - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondarylands ) then hio_nindivs_sec_si_pft(io_si,ft) = hio_nindivs_sec_si_pft(io_si,ft) + & ccohort%n * AREA_INV end if @@ -2890,7 +2890,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & (ccohort%n * AREA_INV) * total_m - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondarylands ) then hio_biomass_sec_si_pft(io_si, ft) = hio_biomass_sec_si_pft(io_si, ft) + & (ccohort%n * AREA_INV) * total_m end if @@ -2900,7 +2900,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) + total_m * ccohort%n * AREA_INV ! track the total biomass on all secondary lands - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondarylands ) then hio_biomass_secondary_forest_si(io_si) = hio_biomass_secondary_forest_si(io_si) + & total_m * ccohort%n * AREA_INV endif @@ -3021,7 +3021,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_npp_si_pft(io_si, ft) = hio_npp_si_pft(io_si, ft) + & ccohort%npp_acc_hold * n_perm2 / days_per_year / sec_per_day - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondarylands ) then hio_gpp_sec_si_pft(io_si, ft) = hio_gpp_sec_si_pft(io_si, ft) + & ccohort%gpp_acc_hold * n_perm2 / days_per_year / sec_per_day hio_npp_sec_si_pft(io_si, ft) = hio_npp_sec_si_pft(io_si, ft) + & @@ -3171,7 +3171,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_m9_si_scls(io_si,scls) = hio_m9_si_scls(io_si,scls) + ccohort%smort*ccohort%n / m2_per_ha ! Examine secondary forest mortality and mortality rates - if(cpatch%anthro_disturbance_label .eq. secondaryforest) then + if(cpatch%land_use_label .eq. secondarylands) then if (hlm_use_cohort_age_tracking .eq.itrue) then hio_m10_sec_si_scls(io_si,scls) = hio_m10_sec_si_scls(io_si,scls) + & @@ -3483,7 +3483,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_m3_mortality_understory_si_scpf(io_si,scpf) = hio_m3_mortality_understory_si_scpf(io_si,scpf) + & ccohort%cmort * ccohort%n / m2_per_ha - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondarylands ) then hio_mortality_canopy_secondary_si_scls(io_si,scls) = hio_mortality_canopy_secondary_si_scls(io_si,scls) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & @@ -3803,7 +3803,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) sites(s)%fmort_rate_canopy(i_scls, i_pft) / m2_per_ha ! Shijie: Think about how to add later? - !if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + !if ( cpatch%land_use_label .eq. secondarylands ) then ! hio_mortality_canopy_secondary_si_scls(io_si,i_scls) = hio_mortality_canopy_secondary_si_scls(io_si,i_scls) + & ! sites(s)%term_nindivs_canopy(i_scls,i_pft) * days_per_year / m2_per_ha !end if @@ -4536,7 +4536,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ccohort%resp_m_unreduced * n_perm2 * per_dt_tstep ! Secondary forest only - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondarylands ) then hio_npp_secondary_si(io_si) = hio_npp_secondary_si(io_si) + & npp * n_perm2 * per_dt_tstep hio_gpp_secondary_si(io_si) = hio_gpp_secondary_si(io_si) + & @@ -5608,7 +5608,7 @@ subroutine define_history_vars(this, initialize_variables) long='secondary forest patch area age distribution since any kind of disturbance', & use_default='inactive', avgflag='A', vtype=site_age_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & - index=ih_secondaryforest_area_si_age) + index=ih_secondarylands_area_si_age) ! Fire Variables diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index a0304f2935..c01f64493e 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -61,7 +61,7 @@ module FatesInventoryInitMod use PRTGenericMod, only : nitrogen_element use PRTGenericMod, only : phosphorus_element use PRTGenericMod, only : SetState - use FatesConstantsMod, only : primaryforest + use FatesConstantsMod, only : primarylands use FatesRunningMeanMod, only : ema_lpa use PRTGenericMod, only : StorageNutrientTarget use FatesConstantsMod, only : fates_unset_int @@ -279,7 +279,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) age_init = 0.0_r8 area_init = 0.0_r8 - call create_patch(sites(s), newpatch, age_init, area_init, primaryforest, fates_unset_int ) + call create_patch(sites(s), newpatch, age_init, area_init, primarylands, fates_unset_int ) if( inv_format_list(invsite) == 1 ) then diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 4efe053627..90e2f3973a 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -8,7 +8,7 @@ module FatesRestartInterfaceMod use FatesConstantsMod, only : itrue use FatesConstantsMod, only : ifalse use FatesConstantsMod, only : fates_unset_r8, fates_unset_int - use FatesConstantsMod, only : primaryforest + use FatesConstantsMod, only : primarylands use FatesConstantsMod, only : nearzero use FatesGlobals, only : fates_log use FatesGlobals, only : endrun => fates_endrun @@ -2224,7 +2224,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! rio_livegrass_pa(io_idx_co_1st) = cpatch%livegrass rio_age_pa(io_idx_co_1st) = cpatch%age - rio_patchdistturbcat_pa(io_idx_co_1st) = cpatch%anthro_disturbance_label + rio_patchdistturbcat_pa(io_idx_co_1st) = cpatch%land_use_label rio_agesinceanthrodist_pa(io_idx_co_1st) = cpatch%age_since_anthro_disturbance rio_nocomp_pft_label_pa(io_idx_co_1st)= cpatch%nocomp_pft_label rio_area_pa(io_idx_co_1st) = cpatch%area @@ -2586,7 +2586,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in, bc_out) nocomp_pft = fates_unset_int ! the nocomp_pft label is set after patch creation has occured in 'get_restart_vectors' ! make new patch - call create_patch(sites(s), newp, fates_unset_r8, fates_unset_r8, primaryforest, nocomp_pft ) + call create_patch(sites(s), newp, fates_unset_r8, fates_unset_r8, primarylands, nocomp_pft ) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -3112,7 +3112,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! cpatch%livegrass = rio_livegrass_pa(io_idx_co_1st) cpatch%age = rio_age_pa(io_idx_co_1st) - cpatch%anthro_disturbance_label = rio_patchdistturbcat_pa(io_idx_co_1st) + cpatch%land_use_label = rio_patchdistturbcat_pa(io_idx_co_1st) cpatch%age_since_anthro_disturbance = rio_agesinceanthrodist_pa(io_idx_co_1st) cpatch%nocomp_pft_label = rio_nocomp_pft_label_pa(io_idx_co_1st) cpatch%area = rio_area_pa(io_idx_co_1st) From cafa72d5c8122f2dc235e6cba51f26a86e441551 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 11 Apr 2023 15:55:26 -0700 Subject: [PATCH 017/250] Add use_luh2 case to set_fates_ctrlparams --- main/FatesInterfaceMod.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 007dc11156..c882a07737 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1839,6 +1839,12 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering hlm_num_lu_harvest_cats= ',ival,' to FATES' end if + case('use_luh2') + hlm_use_luh = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_use_luh = ',ival,' to FATES' + end if + case('num_luh2_states') hlm_num_luh2_states = ival if (fates_global_verbose()) then From 40993458eaf65bff2b9bf437b69da9ecc4b7e0a1 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 12 Apr 2023 15:19:37 -0700 Subject: [PATCH 018/250] Move LUH2 allocations LUH2 transition and state information isn't dependent on the land use harvest capability. --- main/FatesInterfaceMod.F90 | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index c882a07737..e9c728edcf 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -541,10 +541,6 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats, if (hlm_use_lu_harvest .gt. 0) then allocate(bc_in%hlm_harvest_rates(num_lu_harvest_cats)) allocate(bc_in%hlm_harvest_catnames(num_lu_harvest_cats)) - allocate(bc_in%hlm_luh_states(num_luh2_states)) - allocate(bc_in%hlm_luh_state_names(num_luh2_states)) - allocate(bc_in%hlm_luh_transitions(num_luh2_transitions)) - allocate(bc_in%hlm_luh_transition_names(num_luh2_transitions)) else ! LoggingMortality_frac needs these passed to it regardless of harvest allocate(bc_in%hlm_harvest_rates(0)) allocate(bc_in%hlm_harvest_catnames(0)) @@ -552,6 +548,14 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats, allocate(bc_in%pft_areafrac(natpft_lb:natpft_ub)) + ! LUH2 state and transition data + if (hlm_use_luh .gt. 0) then + allocate(bc_in%hlm_luh_states(num_luh2_states)) + allocate(bc_in%hlm_luh_state_names(num_luh2_states)) + allocate(bc_in%hlm_luh_transitions(num_luh2_transitions)) + allocate(bc_in%hlm_luh_transition_names(num_luh2_transitions)) + end if + ! Variables for SP mode. if(hlm_use_sp.eq.itrue) then allocate(bc_in%hlm_sp_tlai(natpft_lb:natpft_ub)) From 8e1d2d68ce84ce63910c417fdde20af628374bed Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 17 Apr 2023 11:50:13 -0700 Subject: [PATCH 019/250] Align naming convention as set in FatesConstantsMod --- biogeochem/FatesLandUseChangeMod.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index 0c1011650b..1495408738 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -3,7 +3,7 @@ module FatesLandUseChangeMod ! Controls the transfer and initialization of patch structure to land use types use FatesGlobals , only : fates_log - use FatesConstantsMod , only : primarylands, secondarylands, pasture, rangelands, crops + use FatesConstantsMod , only : primaryland, secondaryland, pasture, rangelands, crops use FatesConstantsMod , only : n_landuse_cats use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 @@ -75,7 +75,7 @@ subroutine get_landuse_transition_rates(bc_in, landuse_transition_matrix) not_diagonal: if ( i_donor .ne. i_receiver ) then ! ignore special case of primary -> secondary, which is handled by harvest mechanism - not_primary_to_secondary: if ( .not. ((i_donor .eq. primarylands) .and. (i_receiver .eq. secondarylands)) ) then + not_primary_to_secondary: if ( .not. ((i_donor .eq. primaryland) .and. (i_receiver .eq. secondaryland)) ) then transitions_loop: do i_luh2_transitions = 1, hlm_num_luh2_transitions @@ -106,11 +106,11 @@ subroutine init_luh2_fates_mapping ! initialize the character mapping of the LUH2 : FATES correspondance luh2_fates_luype_map(:,:) = '' - luh2_fates_luype_map(1,primarylands) = 'primf' - luh2_fates_luype_map(2,primarylands) = 'primn' + luh2_fates_luype_map(1,primaryland) = 'primf' + luh2_fates_luype_map(2,primaryland) = 'primn' - luh2_fates_luype_map(1,secondarylands) = 'secdf' - luh2_fates_luype_map(2,secondarylands) = 'secdn' + luh2_fates_luype_map(1,secondaryland) = 'secdf' + luh2_fates_luype_map(2,secondaryland) = 'secdn' luh2_fates_luype_map(1,crops) = 'c3ann' luh2_fates_luype_map(2,crops) = 'c4ann' From 5fd30d28d8573b4af6d6b2b7346d2efe504f16f5 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 17 Apr 2023 14:27:42 -0700 Subject: [PATCH 020/250] Match constants references to constants module --- biogeochem/FatesLandUseChangeMod.F90 | 58 ++++++++++++++-------------- 1 file changed, 29 insertions(+), 29 deletions(-) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index 1495408738..44836fdf45 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -3,7 +3,7 @@ module FatesLandUseChangeMod ! Controls the transfer and initialization of patch structure to land use types use FatesGlobals , only : fates_log - use FatesConstantsMod , only : primaryland, secondaryland, pasture, rangelands, crops + use FatesConstantsMod , only : primaryland, secondaryland, pasture, rangeland, crop use FatesConstantsMod , only : n_landuse_cats use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 @@ -112,15 +112,15 @@ subroutine init_luh2_fates_mapping luh2_fates_luype_map(1,secondaryland) = 'secdf' luh2_fates_luype_map(2,secondaryland) = 'secdn' - luh2_fates_luype_map(1,crops) = 'c3ann' - luh2_fates_luype_map(2,crops) = 'c4ann' - luh2_fates_luype_map(3,crops) = 'c3per' - luh2_fates_luype_map(4,crops) = 'c4per' - luh2_fates_luype_map(5,crops) = 'c3nfx' + luh2_fates_luype_map(1,crop) = 'c3ann' + luh2_fates_luype_map(2,crop) = 'c4ann' + luh2_fates_luype_map(3,crop) = 'c3per' + luh2_fates_luype_map(4,crop) = 'c4per' + luh2_fates_luype_map(5,crop) = 'c3nfx' luh2_fates_luype_map(1,pasture) = 'pastr' - luh2_fates_luype_map(1,rangelands) = 'range' + luh2_fates_luype_map(1,rangeland) = 'range' end subroutine init_luh2_fates_mapping @@ -142,60 +142,60 @@ subroutine get_landusechange_rules(clearing_matrix) case(1) - clearing_matrix(:,crops) = .true. + clearing_matrix(:,crop) = .true. clearing_matrix(:,pasture) = .true. - clearing_matrix(pasture,rangelands) = .true. - clearing_matrix(crops,rangelands) = .true. + clearing_matrix(pasture,rangeland) = .true. + clearing_matrix(crop,rangeland) = .true. case(2) - clearing_matrix(:,crops) = .true. - clearing_matrix(rangelands,pasture) = .true. - clearing_matrix(crops,pasture) = .true. - clearing_matrix(pasture,rangelands) = .true. - clearing_matrix(crops,rangelands) = .true. + clearing_matrix(:,crop) = .true. + clearing_matrix(rangeland,pasture) = .true. + clearing_matrix(crop,pasture) = .true. + clearing_matrix(pasture,rangeland) = .true. + clearing_matrix(crop,rangeland) = .true. case(3) - clearing_matrix(:,crops) = .true. + clearing_matrix(:,crop) = .true. clearing_matrix(:,pasture) = .true. - clearing_matrix(:,rangelands) = .true. + clearing_matrix(:,rangeland) = .true. case(4) - clearing_matrix(:,crops) = .true. + clearing_matrix(:,crop) = .true. clearing_matrix(:,pasture) = .true. - clearing_matrix(:,rangelands) = .false. + clearing_matrix(:,rangeland) = .false. case(5) - clearing_matrix(:,crops) = .true. + clearing_matrix(:,crop) = .true. clearing_matrix(:,pasture) = .false. - clearing_matrix(:,rangelands) = .true. + clearing_matrix(:,rangeland) = .true. case(6) - clearing_matrix(:,crops) = .true. + clearing_matrix(:,crop) = .true. clearing_matrix(:,pasture) = .false. - clearing_matrix(:,rangelands) = .false. + clearing_matrix(:,rangeland) = .false. case(7) - clearing_matrix(:,crops) = .false. + clearing_matrix(:,crop) = .false. clearing_matrix(:,pasture) = .true. - clearing_matrix(:,rangelands) = .true. + clearing_matrix(:,rangeland) = .true. case(8) - clearing_matrix(:,crops) = .false. + clearing_matrix(:,crop) = .false. clearing_matrix(:,pasture) = .true. - clearing_matrix(:,rangelands) = .false. + clearing_matrix(:,rangeland) = .false. case(9) - clearing_matrix(:,crops) = .false. + clearing_matrix(:,crop) = .false. clearing_matrix(:,pasture) = .false. - clearing_matrix(:,rangelands) = .true. + clearing_matrix(:,rangeland) = .true. case(default) From b6a6cdb1c9b5ef95ccd567988758cb3d9beb5974 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 17 Apr 2023 14:33:02 -0700 Subject: [PATCH 021/250] Match constants to constants module --- biogeochem/FatesLandUseChangeMod.F90 | 36 ++++++++++++++-------------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index 44836fdf45..79f636d17e 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -3,7 +3,7 @@ module FatesLandUseChangeMod ! Controls the transfer and initialization of patch structure to land use types use FatesGlobals , only : fates_log - use FatesConstantsMod , only : primaryland, secondaryland, pasture, rangeland, crop + use FatesConstantsMod , only : primaryland, secondaryland, pasture, rangeland, cropland use FatesConstantsMod , only : n_landuse_cats use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 @@ -112,11 +112,11 @@ subroutine init_luh2_fates_mapping luh2_fates_luype_map(1,secondaryland) = 'secdf' luh2_fates_luype_map(2,secondaryland) = 'secdn' - luh2_fates_luype_map(1,crop) = 'c3ann' - luh2_fates_luype_map(2,crop) = 'c4ann' - luh2_fates_luype_map(3,crop) = 'c3per' - luh2_fates_luype_map(4,crop) = 'c4per' - luh2_fates_luype_map(5,crop) = 'c3nfx' + luh2_fates_luype_map(1,cropland) = 'c3ann' + luh2_fates_luype_map(2,cropland) = 'c4ann' + luh2_fates_luype_map(3,cropland) = 'c3per' + luh2_fates_luype_map(4,cropland) = 'c4per' + luh2_fates_luype_map(5,cropland) = 'c3nfx' luh2_fates_luype_map(1,pasture) = 'pastr' @@ -142,58 +142,58 @@ subroutine get_landusechange_rules(clearing_matrix) case(1) - clearing_matrix(:,crop) = .true. + clearing_matrix(:,cropland) = .true. clearing_matrix(:,pasture) = .true. clearing_matrix(pasture,rangeland) = .true. - clearing_matrix(crop,rangeland) = .true. + clearing_matrix(cropland,rangeland) = .true. case(2) - clearing_matrix(:,crop) = .true. + clearing_matrix(:,cropland) = .true. clearing_matrix(rangeland,pasture) = .true. - clearing_matrix(crop,pasture) = .true. + clearing_matrix(cropland,pasture) = .true. clearing_matrix(pasture,rangeland) = .true. - clearing_matrix(crop,rangeland) = .true. + clearing_matrix(cropland,rangeland) = .true. case(3) - clearing_matrix(:,crop) = .true. + clearing_matrix(:,cropland) = .true. clearing_matrix(:,pasture) = .true. clearing_matrix(:,rangeland) = .true. case(4) - clearing_matrix(:,crop) = .true. + clearing_matrix(:,cropland) = .true. clearing_matrix(:,pasture) = .true. clearing_matrix(:,rangeland) = .false. case(5) - clearing_matrix(:,crop) = .true. + clearing_matrix(:,cropland) = .true. clearing_matrix(:,pasture) = .false. clearing_matrix(:,rangeland) = .true. case(6) - clearing_matrix(:,crop) = .true. + clearing_matrix(:,cropland) = .true. clearing_matrix(:,pasture) = .false. clearing_matrix(:,rangeland) = .false. case(7) - clearing_matrix(:,crop) = .false. + clearing_matrix(:,cropland) = .false. clearing_matrix(:,pasture) = .true. clearing_matrix(:,rangeland) = .true. case(8) - clearing_matrix(:,crop) = .false. + clearing_matrix(:,cropland) = .false. clearing_matrix(:,pasture) = .true. clearing_matrix(:,rangeland) = .false. case(9) - clearing_matrix(:,crop) = .false. + clearing_matrix(:,cropland) = .false. clearing_matrix(:,pasture) = .false. clearing_matrix(:,rangeland) = .true. From 33bf881711dd841de29dae7e1290ac873d85c3a7 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 17 Apr 2023 16:57:04 -0700 Subject: [PATCH 022/250] Correct non-constant dimension Explicit-shape arrays need the parameter designation for named constants --- biogeochem/FatesLandUseChangeMod.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index 79f636d17e..4d4f6c08a2 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -26,8 +26,9 @@ module FatesLandUseChangeMod public :: get_luh_statedata ! module data - integer :: max_luh2_types_per_fates_lu_type = 5 - CHARACTER(len = 5), protected, DIMENSION(n_landuse_cats,max_luh2_types_per_fates_lu_type) :: luh2_fates_luype_map + integer, parameter :: max_luh2_types_per_fates_lu_type = 5 + CHARACTER(len=5), protected, DIMENSION(n_landuse_cats,max_luh2_types_per_fates_lu_type) :: luh2_fates_luype_map + ! 03/10/2023 Created By Charlie Koven ! ============================================================================ From efd8707671215956b9f4c28459d2617e830e5e98 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 18 Apr 2023 10:56:10 -0700 Subject: [PATCH 023/250] correct build issues --- biogeochem/FatesLandUseChangeMod.F90 | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index 4d4f6c08a2..b5c7776725 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -2,13 +2,16 @@ module FatesLandUseChangeMod ! Controls the transfer and initialization of patch structure to land use types - use FatesGlobals , only : fates_log - use FatesConstantsMod , only : primaryland, secondaryland, pasture, rangeland, cropland - use FatesConstantsMod , only : n_landuse_cats - use FatesGlobals , only : endrun => fates_endrun - use FatesConstantsMod , only : r8 => fates_r8 - use FatesConstantsMod , only : itrue, ifalse + use FatesGlobals , only : fates_log + use FatesConstantsMod , only : primaryland, secondaryland, pasture, rangeland, cropland + use FatesConstantsMod , only : n_landuse_cats + use FatesConstantsMod , only : nearzero + use FatesGlobals , only : endrun => fates_endrun + use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : itrue, ifalse use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : hlm_use_luh + use FatesInterfaceTypesMod , only : hlm_num_luh2_states use FatesInterfaceTypesMod , only : hlm_num_luh2_transitions use EDTypesMod , only : area_site => area @@ -19,12 +22,16 @@ module FatesLandUseChangeMod ! implicit none private + + character(len=*), parameter :: sourcefile = __FILE__ + ! public :: get_landuse_transition_rates public :: init_luh2_fates_mapping public :: get_landusechange_rules public :: get_luh_statedata + ! module data integer, parameter :: max_luh2_types_per_fates_lu_type = 5 CHARACTER(len=5), protected, DIMENSION(n_landuse_cats,max_luh2_types_per_fates_lu_type) :: luh2_fates_luype_map @@ -198,7 +205,7 @@ subroutine get_landusechange_rules(clearing_matrix) clearing_matrix(:,pasture) = .false. clearing_matrix(:,rangeland) = .true. - case(default) + case default write(fates_log(),*) 'unknown clearing ruleset?' write(fates_log(),*) 'ruleset: ', ruleset @@ -217,6 +224,7 @@ subroutine get_luh_statedata(bc_in, state_vector) real(r8) :: urban_fraction integer :: i_luh2_states integer :: ii + character(5) :: state_name ! zero state vector state_vector(:) = 0._r8 From 893615c44f43d3ea749c4607c9dd01ca9d1d00b8 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Tue, 18 Apr 2023 15:14:16 -0700 Subject: [PATCH 024/250] adding land-use and LUxLU hist machinery and one hist variable --- main/FatesHistoryInterfaceMod.F90 | 82 ++++++++++++++++++++++++++++++- main/FatesIODimensionsMod.F90 | 12 +++++ main/FatesIOVariableKindMod.F90 | 2 + main/FatesInterfaceMod.F90 | 8 +++ main/FatesInterfaceTypesMod.F90 | 1 + 5 files changed, 104 insertions(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 0a860c0ab1..15c8efa6a7 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -761,6 +761,7 @@ module FatesHistoryInterfaceMod integer, private :: levelcwd_index_, levelage_index_ integer, private :: levcacls_index_, levcapf_index_ integer, private :: levclscpf_index_ + integer, private :: levlanduse_index_, levlulu_index_ contains @@ -803,6 +804,8 @@ module FatesHistoryInterfaceMod procedure :: levelage_index procedure :: levagefuel_index procedure :: levclscpf_index + procedure :: levlanduse_index + procedure :: levlulu_index ! private work functions procedure, private :: define_history_vars @@ -831,6 +834,8 @@ module FatesHistoryInterfaceMod procedure, private :: set_levheight_index procedure, private :: set_levagefuel_index procedure, private :: set_levclscpf_index + procedure, private :: set_levlanduse_index + procedure, private :: set_levlulu_index procedure, private :: set_levelem_index procedure, private :: set_levelpft_index @@ -869,6 +874,7 @@ subroutine Init(this, num_threads, fates_bounds) use FatesIODimensionsMod, only : levelem, levelpft use FatesIODimensionsMod, only : levelcwd, levelage, levclscpf use FatesIODimensionsMod, only : levcdpf, levcdsc, levcdam + use FatesIODimensionsMod, only : levlanduse, levlulu implicit none @@ -1008,6 +1014,16 @@ subroutine Init(this, num_threads, fates_bounds) call this%dim_bounds(dim_count)%Init(levclscpf, num_threads, & fates_bounds%clscpf_begin, fates_bounds%clscpf_end) + dim_count = dim_count + 1 + call this%set_levlanduse_index(dim_count) + call this%dim_bounds(dim_count)%Init(levlanduse, num_threads, & + fates_bounds%landuse_begin, fates_bounds%landuse_end) + + dim_count = dim_count + 1 + call this%set_levlulu_index(dim_count) + call this%dim_bounds(dim_count)%Init(levlulu, num_threads, & + fates_bounds%lulu_begin, fates_bounds%lulu_end) + end subroutine Init ! ====================================================================== @@ -1128,6 +1144,14 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%clscpf_begin, thread_bounds%clscpf_end) + index = this%levlanduse_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%landuse_begin, thread_bounds%landuse_end) + + index = this%levlulu_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%lulu_begin, thread_bounds%lulu_end) + end subroutine SetThreadBoundsEach ! =================================================================================== @@ -1143,6 +1167,7 @@ subroutine assemble_history_output_types(this) use FatesIOVariableKindMod, only : site_elem_r8, site_elpft_r8 use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8, site_clscpf_r8 use FatesIOVariableKindMod, only : site_cdpf_r8, site_cdsc_r8, site_cdam_r8 + use FatesIOVariableKindMod, only : site_landuse_r8, site_lulu_r8 implicit none @@ -1226,7 +1251,13 @@ subroutine assemble_history_output_types(this) call this%set_dim_indices(site_clscpf_r8, 1, this%column_index()) call this%set_dim_indices(site_clscpf_r8, 2, this%levclscpf_index()) - + + call this%set_dim_indices(site_landuse_r8, 1, this%column_index()) + call this%set_dim_indices(site_landuse_r8, 2, this%levlanduse_index()) + + call this%set_dim_indices(site_lulu_r8, 1, this%column_index()) + call this%set_dim_indices(site_lulu_r8, 2, this%levlulu_index()) + end subroutine assemble_history_output_types ! =================================================================================== @@ -1640,6 +1671,36 @@ end function levclscpf_index ! ====================================================================================== + subroutine set_levlanduse_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levlanduse_index_ = index + end subroutine set_levlanduse_index + + integer function levlanduse_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levlanduse_index = this%levlanduse_index_ + end function levlanduse_index + + ! ====================================================================================== + + subroutine set_levlulu_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levlulu_index_ = index + end subroutine set_levlulu_index + + integer function levlulu_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levlulu_index = this%levlulu_index_ + end function levlulu_index + + ! ====================================================================================== + subroutine zero_site_hvars(this, currentSite, upfreq_in) ! This routine zero's a history diagnostic variable @@ -1786,6 +1847,7 @@ subroutine init_dim_kinds_maps(this) use FatesIOVariableKindMod, only : site_elem_r8, site_elpft_r8 use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8, site_clscpf_r8 use FatesIOVariableKindMod, only : site_cdpf_r8, site_cdsc_r8, site_cdam_r8 + use FatesIOVariableKindMod, only : site_landuse_r8, site_lulu_r8 implicit none @@ -1899,6 +1961,14 @@ subroutine init_dim_kinds_maps(this) index = index + 1 call this%dim_kinds(index)%Init(site_clscpf_r8, 2) + ! site x land use class + index = index + 1 + call this%dim_kinds(index)%Init(site_landuse_r8, 2) + + ! site x land use x land use class + index = index + 1 + call this%dim_kinds(index)%Init(site_lulu_r8, 2) + ! FIXME(bja, 2016-10) assert(index == fates_history_num_dim_kinds) end subroutine init_dim_kinds_maps @@ -2435,6 +2505,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_yesterdaycanopylevel_canopy_si_scls => this%hvars(ih_yesterdaycanopylevel_canopy_si_scls)%r82d, & hio_yesterdaycanopylevel_understory_si_scls => this%hvars(ih_yesterdaycanopylevel_understory_si_scls)%r82d, & hio_area_si_age => this%hvars(ih_area_si_age)%r82d, & + hio_area_si_landuse => this%hvars(ih_area_si_landuse)%r82d, & hio_lai_si_age => this%hvars(ih_lai_si_age)%r82d, & hio_lai_secondary_si => this%hvars(ih_lai_secondary_si)%r81d, & hio_canopy_area_si_age => this%hvars(ih_canopy_area_si_age)%r82d, & @@ -2651,6 +2722,9 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_area_si_age(io_si,cpatch%age_class) = hio_area_si_age(io_si,cpatch%age_class) & + cpatch%area * AREA_INV + hio_area_si_landuse(io_si, cpatch%land_use_label) = hio_area_si_landuse(io_si, cpatch%land_use_label)& + + cpatch%area * AREA_INV + ! 24hr veg temperature hio_tveg24(io_si) = hio_tveg24(io_si) + & (cpatch%tveg24%GetMean()- t_water_freeze_k_1atm)*cpatch%area*AREA_INV @@ -5575,6 +5649,12 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index=ih_biomass_si_age) + ! land use type resolved variables + call this%set_history_var(vname='FATES_PATCHAREA_LU', units='m2 m-2', & + long='patch area by land use type', use_default='active', & + avgflag='A', vtype=site_landuse_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index=ih_area_si_landuse) + ! Secondary forest area and age diagnostics call this%set_history_var(vname='FATES_SECONDARY_FOREST_FRACTION', & diff --git a/main/FatesIODimensionsMod.F90 b/main/FatesIODimensionsMod.F90 index 92488d00a9..9bd8342544 100644 --- a/main/FatesIODimensionsMod.F90 +++ b/main/FatesIODimensionsMod.F90 @@ -35,6 +35,8 @@ module FatesIODimensionsMod character(*), parameter, public :: levelpft = 'fates_levelpft' character(*), parameter, public :: levelcwd = 'fates_levelcwd' character(*), parameter, public :: levelage = 'fates_levelage' + character(*), parameter, public :: levlanduse = 'fates_levlanduse' + character(*), parameter, public :: levlulu = 'fates_lulu' ! column = This is a structure that records where FATES column boundaries ! on each thread point to in the host IO array, this structure @@ -115,6 +117,12 @@ module FatesIODimensionsMod ! levcdam = This is the structure that records the boundaries for the ! number of crown damage classes dimension + + ! levlanduse = this is the structure that records the boundaries for the + ! land use class dimension + + ! levlulu = this is the structure that records the boundaries for the + ! (land use class) x (land use class) dimension type, public :: fates_bounds_type integer :: cohort_begin @@ -171,6 +179,10 @@ module FatesIODimensionsMod integer :: agefuel_end integer :: clscpf_begin integer :: clscpf_end + integer :: landuse_begin + integer :: landuse_end + integer :: lulu_begin + integer :: lulu_end end type fates_bounds_type diff --git a/main/FatesIOVariableKindMod.F90 b/main/FatesIOVariableKindMod.F90 index 84dd8e692f..37c5c34448 100644 --- a/main/FatesIOVariableKindMod.F90 +++ b/main/FatesIOVariableKindMod.F90 @@ -41,6 +41,8 @@ module FatesIOVariableKindMod character(*), parameter, public :: site_agepft_r8 = 'SI_AGEPFT_R8' character(*), parameter, public :: site_agefuel_r8 = 'SI_AGEFUEL_R8' character(*), parameter, public :: site_clscpf_r8 = 'SI_CLSCPF_R8' + character(*), parameter, public :: site_landuse_r8 = 'SI_LANDUSE_R8' + character(*), parameter, public :: site_lulu_r8 = 'SI_LULU_R8' ! Element, and multiplexed element dimensions character(*), parameter, public :: site_elem_r8 = 'SI_ELEM_R8' diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index e9c728edcf..ed631fbb23 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1075,6 +1075,7 @@ subroutine fates_history_maps use EDParamsMod, only : ED_val_history_ageclass_bin_edges use EDParamsMod, only : ED_val_history_height_bin_edges use EDParamsMod, only : ED_val_history_coageclass_bin_edges + use FatesConstantsMod, only : n_landuse_cats ! ------------------------------------------------------------------------------------------ ! This subroutine allocates and populates the variables @@ -1096,11 +1097,13 @@ subroutine fates_history_maps integer :: iheight integer :: icoage integer :: iel + integer :: ilu allocate( fates_hdim_levsclass(1:nlevsclass )) allocate( fates_hdim_pfmap_levscpf(1:nlevsclass*numpft)) allocate( fates_hdim_scmap_levscpf(1:nlevsclass*numpft)) allocate( fates_hdim_levpft(1:numpft )) + allocate( fates_hdim_levlanduse(1:n_landuse_cats)) allocate( fates_hdim_levfuel(1:NFSC )) allocate( fates_hdim_levcwdsc(1:NCWD )) allocate( fates_hdim_levage(1:nlevage )) @@ -1169,6 +1172,11 @@ subroutine fates_history_maps fates_hdim_levcan(ican) = ican end do + ! make land use label array + do ilu = 1, n_landuse_cats + fates_hdim_levlanduse(ilu) = ilu + end do + ! Make an element array, each index is the PARTEH global identifier index do iel = 1, num_elements diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 1a0152146d..4c6ba46043 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -247,6 +247,7 @@ module FatesInterfaceTypesMod real(r8), public, allocatable :: fates_hdim_levage(:) ! patch age lower bound dimension real(r8), public, allocatable :: fates_hdim_levheight(:) ! height lower bound dimension integer , public, allocatable :: fates_hdim_levpft(:) ! plant pft dimension + integer , public, allocatable :: fates_hdim_levlanduse(:) ! land use label dimension integer , public, allocatable :: fates_hdim_levfuel(:) ! fire fuel size class (fsc) dimension integer , public, allocatable :: fates_hdim_levcwdsc(:) ! cwd class dimension integer , public, allocatable :: fates_hdim_levcan(:) ! canopy-layer dimension From f166ef373e6b7292ec74c096592871e4be4e46fb Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 18 Apr 2023 15:12:23 -0700 Subject: [PATCH 025/250] Matching landunit variable naming convention --- biogeochem/EDLoggingMortalityMod.F90 | 28 +++++++++--------- biogeochem/EDPatchDynamicsMod.F90 | 36 ++++++++++++------------ biogeochem/FatesLandUseChangeMod.F90 | 4 +-- main/EDInitMod.F90 | 4 +-- main/EDMainMod.F90 | 4 +-- main/EDTypesMod.F90 | 2 +- main/FatesHistoryInterfaceMod.F90 | 26 ++++++++--------- main/FatesInventoryInitMod.F90 | 4 +-- main/FatesRestartInterfaceMod.F90 | 4 +-- parameter_files/fates_params_default.cdl | 8 +++--- 10 files changed, 60 insertions(+), 60 deletions(-) diff --git a/biogeochem/EDLoggingMortalityMod.F90 b/biogeochem/EDLoggingMortalityMod.F90 index db8064a35f..2d0851b100 100644 --- a/biogeochem/EDLoggingMortalityMod.F90 +++ b/biogeochem/EDLoggingMortalityMod.F90 @@ -62,7 +62,7 @@ module EDLoggingMortalityMod use PRTGenericMod , only : sapw_organ, struct_organ, leaf_organ use PRTGenericMod , only : fnrt_organ, store_organ, repro_organ use FatesAllometryMod , only : set_root_fraction - use FatesConstantsMod , only : primarylands, secondarylands, secondary_age_threshold + use FatesConstantsMod , only : primaryland, secondaryland, secondary_age_threshold use FatesConstantsMod , only : fates_tiny use FatesConstantsMod , only : months_per_year, days_per_sec, years_per_day, g_per_kg use FatesConstantsMod , only : hlm_harvest_area_fraction @@ -373,17 +373,17 @@ subroutine get_harvest_rate_area (patch_land_use_label, hlm_harvest_catnames, hl ! We do account forest only since non-forest harvest has geographical mismatch to LUH2 dataset harvest_rate = 0._r8 do h_index = 1,hlm_num_lu_harvest_cats - if (patch_land_use_label .eq. primarylands) then + if (patch_land_use_label .eq. primaryland) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_VH1" .or. & hlm_harvest_catnames(h_index) .eq. "HARVEST_VH2") then harvest_rate = harvest_rate + hlm_harvest_rates(h_index) endif - else if (patch_land_use_label .eq. secondarylands .and. & + else if (patch_land_use_label .eq secondaryland .and. & secondary_age >= secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH1") then harvest_rate = harvest_rate + hlm_harvest_rates(h_index) endif - else if (patch_land_use_label .eq. secondarylands .and. & + else if (patch_land_use_label .eq secondaryland .and. & secondary_age < secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH2" .or. & hlm_harvest_catnames(h_index) .eq. "HARVEST_SH3") then @@ -395,7 +395,7 @@ subroutine get_harvest_rate_area (patch_land_use_label, hlm_harvest_catnames, hl ! Normalize by site-level primary or secondary forest fraction ! since harvest_rate is specified as a fraction of the gridcell ! also need to put a cap so as not to harvest more primary or secondary area than there is in a gridcell - if (patch_land_use_label .eq. primarylands) then + if (patch_land_use_label .eq. primaryland) then if (frac_site_primary .gt. fates_tiny) then harvest_rate = min((harvest_rate / frac_site_primary),frac_site_primary) else @@ -510,18 +510,18 @@ subroutine get_harvestable_carbon (csite, site_area, hlm_harvest_catnames, harve ! since we have not separated forest vs. non-forest ! all carbon belongs to the forest categories do h_index = 1,hlm_num_lu_harvest_cats - if (currentPatch%land_use_label .eq. primarylands) then + if (currentPatch%land_use_label .eq. primaryland) then ! Primary if(hlm_harvest_catnames(h_index) .eq. "HARVEST_VH1") then harvestable_forest_c(h_index) = harvestable_forest_c(h_index) + harvestable_patch_c end if - else if (currentPatch%land_use_label .eq. secondarylands .and. & + else if (currentPatch%land_use_label .eq secondaryland .and. & currentPatch%age_since_anthro_disturbance >= secondary_age_threshold) then ! Secondary mature if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH1") then harvestable_forest_c(h_index) = harvestable_forest_c(h_index) + harvestable_patch_c end if - else if (currentPatch%land_use_label .eq. secondarylands .and. & + else if (currentPatch%land_use_label .eq secondaryland .and. & currentPatch%age_since_anthro_disturbance < secondary_age_threshold) then ! Secondary young if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH2") then @@ -583,17 +583,17 @@ subroutine get_harvest_rate_carbon (patch_land_use_label, hlm_harvest_catnames, ! mature and secondary young). ! Get the harvest rate from HLM do h_index = 1,hlm_num_lu_harvest_cats - if (patch_land_use_label .eq. primarylands) then + if (patch_land_use_label .eq. primaryland) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_VH1" .or. & hlm_harvest_catnames(h_index) .eq. "HARVEST_VH2") then harvest_rate_c = harvest_rate_c + hlm_harvest_rates(h_index) endif - else if (patch_land_use_label .eq. secondarylands .and. & + else if (patch_land_use_label .eq secondaryland .and. & secondary_age >= secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH1") then harvest_rate_c = harvest_rate_c + hlm_harvest_rates(h_index) endif - else if (patch_land_use_label .eq. secondarylands .and. & + else if (patch_land_use_label .eq secondaryland .and. & secondary_age < secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH2" .or. & hlm_harvest_catnames(h_index) .eq. "HARVEST_SH3") then @@ -605,7 +605,7 @@ subroutine get_harvest_rate_carbon (patch_land_use_label, hlm_harvest_catnames, ! Determine harvest status (succesful or not) ! Here only three categories are used do h_index = 1,hlm_num_lu_harvest_cats - if (patch_land_use_label .eq. primarylands) then + if (patch_land_use_label .eq. primaryland) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_VH1" ) then if(harvestable_forest_c(h_index) >= harvest_rate_c) then harvest_rate_supply = harvest_rate_supply + harvestable_forest_c(h_index) @@ -614,7 +614,7 @@ subroutine get_harvest_rate_carbon (patch_land_use_label, hlm_harvest_catnames, harvest_tag(h_index) = 1 end if end if - else if (patch_land_use_label .eq. secondarylands .and. & + else if (patch_land_use_label .eq secondaryland .and. & secondary_age >= secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH1" ) then if(harvestable_forest_c(h_index) >= harvest_rate_c) then @@ -624,7 +624,7 @@ subroutine get_harvest_rate_carbon (patch_land_use_label, hlm_harvest_catnames, harvest_tag(h_index) = 1 end if end if - else if (patch_land_use_label .eq. secondarylands .and. & + else if (patch_land_use_label .eq secondaryland .and. & secondary_age < secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH2" ) then if(harvestable_forest_c(h_index) >= harvest_rate_c) then diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 257d12a6de..14c8435706 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -73,7 +73,7 @@ module EDPatchDynamicsMod use FatesConstantsMod , only : days_per_sec use FatesConstantsMod , only : years_per_day use FatesConstantsMod , only : nearzero - use FatesConstantsMod , only : primarylands, secondarylands, pasture_rangelands, crops + use FatesConstantsMod , only : primaryland, secondaryland, pasture, rangeland, crops use FatesConstantsMod , only : n_landuse_cats use FatesLandUseChangeMod, only : get_landuse_transition_rates use FatesConstantsMod , only : fates_unset_r8 @@ -518,7 +518,7 @@ subroutine spawn_patches( currentSite, bc_in) ! figure out what land use label the receiver patch for disturbance from patches with ! this disturbance label and disturbance of this type will have if ( i_disturbance_type .eq. dtype_ilog) then - receiver_patch_lu_label = secondarylands + receiver_patch_lu_label =secondaryland else receiver_patch_lu_label = i_donorpatch_landuse_type endif @@ -623,7 +623,7 @@ subroutine spawn_patches( currentSite, bc_in) ! the current disturbance from this patch is non-anthropogenic, ! we need to average in the time-since-anthropogenic-disturbance ! from the donor patch into that of the receiver patch - if ( currentPatch%land_use_label .gt. primarylands .and. & + if ( currentPatch%land_use_label .gt. primaryland .and. & (i_disturbance_type .lt. dtype_ilog) ) then new_patch%age_since_anthro_disturbance = new_patch%age_since_anthro_disturbance + & @@ -1196,12 +1196,12 @@ subroutine spawn_patches( currentSite, bc_in) !!!CDK 3/27 need change this logic. put the new patch as younger than any patches with the same labels ! insert new youngest primary patch after all the secondary patches, if there are any. ! this requires first finding the current youngest primary to insert the new one ahead of - if (currentPatch%land_use_label .eq. secondarylands ) then + if (currentPatch%land_use_label .eq secondaryland ) then found_youngest_primary = .false. do while(associated(currentPatch) .and. .not. found_youngest_primary) currentPatch => currentPatch%older if (associated(currentPatch)) then - if (currentPatch%land_use_label .eq. primarylands) then + if (currentPatch%land_use_label .eq. primaryland) then found_youngest_primary = .true. endif endif @@ -2425,7 +2425,7 @@ subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) ! assign anthropgenic disturbance category and label new_patch%land_use_label = label - if (label .gt. primarylands) then + if (label .gt. primaryland) then new_patch%age_since_anthro_disturbance = age else new_patch%age_since_anthro_disturbance = fates_unset_r8 @@ -2641,22 +2641,22 @@ subroutine fuse_patches( csite, bc_in ) ! if anthropogenic disturance is enabled. if (hlm_use_nocomp.eq.itrue) then !!cdk this logic for how many patcehs to allow in nocomp will need to be changed - maxpatches(primarylands) = max(maxpatch_primary, sum(csite%use_this_pft)) - maxpatches(crops) = maxpatch_crops + maxpatches(primaryland) = max(maxpatch_primary, sum(csite%use_this_pft)) + maxpatches(cropland) = maxpatch_cropland maxpatches(pasture) = maxpatch_pasture - maxpatches(rangelands) = maxpatch_rangeland - maxpatches(secondarylands) = maxpatch_total - maxpatches(primarylands) - maxpatches(crops) - maxpatches(pasture) - maxpatches(rangelands) - if (maxpatch_total .lt. maxpatches(primarylands)) then + maxpatches(rangeland) = maxpatch_rangeland + maxpatches(secondaryland) = maxpatch_total - maxpatches(primaryland) - maxpatches(cropland) - maxpatches(pasture) - maxpatches(rangeland) + if (maxpatch_total .lt. maxpatches(primaryland)) then write(fates_log(),*) 'too many PFTs and not enough patches for nocomp w/o fixed biogeog' write(fates_log(),*) 'maxpatch_total,numpft',maxpatch_total,numpft, sum(csite%use_this_pft) call endrun(msg=errMsg(sourcefile, __LINE__)) endif else - maxpatches(primarylands) = maxpatch_primary - maxpatches(secondarylands) = maxpatch_secondary - maxpatches(crops) = maxpatch_crops + maxpatches(primaryland) = maxpatch_primary + maxpatches(secondaryland) = maxpatch_secondary + maxpatches(cropland) = maxpatch_cropland maxpatches(pasture) = maxpatch_pasture - maxpatches(rangelands) = maxpatch_rangeland + maxpatches(rangeland) = maxpatch_rangeland endif currentPatch => currentSite%youngest_patch @@ -2664,7 +2664,7 @@ subroutine fuse_patches( csite, bc_in ) nopatches(currentPatch%land_use_label) = & nopatches(currentPatch%land_use_label) + 1 - if (currentPatch%land_use_label .eq. primarylands) then + if (currentPatch%land_use_label .eq. primaryland) then primary_land_fraction_beforefusion = primary_land_fraction_beforefusion + & currentPatch%area * AREA_INV endif @@ -2898,7 +2898,7 @@ subroutine fuse_patches( csite, bc_in ) currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - if (currentPatch%land_use_label .eq. primarylands) then + if (currentPatch%land_use_label .eq. primaryland) then primary_land_fraction_afterfusion = primary_land_fraction_afterfusion + & currentPatch%area * AREA_INV endif @@ -3481,7 +3481,7 @@ subroutine get_frac_site_primary(site_in, frac_site_primary) frac_site_primary = 0._r8 currentPatch => site_in%oldest_patch do while (associated(currentPatch)) - if (currentPatch%land_use_label .eq. primarylands) then + if (currentPatch%land_use_label .eq. primaryland) then frac_site_primary = frac_site_primary + currentPatch%area * AREA_INV endif currentPatch => currentPatch%younger diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index b5c7776725..40d663d51b 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -117,8 +117,8 @@ subroutine init_luh2_fates_mapping luh2_fates_luype_map(1,primaryland) = 'primf' luh2_fates_luype_map(2,primaryland) = 'primn' - luh2_fates_luype_map(1,secondaryland) = 'secdf' - luh2_fates_luype_map(2,secondaryland) = 'secdn' + luh2_fates_luype_map(1, secondaryland) = 'secdf' + luh2_fates_luype_map(2, secondaryland) = 'secdn' luh2_fates_luype_map(1,cropland) = 'c3ann' luh2_fates_luype_map(2,cropland) = 'c4ann' diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 51f0f08953..48a791b075 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -8,7 +8,7 @@ module EDInitMod use FatesConstantsMod , only : ifalse use FatesConstantsMod , only : itrue use FatesConstantsMod , only : fates_unset_int - use FatesConstantsMod , only : primarylands + use FatesConstantsMod , only : primaryland use FatesConstantsMod , only : nearzero use FatesGlobals , only : endrun => fates_endrun use EDTypesMod , only : nclmax @@ -605,7 +605,7 @@ subroutine init_patches( nsites, sites, bc_in) else state_vector(:) = 0._r8 - state_vector(primarylands) = 1._r8 + state_vector(primaryland) = 1._r8 n_luh_states = 1 endif diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 471a774002..38a95f005a 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -75,7 +75,7 @@ module EDMainMod use EDTypesMod , only : phen_dstat_moiston use EDTypesMod , only : phen_dstat_timeon use FatesConstantsMod , only : itrue,ifalse - use FatesConstantsMod , only : primarylands, secondarylands + use FatesConstantsMod , only : primaryland, secondaryland use FatesConstantsMod , only : nearzero use FatesConstantsMod , only : m2_per_ha use FatesConstantsMod , only : sec_per_day @@ -448,7 +448,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) endif ! add age increment to secondary forest patches as well - if (currentPatch%land_use_label .ne. primarylands) then + if (currentPatch%land_use_label .ne. primaryland) then currentPatch%age_since_anthro_disturbance = & currentPatch%age_since_anthro_disturbance + hlm_freq_day endif diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index b848f94d5d..fa423205ca 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -433,7 +433,7 @@ module EDTypesMod real(r8) :: area ! patch area: m2 integer :: countcohorts ! Number of cohorts in patch integer :: ncl_p ! Number of occupied canopy layers - integer :: land_use_label ! patch label for land use classification (primarylands, secondarylands, etc) + integer :: land_use_label ! patch label for land use classification (primaryland, secondaryland, etc) real(r8) :: age_since_anthro_disturbance ! average age for secondary forest since last anthropogenic disturbance diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 15c8efa6a7..78839e50a2 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -80,7 +80,7 @@ module FatesHistoryInterfaceMod use FatesConstantsMod , only : umol_per_mol,mol_per_umol use FatesConstantsMod , only : pa_per_mpa use FatesLitterMod , only : litter_type - use FatesConstantsMod , only : secondarylands + use FatesConstantsMod , only : secondaryland use PRTGenericMod , only : leaf_organ, fnrt_organ, sapw_organ use PRTGenericMod , only : struct_organ, store_organ, repro_organ @@ -2712,7 +2712,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! Increment the number of patches per site hio_npatches_si(io_si) = hio_npatches_si(io_si) + 1._r8 - if ( cpatch%land_use_label .eq. secondarylands ) then + if ( cpatch%land_use_label .eq secondaryland ) then hio_npatches_sec_si(io_si) = hio_npatches_sec_si(io_si) + 1._r8 end if @@ -2754,7 +2754,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) endif ! some diagnostics on secondary forest area and its age distribution - if ( cpatch%land_use_label .eq. secondarylands ) then + if ( cpatch%land_use_label .eq secondaryland ) then hio_fraction_secondary_forest_si(io_si) = hio_fraction_secondary_forest_si(io_si) + & cpatch%area * AREA_INV @@ -2770,7 +2770,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) endif ! Secondary forest mean LAI - if ( cpatch%land_use_label .eq. secondarylands ) then + if ( cpatch%land_use_label .eq secondaryland ) then hio_lai_secondary_si(io_si) = hio_lai_secondary_si(io_si) & + sum(cpatch%tlai_profile(:,:,:)) * cpatch%total_canopy_area end if @@ -2840,7 +2840,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! Increment the number of cohorts per site hio_ncohorts_si(io_si) = hio_ncohorts_si(io_si) + 1._r8 - if ( cpatch%land_use_label .eq. secondarylands ) then + if ( cpatch%land_use_label .eq secondaryland ) then hio_ncohorts_sec_si(io_si) = hio_ncohorts_sec_si(io_si) + 1._r8 end if @@ -2956,7 +2956,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_nindivs_si_pft(io_si,ft) = hio_nindivs_si_pft(io_si,ft) + & ccohort%n * AREA_INV - if ( cpatch%land_use_label .eq. secondarylands ) then + if ( cpatch%land_use_label .eq secondaryland ) then hio_nindivs_sec_si_pft(io_si,ft) = hio_nindivs_sec_si_pft(io_si,ft) + & ccohort%n * AREA_INV end if @@ -2964,7 +2964,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & (ccohort%n * AREA_INV) * total_m - if ( cpatch%land_use_label .eq. secondarylands ) then + if ( cpatch%land_use_label .eq secondaryland ) then hio_biomass_sec_si_pft(io_si, ft) = hio_biomass_sec_si_pft(io_si, ft) + & (ccohort%n * AREA_INV) * total_m end if @@ -2974,7 +2974,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) + total_m * ccohort%n * AREA_INV ! track the total biomass on all secondary lands - if ( cpatch%land_use_label .eq. secondarylands ) then + if ( cpatch%land_use_label .eq secondaryland ) then hio_biomass_secondary_forest_si(io_si) = hio_biomass_secondary_forest_si(io_si) + & total_m * ccohort%n * AREA_INV endif @@ -3095,7 +3095,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_npp_si_pft(io_si, ft) = hio_npp_si_pft(io_si, ft) + & ccohort%npp_acc_hold * n_perm2 / days_per_year / sec_per_day - if ( cpatch%land_use_label .eq. secondarylands ) then + if ( cpatch%land_use_label .eq secondaryland ) then hio_gpp_sec_si_pft(io_si, ft) = hio_gpp_sec_si_pft(io_si, ft) + & ccohort%gpp_acc_hold * n_perm2 / days_per_year / sec_per_day hio_npp_sec_si_pft(io_si, ft) = hio_npp_sec_si_pft(io_si, ft) + & @@ -3245,7 +3245,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_m9_si_scls(io_si,scls) = hio_m9_si_scls(io_si,scls) + ccohort%smort*ccohort%n / m2_per_ha ! Examine secondary forest mortality and mortality rates - if(cpatch%land_use_label .eq. secondarylands) then + if(cpatch%land_use_label .eq secondaryland) then if (hlm_use_cohort_age_tracking .eq.itrue) then hio_m10_sec_si_scls(io_si,scls) = hio_m10_sec_si_scls(io_si,scls) + & @@ -3557,7 +3557,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_m3_mortality_understory_si_scpf(io_si,scpf) = hio_m3_mortality_understory_si_scpf(io_si,scpf) + & ccohort%cmort * ccohort%n / m2_per_ha - if ( cpatch%land_use_label .eq. secondarylands ) then + if ( cpatch%land_use_label .eq secondaryland ) then hio_mortality_canopy_secondary_si_scls(io_si,scls) = hio_mortality_canopy_secondary_si_scls(io_si,scls) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & @@ -3877,7 +3877,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) sites(s)%fmort_rate_canopy(i_scls, i_pft) / m2_per_ha ! Shijie: Think about how to add later? - !if ( cpatch%land_use_label .eq. secondarylands ) then + !if ( cpatch%land_use_label .eq secondaryland ) then ! hio_mortality_canopy_secondary_si_scls(io_si,i_scls) = hio_mortality_canopy_secondary_si_scls(io_si,i_scls) + & ! sites(s)%term_nindivs_canopy(i_scls,i_pft) * days_per_year / m2_per_ha !end if @@ -4610,7 +4610,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ccohort%resp_m_unreduced * n_perm2 * per_dt_tstep ! Secondary forest only - if ( cpatch%land_use_label .eq. secondarylands ) then + if ( cpatch%land_use_label .eq secondaryland ) then hio_npp_secondary_si(io_si) = hio_npp_secondary_si(io_si) + & npp * n_perm2 * per_dt_tstep hio_gpp_secondary_si(io_si) = hio_gpp_secondary_si(io_si) + & diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index c01f64493e..b87de10fd4 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -61,7 +61,7 @@ module FatesInventoryInitMod use PRTGenericMod, only : nitrogen_element use PRTGenericMod, only : phosphorus_element use PRTGenericMod, only : SetState - use FatesConstantsMod, only : primarylands + use FatesConstantsMod, only : primaryland use FatesRunningMeanMod, only : ema_lpa use PRTGenericMod, only : StorageNutrientTarget use FatesConstantsMod, only : fates_unset_int @@ -279,7 +279,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) age_init = 0.0_r8 area_init = 0.0_r8 - call create_patch(sites(s), newpatch, age_init, area_init, primarylands, fates_unset_int ) + call create_patch(sites(s), newpatch, age_init, area_init, primaryland, fates_unset_int ) if( inv_format_list(invsite) == 1 ) then diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 90e2f3973a..5a744ed8b5 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -8,7 +8,7 @@ module FatesRestartInterfaceMod use FatesConstantsMod, only : itrue use FatesConstantsMod, only : ifalse use FatesConstantsMod, only : fates_unset_r8, fates_unset_int - use FatesConstantsMod, only : primarylands + use FatesConstantsMod, only : primaryland use FatesConstantsMod, only : nearzero use FatesGlobals, only : fates_log use FatesGlobals, only : endrun => fates_endrun @@ -2586,7 +2586,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in, bc_out) nocomp_pft = fates_unset_int ! the nocomp_pft label is set after patch creation has occured in 'get_restart_vectors' ! make new patch - call create_patch(sites(s), newp, fates_unset_r8, fates_unset_r8, primarylands, nocomp_pft ) + call create_patch(sites(s), newp, fates_unset_r8, fates_unset_r8, primaryland, nocomp_pft ) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 4257dd5cc4..7ab2438754 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -734,9 +734,9 @@ variables: double fates_maxcohort ; fates_maxcohort:units = "count" ; fates_maxcohort:long_name = "maximum number of cohorts per patch. Actual number of cohorts also depend on cohort fusion tolerances" ; - double fates_maxpatch_crops ; - fates_maxpatch_crops:units = "count" ; - fates_maxpatch_crops:long_name = "maximum number of crop patches per site" ; + double fates_maxpatch_cropland ; + fates_maxpatch_cropland:units = "count" ; + fates_maxpatch_cropland:long_name = "maximum number of crop patches per site" ; double fates_maxpatch_pasture ; fates_maxpatch_pasture:units = "count" ; fates_maxpatch_pasture:long_name = "maximum number of pasture patches per site" ; @@ -1524,7 +1524,7 @@ data: fates_maxcohort = 100 ; - fates_maxpatch_crops = 1 ; + fates_maxpatch_cropland = 1 ; fates_maxpatch_pasture = 1 ; From 6c894bc6b931061c4bfdd67819caa55339c3bb62 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 18 Apr 2023 15:17:09 -0700 Subject: [PATCH 026/250] Fix bad global search and replace I messed up the replacement string and dropped a character --- biogeochem/EDLoggingMortalityMod.F90 | 16 ++++++++-------- biogeochem/EDPatchDynamicsMod.F90 | 2 +- main/FatesHistoryInterfaceMod.F90 | 24 ++++++++++++------------ 3 files changed, 21 insertions(+), 21 deletions(-) diff --git a/biogeochem/EDLoggingMortalityMod.F90 b/biogeochem/EDLoggingMortalityMod.F90 index 2d0851b100..9c37b1c5e2 100644 --- a/biogeochem/EDLoggingMortalityMod.F90 +++ b/biogeochem/EDLoggingMortalityMod.F90 @@ -378,12 +378,12 @@ subroutine get_harvest_rate_area (patch_land_use_label, hlm_harvest_catnames, hl hlm_harvest_catnames(h_index) .eq. "HARVEST_VH2") then harvest_rate = harvest_rate + hlm_harvest_rates(h_index) endif - else if (patch_land_use_label .eq secondaryland .and. & + else if (patch_land_use_label .eq. secondaryland .and. & secondary_age >= secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH1") then harvest_rate = harvest_rate + hlm_harvest_rates(h_index) endif - else if (patch_land_use_label .eq secondaryland .and. & + else if (patch_land_use_label .eq. secondaryland .and. & secondary_age < secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH2" .or. & hlm_harvest_catnames(h_index) .eq. "HARVEST_SH3") then @@ -515,13 +515,13 @@ subroutine get_harvestable_carbon (csite, site_area, hlm_harvest_catnames, harve if(hlm_harvest_catnames(h_index) .eq. "HARVEST_VH1") then harvestable_forest_c(h_index) = harvestable_forest_c(h_index) + harvestable_patch_c end if - else if (currentPatch%land_use_label .eq secondaryland .and. & + else if (currentPatch%land_use_label .eq. secondaryland .and. & currentPatch%age_since_anthro_disturbance >= secondary_age_threshold) then ! Secondary mature if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH1") then harvestable_forest_c(h_index) = harvestable_forest_c(h_index) + harvestable_patch_c end if - else if (currentPatch%land_use_label .eq secondaryland .and. & + else if (currentPatch%land_use_label .eq. secondaryland .and. & currentPatch%age_since_anthro_disturbance < secondary_age_threshold) then ! Secondary young if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH2") then @@ -588,12 +588,12 @@ subroutine get_harvest_rate_carbon (patch_land_use_label, hlm_harvest_catnames, hlm_harvest_catnames(h_index) .eq. "HARVEST_VH2") then harvest_rate_c = harvest_rate_c + hlm_harvest_rates(h_index) endif - else if (patch_land_use_label .eq secondaryland .and. & + else if (patch_land_use_label .eq. secondaryland .and. & secondary_age >= secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH1") then harvest_rate_c = harvest_rate_c + hlm_harvest_rates(h_index) endif - else if (patch_land_use_label .eq secondaryland .and. & + else if (patch_land_use_label .eq. secondaryland .and. & secondary_age < secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH2" .or. & hlm_harvest_catnames(h_index) .eq. "HARVEST_SH3") then @@ -614,7 +614,7 @@ subroutine get_harvest_rate_carbon (patch_land_use_label, hlm_harvest_catnames, harvest_tag(h_index) = 1 end if end if - else if (patch_land_use_label .eq secondaryland .and. & + else if (patch_land_use_label .eq. secondaryland .and. & secondary_age >= secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH1" ) then if(harvestable_forest_c(h_index) >= harvest_rate_c) then @@ -624,7 +624,7 @@ subroutine get_harvest_rate_carbon (patch_land_use_label, hlm_harvest_catnames, harvest_tag(h_index) = 1 end if end if - else if (patch_land_use_label .eq secondaryland .and. & + else if (patch_land_use_label .eq. secondaryland .and. & secondary_age < secondary_age_threshold) then if(hlm_harvest_catnames(h_index) .eq. "HARVEST_SH2" ) then if(harvestable_forest_c(h_index) >= harvest_rate_c) then diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 14c8435706..99267bb8bf 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1196,7 +1196,7 @@ subroutine spawn_patches( currentSite, bc_in) !!!CDK 3/27 need change this logic. put the new patch as younger than any patches with the same labels ! insert new youngest primary patch after all the secondary patches, if there are any. ! this requires first finding the current youngest primary to insert the new one ahead of - if (currentPatch%land_use_label .eq secondaryland ) then + if (currentPatch%land_use_label .eq. secondaryland ) then found_youngest_primary = .false. do while(associated(currentPatch) .and. .not. found_youngest_primary) currentPatch => currentPatch%older diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 78839e50a2..030839efa5 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2712,7 +2712,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! Increment the number of patches per site hio_npatches_si(io_si) = hio_npatches_si(io_si) + 1._r8 - if ( cpatch%land_use_label .eq secondaryland ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_npatches_sec_si(io_si) = hio_npatches_sec_si(io_si) + 1._r8 end if @@ -2754,7 +2754,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) endif ! some diagnostics on secondary forest area and its age distribution - if ( cpatch%land_use_label .eq secondaryland ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_fraction_secondary_forest_si(io_si) = hio_fraction_secondary_forest_si(io_si) + & cpatch%area * AREA_INV @@ -2770,7 +2770,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) endif ! Secondary forest mean LAI - if ( cpatch%land_use_label .eq secondaryland ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_lai_secondary_si(io_si) = hio_lai_secondary_si(io_si) & + sum(cpatch%tlai_profile(:,:,:)) * cpatch%total_canopy_area end if @@ -2840,7 +2840,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! Increment the number of cohorts per site hio_ncohorts_si(io_si) = hio_ncohorts_si(io_si) + 1._r8 - if ( cpatch%land_use_label .eq secondaryland ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_ncohorts_sec_si(io_si) = hio_ncohorts_sec_si(io_si) + 1._r8 end if @@ -2956,7 +2956,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_nindivs_si_pft(io_si,ft) = hio_nindivs_si_pft(io_si,ft) + & ccohort%n * AREA_INV - if ( cpatch%land_use_label .eq secondaryland ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_nindivs_sec_si_pft(io_si,ft) = hio_nindivs_sec_si_pft(io_si,ft) + & ccohort%n * AREA_INV end if @@ -2964,7 +2964,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & (ccohort%n * AREA_INV) * total_m - if ( cpatch%land_use_label .eq secondaryland ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_biomass_sec_si_pft(io_si, ft) = hio_biomass_sec_si_pft(io_si, ft) + & (ccohort%n * AREA_INV) * total_m end if @@ -2974,7 +2974,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) + total_m * ccohort%n * AREA_INV ! track the total biomass on all secondary lands - if ( cpatch%land_use_label .eq secondaryland ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_biomass_secondary_forest_si(io_si) = hio_biomass_secondary_forest_si(io_si) + & total_m * ccohort%n * AREA_INV endif @@ -3095,7 +3095,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_npp_si_pft(io_si, ft) = hio_npp_si_pft(io_si, ft) + & ccohort%npp_acc_hold * n_perm2 / days_per_year / sec_per_day - if ( cpatch%land_use_label .eq secondaryland ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_gpp_sec_si_pft(io_si, ft) = hio_gpp_sec_si_pft(io_si, ft) + & ccohort%gpp_acc_hold * n_perm2 / days_per_year / sec_per_day hio_npp_sec_si_pft(io_si, ft) = hio_npp_sec_si_pft(io_si, ft) + & @@ -3245,7 +3245,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_m9_si_scls(io_si,scls) = hio_m9_si_scls(io_si,scls) + ccohort%smort*ccohort%n / m2_per_ha ! Examine secondary forest mortality and mortality rates - if(cpatch%land_use_label .eq secondaryland) then + if(cpatch%land_use_label .eq. secondaryland) then if (hlm_use_cohort_age_tracking .eq.itrue) then hio_m10_sec_si_scls(io_si,scls) = hio_m10_sec_si_scls(io_si,scls) + & @@ -3557,7 +3557,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_m3_mortality_understory_si_scpf(io_si,scpf) = hio_m3_mortality_understory_si_scpf(io_si,scpf) + & ccohort%cmort * ccohort%n / m2_per_ha - if ( cpatch%land_use_label .eq secondaryland ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_mortality_canopy_secondary_si_scls(io_si,scls) = hio_mortality_canopy_secondary_si_scls(io_si,scls) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & @@ -3877,7 +3877,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) sites(s)%fmort_rate_canopy(i_scls, i_pft) / m2_per_ha ! Shijie: Think about how to add later? - !if ( cpatch%land_use_label .eq secondaryland ) then + !if ( cpatch%land_use_label .eq. secondaryland ) then ! hio_mortality_canopy_secondary_si_scls(io_si,i_scls) = hio_mortality_canopy_secondary_si_scls(io_si,i_scls) + & ! sites(s)%term_nindivs_canopy(i_scls,i_pft) * days_per_year / m2_per_ha !end if @@ -4610,7 +4610,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ccohort%resp_m_unreduced * n_perm2 * per_dt_tstep ! Secondary forest only - if ( cpatch%land_use_label .eq secondaryland ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_npp_secondary_si(io_si) = hio_npp_secondary_si(io_si) + & npp * n_perm2 * per_dt_tstep hio_gpp_secondary_si(io_si) = hio_gpp_secondary_si(io_si) + & From 1f4633bad20d7c45609975875d76778a267b3dd8 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 18 Apr 2023 15:44:24 -0700 Subject: [PATCH 027/250] Align pasture constant name with other landunits --- biogeochem/EDPatchDynamicsMod.F90 | 8 +++---- biogeochem/FatesLandUseChangeMod.F90 | 28 ++++++++++++------------ main/FatesConstantsMod.F90 | 2 +- parameter_files/fates_params_default.cdl | 8 +++---- 4 files changed, 23 insertions(+), 23 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 99267bb8bf..8c5d7548e7 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -73,7 +73,7 @@ module EDPatchDynamicsMod use FatesConstantsMod , only : days_per_sec use FatesConstantsMod , only : years_per_day use FatesConstantsMod , only : nearzero - use FatesConstantsMod , only : primaryland, secondaryland, pasture, rangeland, crops + use FatesConstantsMod , only : primaryland, secondaryland, pastureland, rangeland, cropland use FatesConstantsMod , only : n_landuse_cats use FatesLandUseChangeMod, only : get_landuse_transition_rates use FatesConstantsMod , only : fates_unset_r8 @@ -2643,9 +2643,9 @@ subroutine fuse_patches( csite, bc_in ) !!cdk this logic for how many patcehs to allow in nocomp will need to be changed maxpatches(primaryland) = max(maxpatch_primary, sum(csite%use_this_pft)) maxpatches(cropland) = maxpatch_cropland - maxpatches(pasture) = maxpatch_pasture + maxpatches(pastureland) = maxpatch_pastureland maxpatches(rangeland) = maxpatch_rangeland - maxpatches(secondaryland) = maxpatch_total - maxpatches(primaryland) - maxpatches(cropland) - maxpatches(pasture) - maxpatches(rangeland) + maxpatches(secondaryland) = maxpatch_total - maxpatches(primaryland) - maxpatches(cropland) - maxpatches(pastureland) - maxpatches(rangeland) if (maxpatch_total .lt. maxpatches(primaryland)) then write(fates_log(),*) 'too many PFTs and not enough patches for nocomp w/o fixed biogeog' write(fates_log(),*) 'maxpatch_total,numpft',maxpatch_total,numpft, sum(csite%use_this_pft) @@ -2655,7 +2655,7 @@ subroutine fuse_patches( csite, bc_in ) maxpatches(primaryland) = maxpatch_primary maxpatches(secondaryland) = maxpatch_secondary maxpatches(cropland) = maxpatch_cropland - maxpatches(pasture) = maxpatch_pasture + maxpatches(pastureland) = maxpatch_pastureland maxpatches(rangeland) = maxpatch_rangeland endif diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index 40d663d51b..268ea303cc 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -3,7 +3,7 @@ module FatesLandUseChangeMod ! Controls the transfer and initialization of patch structure to land use types use FatesGlobals , only : fates_log - use FatesConstantsMod , only : primaryland, secondaryland, pasture, rangeland, cropland + use FatesConstantsMod , only : primaryland, secondaryland, pastureland, rangeland, cropland use FatesConstantsMod , only : n_landuse_cats use FatesConstantsMod , only : nearzero use FatesGlobals , only : endrun => fates_endrun @@ -126,7 +126,7 @@ subroutine init_luh2_fates_mapping luh2_fates_luype_map(4,cropland) = 'c4per' luh2_fates_luype_map(5,cropland) = 'c3nfx' - luh2_fates_luype_map(1,pasture) = 'pastr' + luh2_fates_luype_map(1,pastureland) = 'pastr' luh2_fates_luype_map(1,rangeland) = 'range' @@ -151,58 +151,58 @@ subroutine get_landusechange_rules(clearing_matrix) case(1) clearing_matrix(:,cropland) = .true. - clearing_matrix(:,pasture) = .true. - clearing_matrix(pasture,rangeland) = .true. + clearing_matrix(:,pastureland) = .true. + clearing_matrix(pastureland,rangeland) = .true. clearing_matrix(cropland,rangeland) = .true. case(2) clearing_matrix(:,cropland) = .true. - clearing_matrix(rangeland,pasture) = .true. - clearing_matrix(cropland,pasture) = .true. - clearing_matrix(pasture,rangeland) = .true. + clearing_matrix(rangeland,pastureland) = .true. + clearing_matrix(cropland,pastureland) = .true. + clearing_matrix(pastureland,rangeland) = .true. clearing_matrix(cropland,rangeland) = .true. case(3) clearing_matrix(:,cropland) = .true. - clearing_matrix(:,pasture) = .true. + clearing_matrix(:,pastureland) = .true. clearing_matrix(:,rangeland) = .true. case(4) clearing_matrix(:,cropland) = .true. - clearing_matrix(:,pasture) = .true. + clearing_matrix(:,pastureland) = .true. clearing_matrix(:,rangeland) = .false. case(5) clearing_matrix(:,cropland) = .true. - clearing_matrix(:,pasture) = .false. + clearing_matrix(:,pastureland) = .false. clearing_matrix(:,rangeland) = .true. case(6) clearing_matrix(:,cropland) = .true. - clearing_matrix(:,pasture) = .false. + clearing_matrix(:,pastureland) = .false. clearing_matrix(:,rangeland) = .false. case(7) clearing_matrix(:,cropland) = .false. - clearing_matrix(:,pasture) = .true. + clearing_matrix(:,pastureland) = .true. clearing_matrix(:,rangeland) = .true. case(8) clearing_matrix(:,cropland) = .false. - clearing_matrix(:,pasture) = .true. + clearing_matrix(:,pastureland) = .true. clearing_matrix(:,rangeland) = .false. case(9) clearing_matrix(:,cropland) = .false. - clearing_matrix(:,pasture) = .false. + clearing_matrix(:,pastureland) = .false. clearing_matrix(:,rangeland) = .true. case default diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 4944481395..03142b99bf 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -35,7 +35,7 @@ module FatesConstantsMod integer, parameter, public :: primaryland = 1 integer, parameter, public :: secondaryland = 2 integer, parameter, public :: rangeland = 3 - integer, parameter, public :: pasture = 4 + integer, parameter, public :: pastureland = 4 integer, parameter, public :: cropland = 5 ! Bareground label for no competition mode diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 7ab2438754..70e12524d3 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -737,9 +737,9 @@ variables: double fates_maxpatch_cropland ; fates_maxpatch_cropland:units = "count" ; fates_maxpatch_cropland:long_name = "maximum number of crop patches per site" ; - double fates_maxpatch_pasture ; - fates_maxpatch_pasture:units = "count" ; - fates_maxpatch_pasture:long_name = "maximum number of pasture patches per site" ; + double fates_maxpatch_pastureland ; + fates_maxpatch_pastureland:units = "count" ; + fates_maxpatch_pastureland:long_name = "maximum number of pasture patches per site" ; double fates_maxpatch_rangeland ; fates_maxpatch_rangeland:units = "count" ; fates_maxpatch_rangeland:long_name = "maximum number of rangeland patches per site" ; @@ -1526,7 +1526,7 @@ data: fates_maxpatch_cropland = 1 ; - fates_maxpatch_pasture = 1 ; + fates_maxpatch_pastureland = 1 ; fates_maxpatch_primary = 10 ; From ebce1c0c8f054496543799f2bb4d7c4501aa9b76 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 18 Apr 2023 15:57:00 -0700 Subject: [PATCH 028/250] add landuse transition rate as a patch level variable --- main/EDTypesMod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index fa423205ca..201af26cee 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -565,6 +565,7 @@ module EDTypesMod real(r8) :: disturbance_rates(n_dist_types) ! disturbance rate from 1) mortality ! 2) fire: fraction/day ! 3) logging mortatliy + real(r8) :: landuse_transition_rates(n_landuse_cats) ! land use tranision rate real(r8) :: fract_ldist_not_harvested ! fraction of logged area that is canopy trees that weren't harvested From ae2eac1a924dc63b9d984abd2a65d3f9a383c26d Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 18 Apr 2023 16:25:01 -0700 Subject: [PATCH 029/250] update loop ids to avoid duplicate name scheme This appears to be an build requirement. Named loops need to be unique. --- biogeochem/EDPatchDynamicsMod.F90 | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 8c5d7548e7..710e56a671 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -509,7 +509,7 @@ subroutine spawn_patches( currentSite, bc_in) landusechange_type_loop: do i_landusechange_type = 1, n_luctype landuse_type_loop: do i_donorpatch_landuse_type = 1, n_landuse_cats -s + ! calculate area of disturbed land, in this timestep, by summing contributions from each existing patch. currentPatch => currentSite%youngest_patch @@ -523,12 +523,12 @@ subroutine spawn_patches( currentSite, bc_in) receiver_patch_lu_label = i_donorpatch_landuse_type endif - patchloop: do while(associated(currentPatch)) + patchloop_areadis: do while(associated(currentPatch)) cp_nocomp_matches_1_if: if ( hlm_use_nocomp .eq. ifalse .or. & currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then - patchlabel_matches_lutype_if: if (currentPatch%land_use_label .eq. i_donorpatch_landuse_type) then + patchlabel_matches_lutype_if_areadis: if (currentPatch%land_use_label .eq. i_donorpatch_landuse_type) then if ( i_disturbance_type .ne. dtype_ilandusechange) then disturbance_rate = currentPatch%disturbance_rates(i_disturbance_type) @@ -555,10 +555,10 @@ subroutine spawn_patches( currentSite, bc_in) end if - end if patchlabel_matches_lutype_if + end if patchlabel_matches_lutype_if_areadis end if cp_nocomp_matches_1_if currentPatch => currentPatch%older - enddo patchloop ! end loop over patches. sum area disturbed for all patches. + enddo patchloop_areadis! end loop over patches. sum area disturbed for all patches. ! It is possible that no disturbance area was generated if ( site_areadis > nearzero) then @@ -659,7 +659,6 @@ subroutine spawn_patches( currentSite, bc_in) call landusechange_litter_fluxes(currentSite, currentPatch, & new_patch, patch_site_areadis,bc_in, & clearing_matrix(i_donorpatch_landuse_type,receiver_patch_lu_label)) - endif ! Copy any means or timers from the original patch to the new patch @@ -717,7 +716,7 @@ subroutine spawn_patches( currentSite, bc_in) ! treefall mortality is the current disturbance case (dtype_ifall) - in_canopy_if: if(currentCohort%canopy_layer == 1)then + in_canopy_if_falldtype: if(currentCohort%canopy_layer == 1)then ! In the donor patch we are left with fewer trees because the area has decreased ! the plant density for large trees does not actually decrease in the donor patch @@ -744,7 +743,7 @@ subroutine spawn_patches( currentSite, bc_in) else ! small trees - woody_if: if( prt_params%woody(currentCohort%pft) == itrue)then + woody_if_falldtype: if( prt_params%woody(currentCohort%pft) == itrue)then ! Survivorship of undestory woody plants. Two step process. @@ -833,8 +832,8 @@ subroutine spawn_patches( currentSite, bc_in) nc%lmort_collateral = currentCohort%lmort_collateral nc%lmort_infra = currentCohort%lmort_infra - endif woody_if - endif in_canopy_if + endif woody_if_falldtyp + endif in_canopy_if_falldtype ! Fire is the current disturbance case (dtype_ifire) @@ -969,7 +968,7 @@ subroutine spawn_patches( currentSite, bc_in) case (dtype_ilog) ! If this cohort is in the upper canopy. It generated - in_canopy_if: if(currentCohort%canopy_layer == 1)then + in_canopy_if_logdtype: if(currentCohort%canopy_layer == 1)then ! calculate the survivorship of disturbed trees because non-harvested nc%n = currentCohort%n * currentCohort%l_degrad @@ -1004,7 +1003,7 @@ subroutine spawn_patches( currentSite, bc_in) ! What to do with cohorts in the understory of a logging generated ! disturbance patch? - woody_if: if(prt_params%woody(currentCohort%pft) == itrue)then + woody_if_logdtype: if(prt_params%woody(currentCohort%pft) == itrue)then ! Survivorship of undestory woody plants. Two step process. @@ -1082,9 +1081,9 @@ subroutine spawn_patches( currentSite, bc_in) nc%lmort_collateral = currentCohort%lmort_collateral nc%lmort_infra = currentCohort%lmort_infra - endif woody_if ! is/is-not woody + endif woody_if_logdtyp ! is/is-not woody - endif in_canopy_if ! Select canopy layer + endif in_canopy_if_logdtyp ! Select canopy layer case (dtype_ilandusechange) From deb80396857f6c06dd557759de2d853d3bdfc515 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 18 Apr 2023 17:11:13 -0700 Subject: [PATCH 030/250] add missing end case statement --- biogeochem/EDPatchDynamicsMod.F90 | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 710e56a671..a11a0d7b40 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -659,6 +659,11 @@ subroutine spawn_patches( currentSite, bc_in) call landusechange_litter_fluxes(currentSite, currentPatch, & new_patch, patch_site_areadis,bc_in, & clearing_matrix(i_donorpatch_landuse_type,receiver_patch_lu_label)) + case default + write(fates_log(),*) 'unknown disturbance mode?' + write(fates_log(),*) 'i_disturbance_type: ',i_disturbance_type + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select ! Copy any means or timers from the original patch to the new patch @@ -832,7 +837,7 @@ subroutine spawn_patches( currentSite, bc_in) nc%lmort_collateral = currentCohort%lmort_collateral nc%lmort_infra = currentCohort%lmort_infra - endif woody_if_falldtyp + endif woody_if_falldtype endif in_canopy_if_falldtype ! Fire is the current disturbance @@ -1081,9 +1086,9 @@ subroutine spawn_patches( currentSite, bc_in) nc%lmort_collateral = currentCohort%lmort_collateral nc%lmort_infra = currentCohort%lmort_infra - endif woody_if_logdtyp ! is/is-not woody + endif woody_if_logdtype ! is/is-not woody - endif in_canopy_if_logdtyp ! Select canopy layer + endif in_canopy_if_logdtype ! Select canopy layer case (dtype_ilandusechange) From f419c9450fe77f61368d26da635fcf88c900750c Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 19 Apr 2023 14:13:02 -0700 Subject: [PATCH 031/250] replace site level disturbance variables with one --- biogeochem/EDPatchDynamicsMod.F90 | 4 +--- main/EDInitMod.F90 | 4 +--- main/EDTypesMod.F90 | 10 ++++---- main/FatesHistoryInterfaceMod.F90 | 38 +++++++++++++++---------------- 4 files changed, 25 insertions(+), 31 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index a11a0d7b40..8830a514f7 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -485,9 +485,7 @@ subroutine spawn_patches( currentSite, bc_in) endif ! zero the diagnostic disturbance rate fields - currentSite%disturbance_rates_primary_to_primary(1:N_DIST_TYPES) = 0._r8 - currentSite%disturbance_rates_primary_to_secondary(1:N_DIST_TYPES) = 0._r8 - currentSite%disturbance_rates_secondary_to_secondary(1:N_DIST_TYPES) = 0._r8 + currentSite%disturbance_rates(:) = 0._r8 ! get rules for vegetation clearing during land use change call get_landusechange_rules(clearing_matrix) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 48a791b075..7a8fefa149 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -250,9 +250,7 @@ subroutine zero_site( site_in ) ! Disturbance rates tracking site_in%primary_land_patchfusion_error = 0.0_r8 site_in%potential_disturbance_rates(:) = 0.0_r8 - site_in%disturbance_rates_secondary_to_secondary(:) = 0.0_r8 - site_in%disturbance_rates_primary_to_secondary(:) = 0.0_r8 - site_in%disturbance_rates_primary_to_primary(:) = 0.0_r8 + site_in%disturbance_rates(:) = 0.0_r8 ! FIRE site_in%acc_ni = 0.0_r8 ! daily nesterov index accumulating over time. time unlimited theoretically. diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 201af26cee..56f13698c5 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -565,6 +565,7 @@ module EDTypesMod real(r8) :: disturbance_rates(n_dist_types) ! disturbance rate from 1) mortality ! 2) fire: fraction/day ! 3) logging mortatliy + ! 4) land use change real(r8) :: landuse_transition_rates(n_landuse_cats) ! land use tranision rate real(r8) :: fract_ldist_not_harvested ! fraction of logged area that is canopy trees that weren't harvested @@ -898,12 +899,9 @@ module EDTypesMod real(r8) :: spread ! dynamic canopy allometric term [unitless] ! site-level variables to keep track of the disturbance rates, both actual and "potential" - real(r8) :: disturbance_rates_primary_to_primary(N_DIST_TYPES) ! actual disturbance rates from primary patches to primary patches [m2/m2/day] - real(r8) :: disturbance_rates_primary_to_secondary(N_DIST_TYPES) ! actual disturbance rates from primary patches to secondary patches [m2/m2/day] - real(r8) :: disturbance_rates_secondary_to_secondary(N_DIST_TYPES) ! actual disturbance rates from secondary patches to secondary patches [m2/m2/day] - real(r8) :: potential_disturbance_rates(N_DIST_TYPES) ! "potential" disturb rates (i.e. prior to the "which is most" logic) [m2/m2/day] - real(r8) :: primary_land_patchfusion_error ! error term in total area of primary patches associated with patch fusion [m2/m2/day] - + real(r8) :: disturbance_rates(N_DIST_TYPES) ! actual disturbance rates for each disturbance type [m2/m2/day] + real(r8) :: potential_disturbance_rates(N_DIST_TYPES) ! "potential" disturbance rates (i.e. prior to the "which is most" logic) [m2/m2/day] + real(r8) :: primary_land_patchfusion_error ! error term in total area of primary patches associated with patch fusion [m2/m2/day] real(r8) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) ! land use transition matrix as read in from HLM and aggregated to FATES land use types [m2/m2/year] end type ed_site_type diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 030839efa5..91a8a35e85 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2681,25 +2681,25 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! error in primary lands from patch fusion [m2 m-2 day-1] -> [m2 m-2 yr-1] hio_primaryland_fusion_error_si(io_si) = sites(s)%primary_land_patchfusion_error * days_per_year - ! output site-level disturbance rates [m2 m-2 day-1] -> [m2 m-2 yr-1] - hio_disturbance_rate_p2p_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_primary(1:N_DIST_TYPES)) * days_per_year - hio_disturbance_rate_p2s_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_secondary(1:N_DIST_TYPES)) * days_per_year - hio_disturbance_rate_s2s_si(io_si) = sum(sites(s)%disturbance_rates_secondary_to_secondary(1:N_DIST_TYPES)) * days_per_year - - hio_fire_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ifire) + & - sites(s)%disturbance_rates_primary_to_secondary(dtype_ifire) + & - sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifire)) * & - days_per_year - - hio_logging_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ilog) + & - sites(s)%disturbance_rates_primary_to_secondary(dtype_ilog) + & - sites(s)%disturbance_rates_secondary_to_secondary(dtype_ilog)) * & - days_per_year - - hio_fall_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ifall) + & - sites(s)%disturbance_rates_primary_to_secondary(dtype_ifall) + & - sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifall)) * & - days_per_year + ! output site-level disturbance rates [m2 m-2 day-1] -> [m2 m-2 yr-1] - TO DO rework this + ! hio_disturbance_rate_p2p_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_primary(1:N_DIST_TYPES)) * days_per_year + ! hio_disturbance_rate_p2s_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_secondary(1:N_DIST_TYPES)) * days_per_year + ! hio_disturbance_rate_s2s_si(io_si) = sum(sites(s)%disturbance_rates_secondary_to_secondary(1:N_DIST_TYPES)) * days_per_year + + ! hio_fire_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ifire) + & + ! sites(s)%disturbance_rates_primary_to_secondary(dtype_ifire) + & + ! sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifire)) * & + ! days_per_year + + ! hio_logging_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ilog) + & + ! sites(s)%disturbance_rates_primary_to_secondary(dtype_ilog) + & + ! sites(s)%disturbance_rates_secondary_to_secondary(dtype_ilog)) * & + ! days_per_year + + ! hio_fall_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ifall) + & + ! sites(s)%disturbance_rates_primary_to_secondary(dtype_ifall) + & + ! sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifall)) * & + ! days_per_year hio_potential_disturbance_rate_si(io_si) = sum(sites(s)%potential_disturbance_rates(1:N_DIST_TYPES)) * days_per_year From b4a7f3aaf7c36c241c0e86119ba2cd4d155e86f5 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 19 Apr 2023 15:00:54 -0700 Subject: [PATCH 032/250] adding new maxpatch category registration --- biogeochem/EDPatchDynamicsMod.F90 | 6 +-- main/EDParamsMod.F90 | 61 +++++++++++++++++++----- parameter_files/fates_params_default.cdl | 16 +++---- 3 files changed, 59 insertions(+), 24 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 8830a514f7..0529b20f9f 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -96,8 +96,8 @@ module EDPatchDynamicsMod use SFParamsMod, only : SF_VAL_CWD_FRAC use EDParamsMod, only : logging_event_code use EDParamsMod, only : logging_export_frac - use EDParamsMod, only : maxpatch_primary - use EDParamsMod, only : maxpatch_secondary + use EDParamsMod, only : maxpatch_primaryland, maxpatch_secondaryland + use EDParamsMod, only : maxpatch_pastureland, maxpatch_rangeland, maxpatch_cropland use EDParamsMod, only : maxpatch_total use FatesRunningMeanMod, only : ema_24hr, fixed_24hr, ema_lpa, ema_longterm @@ -2643,7 +2643,7 @@ subroutine fuse_patches( csite, bc_in ) ! if anthropogenic disturance is enabled. if (hlm_use_nocomp.eq.itrue) then !!cdk this logic for how many patcehs to allow in nocomp will need to be changed - maxpatches(primaryland) = max(maxpatch_primary, sum(csite%use_this_pft)) + maxpatches(primaryland) = max(maxpatch_primaryland, sum(csite%use_this_pft)) maxpatches(cropland) = maxpatch_cropland maxpatches(pastureland) = maxpatch_pastureland maxpatches(rangeland) = maxpatch_rangeland diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 40edc6a0b8..3875698f9c 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -185,11 +185,20 @@ module EDParamsMod ! For instance, in SP mode, we want the same number of primary patches as the number of PFTs ! in the fates parameter file, and zero secondary. - integer, public :: maxpatch_primary - character(len=param_string_length), parameter, public :: maxpatch_primary_name = "fates_maxpatch_primary" + integer, public :: maxpatch_primaryland + character(len=param_string_length), parameter, public :: maxpatch_primaryland_name = "fates_maxpatch_primaryland" - integer, public :: maxpatch_secondary - character(len=param_string_length), parameter, public :: maxpatch_secondary_name = "fates_maxpatch_secondary" + integer, public :: maxpatch_secondaryland + character(len=param_string_length), parameter, public :: maxpatch_secondaryland_name = "fates_maxpatch_secondaryland" + + integer, public :: maxpatch_pastureland + character(len=param_string_length), parameter, public :: maxpatch_pastureland_name = "fates_maxpatch_pastureland" + + integer, public :: maxpatch_rangeland + character(len=param_string_length), parameter, public :: maxpatch_rangeland_name = "fates_maxpatch_rangeland" + + integer, public :: maxpatch_cropland + character(len=param_string_length), parameter, public :: maxpatch_cropland_name = "fates_maxpatch_cropland" integer, public :: maxpatch_total @@ -292,8 +301,11 @@ subroutine FatesParamsInit() ED_val_canopy_closure_thresh = nan stomatal_model = -9 stomatal_assim_model = -9 - maxpatch_primary = -9 - maxpatch_secondary = -9 + maxpatch_primaryland = -9 + maxpatch_secondaryland = -9 + maxpatch_pastureland = -9 + maxpatch_rangeland = -9 + maxpatch_cropland = -9 max_cohort_per_patch = -9 hydr_kmax_rsurf1 = nan hydr_kmax_rsurf2 = nan @@ -437,10 +449,19 @@ subroutine FatesRegisterParams(fates_params) call fates_params%RegisterParameter(name=stomatal_assim_name, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) - call fates_params%RegisterParameter(name=maxpatch_primary_name, dimension_shape=dimension_shape_scalar, & + call fates_params%RegisterParameter(name=maxpatch_primaryland_name, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=maxpatch_secondaryland_name, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=maxpatch_pastureland_name, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) - call fates_params%RegisterParameter(name=maxpatch_secondary_name, dimension_shape=dimension_shape_scalar, & + call fates_params%RegisterParameter(name=maxpatch_rangeland_name, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=maxpatch_cropland_name, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) call fates_params%RegisterParameter(name=maxcohort_name, dimension_shape=dimension_shape_scalar, & @@ -641,15 +662,29 @@ subroutine FatesReceiveParams(fates_params) data=tmpreal) stomatal_assim_model = nint(tmpreal) - call fates_params%RetrieveParameter(name=maxpatch_primary_name, & + call fates_params%RetrieveParameter(name=maxpatch_primaryland_name, & + data=tmpreal) + maxpatch_primaryland = nint(tmpreal) + + call fates_params%RetrieveParameter(name=maxpatch_secondaryland_name, & + data=tmpreal) + maxpatch_secondaryland = nint(tmpreal) + + call fates_params%RetrieveParameter(name=maxpatch_pastureland_name, & + data=tmpreal) + maxpatch_pastureland = nint(tmpreal) + + call fates_params%RetrieveParameter(name=maxpatch_rangeland_name, & data=tmpreal) - maxpatch_primary = nint(tmpreal) + maxpatch_rangeland = nint(tmpreal) - call fates_params%RetrieveParameter(name=maxpatch_secondary_name, & + call fates_params%RetrieveParameter(name=maxpatch_cropland_name, & data=tmpreal) - maxpatch_secondary = nint(tmpreal) + maxpatch_cropland = nint(tmpreal) - maxpatch_total = maxpatch_primary+maxpatch_secondary + maxpatch_total = maxpatch_primaryland + maxpatch_secondaryland + & + maxpatch_pastureland + maxpatch_rangeland + & + maxpatch_cropland call fates_params%RetrieveParameter(name=maxcohort_name, & data=tmpreal) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 70e12524d3..408ca1e9ab 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -743,12 +743,12 @@ variables: double fates_maxpatch_rangeland ; fates_maxpatch_rangeland:units = "count" ; fates_maxpatch_rangeland:long_name = "maximum number of rangeland patches per site" ; - double fates_maxpatch_primary ; - fates_maxpatch_primary:units = "count" ; - fates_maxpatch_primary:long_name = "maximum number of primary vegetation patches per site" ; - double fates_maxpatch_secondary ; - fates_maxpatch_secondary:units = "count" ; - fates_maxpatch_secondary:long_name = "maximum number of secondary vegetation patches per site" ; + double fates_maxpatch_primaryland ; + fates_maxpatch_primaryland:units = "count" ; + fates_maxpatch_primaryland:long_name = "maximum number of primary vegetation patches per site" ; + double fates_maxpatch_secondaryland ; + fates_maxpatch_secondaryland:units = "count" ; + fates_maxpatch_secondaryland:long_name = "maximum number of secondaryland vegetation patches per site" ; double fates_mort_disturb_frac ; fates_mort_disturb_frac:units = "fraction" ; fates_mort_disturb_frac:long_name = "fraction of canopy mortality that results in disturbance (i.e. transfer of area from new to old patch)" ; @@ -1528,11 +1528,11 @@ data: fates_maxpatch_pastureland = 1 ; - fates_maxpatch_primary = 10 ; + fates_maxpatch_primaryland = 10 ; fates_maxpatch_rangeland = 1 ; - fates_maxpatch_secondary = 4 ; + fates_maxpatch_secondaryland = 4 ; fates_mort_disturb_frac = 1 ; From b1c4571317af8f1c668e8d07c4009e89da034c3d Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 19 Apr 2023 16:06:50 -0700 Subject: [PATCH 033/250] adding and updating new variable definitions --- biogeochem/EDPatchDynamicsMod.F90 | 23 ++++++++----- main/EDInitMod.F90 | 6 ++-- main/FatesHistoryInterfaceMod.F90 | 55 ++++++++++++++++--------------- main/FatesInterfaceMod.F90 | 20 +++++++---- 4 files changed, 60 insertions(+), 44 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 0529b20f9f..cda0dd5b92 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -448,8 +448,9 @@ subroutine spawn_patches( currentSite, bc_in) type (ed_cohort_type), pointer :: storesmallcohort type (ed_cohort_type), pointer :: storebigcohort real(r8) :: site_areadis_primary ! total area disturbed (to primary forest) in m2 per site per day - real(r8) :: site_areadis_secondary ! total area disturbed (to secondary forest) in m2 per site per day + real(r8) :: site_areadis_secondary ! total area disturbed (to secondary forest) in m2 per site per day real(r8) :: patch_site_areadis ! total area disturbed in m2 per patch per day + real(r8) :: site_areadis ! total site area disturbed in m2 per day real(r8) :: age ! notional age of this patch in years integer :: el ! element loop index integer :: tnull ! is there a tallest cohort? @@ -467,6 +468,10 @@ subroutine spawn_patches( currentSite, bc_in) logical :: found_youngest_primary ! logical for finding the first primary forest patch integer :: min_nocomp_pft, max_nocomp_pft, i_nocomp_pft integer :: i_disturbance_type, i_dist2 ! iterators for looping over disturbance types + integer :: i_landusechange_type ! iterator for the land use change types + integer :: i_donorpatch_landuse_type ! iterator for the land use change types donor patch + integer :: n_luctype ! pass through variable for number of landuse types + integer :: receiver_patch_lu_label ! pass through variable for reciever patch land use type label real(r8) :: disturbance_rate ! rate of disturbance being resolved [fraction of patch area / day] real(r8) :: oldarea ! old patch area prior to disturbance logical :: clearing_matrix(n_landuse_cats,n_landuse_cats) ! do we clear vegetation when transferring from one LU type to another? @@ -643,7 +648,7 @@ subroutine spawn_patches( currentSite, bc_in) ! CDK what do we do here for land use transitions? - select case(disturbance_type) + select case(i_disturbance_type) case (dtype_ilog) call logging_litter_fluxes(currentSite, currentPatch, & new_patch, patch_site_areadis,bc_in) @@ -715,7 +720,7 @@ subroutine spawn_patches( currentSite, bc_in) store_c = currentCohort%prt%GetState(store_organ, carbon12_element) total_c = sapw_c + struct_c + leaf_c + fnrt_c + store_c - disttype_case: select case(disturbance_type) + disttype_case: select case(i_disturbance_type) ! treefall mortality is the current disturbance case (dtype_ifall) @@ -1159,13 +1164,13 @@ subroutine spawn_patches( currentSite, bc_in) currentPatch%disturbance_rates(i_dist2) = currentPatch%disturbance_rates(i_dist2) & * oldarea / currentPatch%area end do - do i_dist = 1,n_landuse_cats - currentPatch%landuse_transition_rates(i_dist) = currentPatch%landuse_transition_rates(i_dist) & + do i_dist2 = 1,n_landuse_cats + currentPatch%landuse_transition_rates(i_dist2) = currentPatch%landuse_transition_rates(i_dist2) & * oldarea / currentPatch%area end do else - do i_dist = i_lu_change+1,n_landuse_cats - currentPatch%landuse_transition_rates(i_dist) = currentPatch%landuse_transition_rates(i_dist) & + do i_dist2 = i_landusechange_type+1,n_landuse_cats + currentPatch%landuse_transition_rates(i_dist2) = currentPatch%landuse_transition_rates(i_dist2) & * oldarea / currentPatch%area end do end if @@ -2654,8 +2659,8 @@ subroutine fuse_patches( csite, bc_in ) call endrun(msg=errMsg(sourcefile, __LINE__)) endif else - maxpatches(primaryland) = maxpatch_primary - maxpatches(secondaryland) = maxpatch_secondary + maxpatches(primaryland) = maxpatch_primaryland + maxpatches(secondaryland) = maxpatch_secondaryland maxpatches(cropland) = maxpatch_cropland maxpatches(pastureland) = maxpatch_pastureland maxpatches(rangeland) = maxpatch_rangeland diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 7a8fefa149..c24d0041cc 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -9,7 +9,8 @@ module EDInitMod use FatesConstantsMod , only : itrue use FatesConstantsMod , only : fates_unset_int use FatesConstantsMod , only : primaryland - use FatesConstantsMod , only : nearzero + use FatesConstantsMod , only : nearzero + use FatesConstantsMod , only : n_landuse_cats use FatesGlobals , only : endrun => fates_endrun use EDTypesMod , only : nclmax use FatesGlobals , only : fates_log @@ -520,12 +521,13 @@ subroutine init_patches( nsites, sites, bc_in) integer :: start_patch integer :: num_new_patches integer :: nocomp_pft - real(r8) :: newparea + real(r8) :: newparea, newparea_withlanduse real(r8) :: tota !check on area integer :: is_first_patch integer :: n_luh_states integer :: luh_state_counter real(r8) :: state_vector(n_landuse_cats) ! [m2/m2] + integer :: i_lu, i_lu_state type(ed_site_type), pointer :: sitep diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 91a8a35e85..2cb00d549c 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -302,9 +302,11 @@ module FatesHistoryInterfaceMod integer :: ih_growth_resp_secondary_si integer :: ih_primaryland_fusion_error_si - integer :: ih_disturbance_rate_p2p_si - integer :: ih_disturbance_rate_p2s_si - integer :: ih_disturbance_rate_s2s_si + ! integer :: ih_disturbance_rate_p2p_si + ! integer :: ih_disturbance_rate_p2s_si + ! integer :: ih_disturbance_rate_s2s_si + ! integer :: ih_disturbance_rate_si + integer :: ih_area_si_landuse integer :: ih_fire_disturbance_rate_si integer :: ih_logging_disturbance_rate_si integer :: ih_fall_disturbance_rate_si @@ -2342,9 +2344,9 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_canopy_biomass_si => this%hvars(ih_canopy_biomass_si)%r81d, & hio_understory_biomass_si => this%hvars(ih_understory_biomass_si)%r81d, & hio_primaryland_fusion_error_si => this%hvars(ih_primaryland_fusion_error_si)%r81d, & - hio_disturbance_rate_p2p_si => this%hvars(ih_disturbance_rate_p2p_si)%r81d, & - hio_disturbance_rate_p2s_si => this%hvars(ih_disturbance_rate_p2s_si)%r81d, & - hio_disturbance_rate_s2s_si => this%hvars(ih_disturbance_rate_s2s_si)%r81d, & + ! hio_disturbance_rate_p2p_si => this%hvars(ih_disturbance_rate_p2p_si)%r81d, & + ! hio_disturbance_rate_p2s_si => this%hvars(ih_disturbance_rate_p2s_si)%r81d, & + ! hio_disturbance_rate_s2s_si => this%hvars(ih_disturbance_rate_s2s_si)%r81d, & hio_fire_disturbance_rate_si => this%hvars(ih_fire_disturbance_rate_si)%r81d, & hio_logging_disturbance_rate_si => this%hvars(ih_logging_disturbance_rate_si)%r81d, & hio_fall_disturbance_rate_si => this%hvars(ih_fall_disturbance_rate_si)%r81d, & @@ -5298,6 +5300,7 @@ subroutine define_history_vars(this, initialize_variables) use FatesIOVariableKindMod, only : site_scagpft_r8, site_agepft_r8 use FatesIOVariableKindMod, only : site_elem_r8, site_elpft_r8, site_clscpf_r8 use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8 + use FatesIOVariableKindMod, only : site_landuse_r8, site_lulu_r8 implicit none @@ -6313,26 +6316,26 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_primaryland_fusion_error_si) - call this%set_history_var(vname='FATES_DISTURBANCE_RATE_P2P', & - units='m2 m-2 yr-1', & - long='disturbance rate from primary to primary lands', & - use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_disturbance_rate_p2p_si) - - call this%set_history_var(vname='FATES_DISTURBANCE_RATE_P2S', & - units='m2 m-2 yr-1', & - long='disturbance rate from primary to secondary lands', & - use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_disturbance_rate_p2s_si ) - - call this%set_history_var(vname='FATES_DISTURBANCE_RATE_S2S', & - units='m2 m-2 yr-1', & - long='disturbance rate from secondary to secondary lands', & - use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_disturbance_rate_s2s_si) + ! call this%set_history_var(vname='FATES_DISTURBANCE_RATE_P2P', & + ! units='m2 m-2 yr-1', & + ! long='disturbance rate from primary to primary lands', & + ! use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + ! upfreq=1, ivar=ivar, initialize=initialize_variables, & + ! index = ih_disturbance_rate_p2p_si) + + ! call this%set_history_var(vname='FATES_DISTURBANCE_RATE_P2S', & + ! units='m2 m-2 yr-1', & + ! long='disturbance rate from primary to secondary lands', & + ! use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + ! upfreq=1, ivar=ivar, initialize=initialize_variables, & + ! index = ih_disturbance_rate_p2s_si ) + + ! call this%set_history_var(vname='FATES_DISTURBANCE_RATE_S2S', & + ! units='m2 m-2 yr-1', & + ! long='disturbance rate from secondary to secondary lands', & + ! use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + ! upfreq=1, ivar=ivar, initialize=initialize_variables, & + ! index = ih_disturbance_rate_s2s_si) call this%set_history_var(vname='FATES_DISTURBANCE_RATE_FIRE', & units='m2 m-2 yr-1', long='disturbance rate from fire', & diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index ed631fbb23..1c31e7ff2d 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -16,8 +16,8 @@ module FatesInterfaceMod use EDParamsMod , only : ED_val_vai_width_increase_factor use EDParamsMod , only : ED_val_history_damage_bin_edges use EDParamsMod , only : maxpatch_total - use EDParamsMod , only : maxpatch_primary - use EDParamsMod , only : maxpatch_secondary + use EDParamsMod , only : maxpatch_primaryland, maxpatch_secondaryland + use EDParamsMod , only : maxpatch_pastureland, maxpatch_rangeland, maxpatch_cropland use EDParamsMod , only : max_cohort_per_patch use EDTypesMod , only : maxSWb use EDTypesMod , only : ivis @@ -765,8 +765,11 @@ subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft) ! to hold all PFTs. So create the same number of ! patches as the number of PFTs - maxpatch_primary = fates_numpft - maxpatch_secondary = 0 + maxpatch_primaryland = fates_numpft + maxpatch_secondaryland = 0 + maxpatch_pastureland = 0 + maxpatch_rangeland = 0 + maxpatch_cropland = 0 maxpatch_total = fates_numpft ! If this is an SP run, we actually need enough patches on the @@ -781,13 +784,16 @@ subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft) else ! If we are using fixed biogeography or no-comp then we - ! can also apply those constraints to maxpatch_primary and secondary + ! can also apply those constraints to maxpatch_primaryland and secondary ! and that value will match fates_maxPatchesPerSite if(hlm_use_nocomp==itrue) then - maxpatch_primary = max(maxpatch_primary,fates_numpft) - maxpatch_total = maxpatch_primary + maxpatch_secondary + maxpatch_primaryland = max(maxpatch_primaryland,fates_numpft) + maxpatch_total = maxpatch_primaryland + maxpatch_secondaryland + & + maxpatch_pastureland + maxpatch_rangeland + & + maxpatch_cropland + !if(maxpatch_primary Date: Thu, 20 Apr 2023 09:37:54 -0700 Subject: [PATCH 034/250] logic fix for receiver patch label during land use change --- biogeochem/EDPatchDynamicsMod.F90 | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index cda0dd5b92..cd2e2c0587 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -468,7 +468,7 @@ subroutine spawn_patches( currentSite, bc_in) logical :: found_youngest_primary ! logical for finding the first primary forest patch integer :: min_nocomp_pft, max_nocomp_pft, i_nocomp_pft integer :: i_disturbance_type, i_dist2 ! iterators for looping over disturbance types - integer :: i_landusechange_type ! iterator for the land use change types + integer :: i_landusechange_receiverpatchlabel ! iterator for the land use change types integer :: i_donorpatch_landuse_type ! iterator for the land use change types donor patch integer :: n_luctype ! pass through variable for number of landuse types integer :: receiver_patch_lu_label ! pass through variable for reciever patch land use type label @@ -509,9 +509,9 @@ subroutine spawn_patches( currentSite, bc_in) n_luctype = 1 endif - landusechange_type_loop: do i_landusechange_type = 1, n_luctype + landusechange_receiverpatchlabel_loop: do i_landusechange_receiverpatchlabel = 1, n_luctype - landuse_type_loop: do i_donorpatch_landuse_type = 1, n_landuse_cats + landuse_donortype_loop: do i_donorpatch_landuse_type = 1, n_landuse_cats ! calculate area of disturbed land, in this timestep, by summing contributions from each existing patch. currentPatch => currentSite%youngest_patch @@ -522,6 +522,8 @@ subroutine spawn_patches( currentSite, bc_in) ! this disturbance label and disturbance of this type will have if ( i_disturbance_type .eq. dtype_ilog) then receiver_patch_lu_label =secondaryland + else if ( i_disturbance_type .eq. dtype_ilandusechange) then + receiver_patch_lu_label = i_landusechange_receiverpatchlabel else receiver_patch_lu_label = i_donorpatch_landuse_type endif @@ -536,7 +538,7 @@ subroutine spawn_patches( currentSite, bc_in) if ( i_disturbance_type .ne. dtype_ilandusechange) then disturbance_rate = currentPatch%disturbance_rates(i_disturbance_type) else - disturbance_rate = currentPatch%landuse_transition_rates(i_landusechange_type) + disturbance_rate = currentPatch%landuse_transition_rates(i_landusechange_receiverpatchlabel) endif if(disturbance_rate > (1.0_r8 + rsnbl_math_prec)) then @@ -608,7 +610,7 @@ subroutine spawn_patches( currentSite, bc_in) if ( i_disturbance_type .ne. dtype_ilandusechange) then disturbance_rate = currentPatch%disturbance_rates(i_disturbance_type) else - disturbance_rate = currentPatch%landuse_transition_rates(i_landusechange_type) + disturbance_rate = currentPatch%landuse_transition_rates(i_landusechange_receiverpatchlabel) endif patch_site_areadis = currentPatch%area * disturbance_rate @@ -1169,7 +1171,7 @@ subroutine spawn_patches( currentSite, bc_in) * oldarea / currentPatch%area end do else - do i_dist2 = i_landusechange_type+1,n_landuse_cats + do i_dist2 = i_landusechange_receiverpatchlabel+1,n_landuse_cats currentPatch%landuse_transition_rates(i_dist2) = currentPatch%landuse_transition_rates(i_dist2) & * oldarea / currentPatch%area end do @@ -1250,9 +1252,9 @@ subroutine spawn_patches( currentSite, bc_in) call check_patch_area(currentSite) call set_patchno(currentSite) - end do landuse_type_loop + end do landuse_donortype_loop - end do landusechange_type_loop + end do landusechange_receiverpatchlabel_loop end do disturbance_type_loop end do nocomp_pft_loop From fb7b4eb965cbfbf6d277eeb31bb37228db30d553 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 20 Apr 2023 11:27:15 -0700 Subject: [PATCH 035/250] adding use statements for land use change mod --- biogeochem/EDPatchDynamicsMod.F90 | 8 +++++--- main/EDInitMod.F90 | 1 + 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index cd2e2c0587..634e131a6c 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -429,9 +429,11 @@ subroutine spawn_patches( currentSite, bc_in) ! ! !USES: - use EDParamsMod , only : ED_val_understorey_death, logging_coll_under_frac - use EDCohortDynamicsMod , only : zero_cohort, copy_cohort, terminate_cohorts - use FatesConstantsMod , only : rsnbl_math_prec + use EDParamsMod , only : ED_val_understorey_death, logging_coll_under_frac + use EDCohortDynamicsMod , only : zero_cohort, copy_cohort, terminate_cohorts + use FatesConstantsMod , only : rsnbl_math_prec + use FatesLandUseChangeMod, only : get_landuse_transition_rates + use FatesLandUseChangeMod, only : get_landusechange_rules ! ! !ARGUMENTS: diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index c24d0041cc..6df6766bcc 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -500,6 +500,7 @@ subroutine init_patches( nsites, sites, bc_in) use FatesPlantHydraulicsMod, only : updateSizeDepRhizHydProps use FatesInventoryInitMod, only : initialize_sites_by_inventory + use FatesLandUseChangeMod, only : get_luh_statedata ! ! !ARGUMENTS From 6c8f560b88199b152502c876a04d283d54c5cdb3 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Thu, 20 Apr 2023 15:57:27 -0700 Subject: [PATCH 036/250] updated diagnostic disturbance rates variables --- biogeochem/EDPatchDynamicsMod.F90 | 15 ++----- main/EDInitMod.F90 | 3 +- main/EDTypesMod.F90 | 3 +- main/FatesHistoryInterfaceMod.F90 | 75 +++++++++---------------------- 4 files changed, 26 insertions(+), 70 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 634e131a6c..1673d09e67 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -280,9 +280,6 @@ subroutine disturbance_rates( site_in, bc_in) ! Calculate Disturbance Rates based on the mortality rates just calculated ! --------------------------------------------------------------------------------------------- - ! zero the diagnostic disturbance rate fields - site_in%potential_disturbance_rates(1:N_DIST_TYPES) = 0._r8 - ! Recalculate total canopy area prior to resolving the disturbance currentPatch => site_in%oldest_patch do while (associated(currentPatch)) @@ -381,12 +378,6 @@ subroutine disturbance_rates( site_in, bc_in) ! Fire Disturbance Rate currentPatch%disturbance_rates(dtype_ifire) = currentPatch%frac_burnt - ! calculate a disgnostic sum of disturbance rates for different classes of disturbance across all patches in this site. - do i_dist = 1,N_DIST_TYPES - site_in%potential_disturbance_rates(i_dist) = site_in%potential_disturbance_rates(i_dist) + & - currentPatch%disturbance_rates(i_dist) * currentPatch%area * AREA_INV - end do - ! Fires can't burn the whole patch, as this causes /0 errors. if (currentPatch%disturbance_rates(dtype_ifire) > 0.98_r8)then msg = 'very high fire areas'//trim(A2S(currentPatch%disturbance_rates(:)))//trim(N2S(currentPatch%frac_burnt)) @@ -492,7 +483,7 @@ subroutine spawn_patches( currentSite, bc_in) endif ! zero the diagnostic disturbance rate fields - currentSite%disturbance_rates(:) = 0._r8 + currentSite%disturbance_rates(:,:,:) = 0._r8 ! get rules for vegetation clearing during land use change call get_landusechange_rules(clearing_matrix) @@ -555,8 +546,8 @@ subroutine spawn_patches( currentSite, bc_in) site_areadis = site_areadis + currentPatch%area * disturbance_rate ! track disturbance rates to output to history - currentSite%disturbance_rates(i_disturbance_type) = & - currentSite%disturbance_rates(i_disturbance_type) + & + currentSite%disturbance_rates(i_disturbance_type,i_donorpatch_landuse_type,receiver_patch_lu_label) = & + currentSite%disturbance_rates(i_disturbance_type,i_donorpatch_landuse_type,receiver_patch_lu_label) + & currentPatch%area * disturbance_rate * AREA_INV diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 6df6766bcc..3f22c09c14 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -250,8 +250,7 @@ subroutine zero_site( site_in ) ! Disturbance rates tracking site_in%primary_land_patchfusion_error = 0.0_r8 - site_in%potential_disturbance_rates(:) = 0.0_r8 - site_in%disturbance_rates(:) = 0.0_r8 + site_in%disturbance_rates(:,:,:) = 0.0_r8 ! FIRE site_in%acc_ni = 0.0_r8 ! daily nesterov index accumulating over time. time unlimited theoretically. diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 56f13698c5..84c1fb7a4b 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -899,8 +899,7 @@ module EDTypesMod real(r8) :: spread ! dynamic canopy allometric term [unitless] ! site-level variables to keep track of the disturbance rates, both actual and "potential" - real(r8) :: disturbance_rates(N_DIST_TYPES) ! actual disturbance rates for each disturbance type [m2/m2/day] - real(r8) :: potential_disturbance_rates(N_DIST_TYPES) ! "potential" disturbance rates (i.e. prior to the "which is most" logic) [m2/m2/day] + real(r8) :: disturbance_rates(N_DIST_TYPES,n_landuse_cats, n_landuse_cats) ! actual disturbance rates for each disturbance type [m2/m2/day] real(r8) :: primary_land_patchfusion_error ! error term in total area of primary patches associated with patch fusion [m2/m2/day] real(r8) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) ! land use transition matrix as read in from HLM and aggregated to FATES land use types [m2/m2/year] diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 2cb00d549c..85d14962de 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -302,15 +302,11 @@ module FatesHistoryInterfaceMod integer :: ih_growth_resp_secondary_si integer :: ih_primaryland_fusion_error_si - ! integer :: ih_disturbance_rate_p2p_si - ! integer :: ih_disturbance_rate_p2s_si - ! integer :: ih_disturbance_rate_s2s_si - ! integer :: ih_disturbance_rate_si integer :: ih_area_si_landuse + integer :: ih_disturbance_rate_si_lulu integer :: ih_fire_disturbance_rate_si integer :: ih_logging_disturbance_rate_si integer :: ih_fall_disturbance_rate_si - integer :: ih_potential_disturbance_rate_si integer :: ih_harvest_carbonflux_si integer :: ih_harvest_debt_si integer :: ih_harvest_debt_sec_si @@ -2275,6 +2271,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) real(r8) :: storec_understory_scpf(numpft*nlevsclass) integer :: return_code + integer :: i_dist, j_dist type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort @@ -2344,13 +2341,10 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_canopy_biomass_si => this%hvars(ih_canopy_biomass_si)%r81d, & hio_understory_biomass_si => this%hvars(ih_understory_biomass_si)%r81d, & hio_primaryland_fusion_error_si => this%hvars(ih_primaryland_fusion_error_si)%r81d, & - ! hio_disturbance_rate_p2p_si => this%hvars(ih_disturbance_rate_p2p_si)%r81d, & - ! hio_disturbance_rate_p2s_si => this%hvars(ih_disturbance_rate_p2s_si)%r81d, & - ! hio_disturbance_rate_s2s_si => this%hvars(ih_disturbance_rate_s2s_si)%r81d, & + hio_disturbance_rate_si_lulu => this%hvars(ih_disturbance_rate_si_lulu)%r82d, & hio_fire_disturbance_rate_si => this%hvars(ih_fire_disturbance_rate_si)%r81d, & hio_logging_disturbance_rate_si => this%hvars(ih_logging_disturbance_rate_si)%r81d, & hio_fall_disturbance_rate_si => this%hvars(ih_fall_disturbance_rate_si)%r81d, & - hio_potential_disturbance_rate_si => this%hvars(ih_potential_disturbance_rate_si)%r81d, & hio_harvest_carbonflux_si => this%hvars(ih_harvest_carbonflux_si)%r81d, & hio_harvest_debt_si => this%hvars(ih_harvest_debt_si)%r81d, & hio_harvest_debt_sec_si => this%hvars(ih_harvest_debt_sec_si)%r81d, & @@ -2683,27 +2677,23 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! error in primary lands from patch fusion [m2 m-2 day-1] -> [m2 m-2 yr-1] hio_primaryland_fusion_error_si(io_si) = sites(s)%primary_land_patchfusion_error * days_per_year - ! output site-level disturbance rates [m2 m-2 day-1] -> [m2 m-2 yr-1] - TO DO rework this - ! hio_disturbance_rate_p2p_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_primary(1:N_DIST_TYPES)) * days_per_year - ! hio_disturbance_rate_p2s_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_secondary(1:N_DIST_TYPES)) * days_per_year - ! hio_disturbance_rate_s2s_si(io_si) = sum(sites(s)%disturbance_rates_secondary_to_secondary(1:N_DIST_TYPES)) * days_per_year + do i_dist = 1, n_landuse_cats + do j_dist = 1, n_landuse_cats + hio_disturbance_rate_si_lulu(io_si, i_dist, j_dist) = sum(site%disturbance_rates(1:n_dist_types,i_dist, j_dist) * & + days_per_year + end do + end do - ! hio_fire_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ifire) + & - ! sites(s)%disturbance_rates_primary_to_secondary(dtype_ifire) + & - ! sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifire)) * & - ! days_per_year + ! output site-level disturbance rates [m2 m-2 day-1] -> [m2 m-2 yr-1] - TO DO rework this - ! hio_logging_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ilog) + & - ! sites(s)%disturbance_rates_primary_to_secondary(dtype_ilog) + & - ! sites(s)%disturbance_rates_secondary_to_secondary(dtype_ilog)) * & - ! days_per_year + hio_fire_disturbance_rate_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_primary(dtype_ifire,1:n_landuse_cats,1:n_landuse_cats)) * & + days_per_year - ! hio_fall_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ifall) + & - ! sites(s)%disturbance_rates_primary_to_secondary(dtype_ifall) + & - ! sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifall)) * & - ! days_per_year + hio_logging_disturbance_rate_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_primary(dtype_ilog,1:n_landuse_cats,1:n_landuse_cats)) * & + days_per_year - hio_potential_disturbance_rate_si(io_si) = sum(sites(s)%potential_disturbance_rates(1:N_DIST_TYPES)) * days_per_year + hio_fall_disturbance_rate_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_primary(dtype_ifall,1:n_landuse_cats,1:n_landuse_cats)) * & + days_per_year hio_harvest_carbonflux_si(io_si) = sites(s)%mass_balance(element_pos(carbon12_element))%wood_product * AREA_INV @@ -5658,6 +5648,11 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_landuse_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index=ih_area_si_landuse) + call this%set_history_var(vname='FATES_DISTURBANCE_RATE_MATRIX_LULU', units='m2 m-2 yr-1', & + long='disturbance rates by land use type x land use type matrix', use_default='active', & + avgflag='A', vtype=site_lulu_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index=ih_disturbance_rate_si_lulu) + ! Secondary forest area and age diagnostics call this%set_history_var(vname='FATES_SECONDARY_FOREST_FRACTION', & @@ -6316,27 +6311,6 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_primaryland_fusion_error_si) - ! call this%set_history_var(vname='FATES_DISTURBANCE_RATE_P2P', & - ! units='m2 m-2 yr-1', & - ! long='disturbance rate from primary to primary lands', & - ! use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - ! upfreq=1, ivar=ivar, initialize=initialize_variables, & - ! index = ih_disturbance_rate_p2p_si) - - ! call this%set_history_var(vname='FATES_DISTURBANCE_RATE_P2S', & - ! units='m2 m-2 yr-1', & - ! long='disturbance rate from primary to secondary lands', & - ! use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - ! upfreq=1, ivar=ivar, initialize=initialize_variables, & - ! index = ih_disturbance_rate_p2s_si ) - - ! call this%set_history_var(vname='FATES_DISTURBANCE_RATE_S2S', & - ! units='m2 m-2 yr-1', & - ! long='disturbance rate from secondary to secondary lands', & - ! use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - ! upfreq=1, ivar=ivar, initialize=initialize_variables, & - ! index = ih_disturbance_rate_s2s_si) - call this%set_history_var(vname='FATES_DISTURBANCE_RATE_FIRE', & units='m2 m-2 yr-1', long='disturbance rate from fire', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & @@ -6355,13 +6329,6 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_fall_disturbance_rate_si) - call this%set_history_var(vname='FATES_DISTURBANCE_RATE_POTENTIAL', & - units='m2 m-2 yr-1', & - long='potential (i.e., including unresolved) disturbance rate', & - use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_potential_disturbance_rate_si) - call this%set_history_var(vname='FATES_HARVEST_CARBON_FLUX', & units='kg m-2 yr-1', & long='harvest carbon flux in kg carbon per m2 per year', & From 3f2fc4bdd02e789cffd55c95138c7aefec8d662b Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Thu, 20 Apr 2023 21:30:49 -0700 Subject: [PATCH 037/250] fixing the math on prior --- main/FatesHistoryInterfaceMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 85d14962de..0f35375618 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2677,9 +2677,10 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! error in primary lands from patch fusion [m2 m-2 day-1] -> [m2 m-2 yr-1] hio_primaryland_fusion_error_si(io_si) = sites(s)%primary_land_patchfusion_error * days_per_year + ! roll up disturbance rates in land-use x land-use array into a single dimension do i_dist = 1, n_landuse_cats do j_dist = 1, n_landuse_cats - hio_disturbance_rate_si_lulu(io_si, i_dist, j_dist) = sum(site%disturbance_rates(1:n_dist_types,i_dist, j_dist) * & + hio_disturbance_rate_si_lulu(io_si, i_dist+n_landuse_cats*(j_dist-1)) = sum(site%disturbance_rates(1:n_dist_types,i_dist, j_dist) * & days_per_year end do end do From 825d327037e1a0f8e5422f7ba1e4644fc561f766 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 21 Apr 2023 08:26:28 -0700 Subject: [PATCH 038/250] simplifying labeling logic for disturbance types --- biogeochem/EDPatchDynamicsMod.F90 | 39 ++++++++++++++----------------- 1 file changed, 18 insertions(+), 21 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 1673d09e67..fc674ebbf4 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -463,8 +463,8 @@ subroutine spawn_patches( currentSite, bc_in) integer :: i_disturbance_type, i_dist2 ! iterators for looping over disturbance types integer :: i_landusechange_receiverpatchlabel ! iterator for the land use change types integer :: i_donorpatch_landuse_type ! iterator for the land use change types donor patch - integer :: n_luctype ! pass through variable for number of landuse types - integer :: receiver_patch_lu_label ! pass through variable for reciever patch land use type label + integer :: start_receiver_lulabel ! starting bound for receiver landuse label type loop + integer :: end_receiver_lulabel ! ending bound for receiver landuse label type loop real(r8) :: disturbance_rate ! rate of disturbance being resolved [fraction of patch area / day] real(r8) :: oldarea ! old patch area prior to disturbance logical :: clearing_matrix(n_landuse_cats,n_landuse_cats) ! do we clear vegetation when transferring from one LU type to another? @@ -496,13 +496,20 @@ subroutine spawn_patches( currentSite, bc_in) disturbance_type_loop: do i_disturbance_type = 1,N_DIST_TYPES - if ( i_disturbance_type .eq. dtype_ilandusechange) then - n_luctype = n_landuse_cats + ! figure out what land use label(s) the receiver patch for disturbance from patches with + ! this disturbance label and disturbance of this type will have, and set receiver label loop bounds accordingly + if ( i_disturbance_type .eq. dtype_ilog) then + start_receiver_lulabel = secondaryland + end_receiver_lulabel = secondaryland + else if ( i_disturbance_type .eq. dtype_ilandusechange) then + start_receiver_lulabel = 1 ! this should actually maybe be 2, as primaryland column of matrix should all be zeros, but leave as 1 for now + end_receiver_lulabel = n_landuse_cats else - n_luctype = 1 + start_receiver_lulabel = i_donorpatch_landuse_type + end_receiver_lulabel = i_donorpatch_landuse_type endif - landusechange_receiverpatchlabel_loop: do i_landusechange_receiverpatchlabel = 1, n_luctype + landusechange_receiverpatchlabel_loop: do i_landusechange_receiverpatchlabel = start_receiver_lulabel, end_receiver_lulabel landuse_donortype_loop: do i_donorpatch_landuse_type = 1, n_landuse_cats @@ -511,16 +518,6 @@ subroutine spawn_patches( currentSite, bc_in) site_areadis = 0.0_r8 - ! figure out what land use label the receiver patch for disturbance from patches with - ! this disturbance label and disturbance of this type will have - if ( i_disturbance_type .eq. dtype_ilog) then - receiver_patch_lu_label =secondaryland - else if ( i_disturbance_type .eq. dtype_ilandusechange) then - receiver_patch_lu_label = i_landusechange_receiverpatchlabel - else - receiver_patch_lu_label = i_donorpatch_landuse_type - endif - patchloop_areadis: do while(associated(currentPatch)) cp_nocomp_matches_1_if: if ( hlm_use_nocomp .eq. ifalse .or. & @@ -546,8 +543,8 @@ subroutine spawn_patches( currentSite, bc_in) site_areadis = site_areadis + currentPatch%area * disturbance_rate ! track disturbance rates to output to history - currentSite%disturbance_rates(i_disturbance_type,i_donorpatch_landuse_type,receiver_patch_lu_label) = & - currentSite%disturbance_rates(i_disturbance_type,i_donorpatch_landuse_type,receiver_patch_lu_label) + & + currentSite%disturbance_rates(i_disturbance_type,i_donorpatch_landuse_type,i_landusechange_receiverpatchlabel) = & + currentSite%disturbance_rates(i_disturbance_type,i_donorpatch_landuse_type,i_landusechange_receiverpatchlabel) + & currentPatch%area * disturbance_rate * AREA_INV @@ -567,7 +564,7 @@ subroutine spawn_patches( currentSite, bc_in) allocate(new_patch) call create_patch(currentSite, new_patch, age, & - site_areadis, receiver_patch_lu_label, i_nocomp_pft) + site_areadis, i_landusechange_receiverpatchlabel, i_nocomp_pft) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -656,7 +653,7 @@ subroutine spawn_patches( currentSite, bc_in) case (dtype_ilandusechange) call landusechange_litter_fluxes(currentSite, currentPatch, & new_patch, patch_site_areadis,bc_in, & - clearing_matrix(i_donorpatch_landuse_type,receiver_patch_lu_label)) + clearing_matrix(i_donorpatch_landuse_type,i_landusechange_receiverpatchlabel)) case default write(fates_log(),*) 'unknown disturbance mode?' write(fates_log(),*) 'i_disturbance_type: ',i_disturbance_type @@ -1098,7 +1095,7 @@ subroutine spawn_patches( currentSite, bc_in) currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) ! now apply survivorship based on the type of landuse transition - if ( clearing_matrix(i_donorpatch_landuse_type,receiver_patch_lu_label) ) then + if ( clearing_matrix(i_donorpatch_landuse_type,i_landusechange_receiverpatchlabel) ) then ! kill everything nc%n = 0._r8 end if From 3026872baf953a7b8754c08388d5cd4126ae5885 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 21 Apr 2023 08:30:52 -0700 Subject: [PATCH 039/250] bugfix on prior --- biogeochem/EDPatchDynamicsMod.F90 | 33 +++++++++++++++---------------- 1 file changed, 16 insertions(+), 17 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index fc674ebbf4..0d83500fa2 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -496,22 +496,21 @@ subroutine spawn_patches( currentSite, bc_in) disturbance_type_loop: do i_disturbance_type = 1,N_DIST_TYPES - ! figure out what land use label(s) the receiver patch for disturbance from patches with - ! this disturbance label and disturbance of this type will have, and set receiver label loop bounds accordingly - if ( i_disturbance_type .eq. dtype_ilog) then - start_receiver_lulabel = secondaryland - end_receiver_lulabel = secondaryland - else if ( i_disturbance_type .eq. dtype_ilandusechange) then - start_receiver_lulabel = 1 ! this should actually maybe be 2, as primaryland column of matrix should all be zeros, but leave as 1 for now - end_receiver_lulabel = n_landuse_cats - else - start_receiver_lulabel = i_donorpatch_landuse_type - end_receiver_lulabel = i_donorpatch_landuse_type - endif - - landusechange_receiverpatchlabel_loop: do i_landusechange_receiverpatchlabel = start_receiver_lulabel, end_receiver_lulabel + landuse_donortype_loop: do i_donorpatch_landuse_type = 1, n_landuse_cats + ! figure out what land use label(s) the receiver patch for disturbance from patches with + ! this disturbance label and disturbance of this type will have, and set receiver label loop bounds accordingly + if ( i_disturbance_type .eq. dtype_ilog) then + start_receiver_lulabel = secondaryland + end_receiver_lulabel = secondaryland + else if ( i_disturbance_type .eq. dtype_ilandusechange) then + start_receiver_lulabel = 1 ! this could actually maybe be 2, as primaryland column of matrix should all be zeros, but leave as 1 for now + end_receiver_lulabel = n_landuse_cats + else + start_receiver_lulabel = i_donorpatch_landuse_type + end_receiver_lulabel = i_donorpatch_landuse_type + endif - landuse_donortype_loop: do i_donorpatch_landuse_type = 1, n_landuse_cats + landusechange_receiverpatchlabel_loop: do i_landusechange_receiverpatchlabel = start_receiver_lulabel, end_receiver_lulabel ! calculate area of disturbed land, in this timestep, by summing contributions from each existing patch. currentPatch => currentSite%youngest_patch @@ -1242,9 +1241,9 @@ subroutine spawn_patches( currentSite, bc_in) call check_patch_area(currentSite) call set_patchno(currentSite) - end do landuse_donortype_loop - end do landusechange_receiverpatchlabel_loop + end do landusechange_receiverpatchlabel_loop + end do landuse_donortype_loop end do disturbance_type_loop end do nocomp_pft_loop From a616aa74ad00df9e1940eb88ed5c68cd945f6a57 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Sat, 22 Apr 2023 11:13:03 -0700 Subject: [PATCH 040/250] copy patch xml file --- .../archive/api26.0.0_042223_luh2.xml | 33 +++++++++++++++++++ 1 file changed, 33 insertions(+) create mode 100644 parameter_files/archive/api26.0.0_042223_luh2.xml diff --git a/parameter_files/archive/api26.0.0_042223_luh2.xml b/parameter_files/archive/api26.0.0_042223_luh2.xml new file mode 100644 index 0000000000..e68fb782cc --- /dev/null +++ b/parameter_files/archive/api26.0.0_042223_luh2.xml @@ -0,0 +1,33 @@ + + + + + + + + + + + + + + + + + + + archive/api25.3.0_032223_fates_params_default.cdl + fates_params_default.cdl + 1,2,3,4,5,6,7,8,9,10,11,12 + + + initial seedling density for a cold-start near-bare-ground simulation. If negative sets initial tree dbh - only to be used in nocomp mode + + + From b994fd9468aa805a03af061d085bf7839c88cf25 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Sat, 22 Apr 2023 11:24:50 -0700 Subject: [PATCH 041/250] update xml patch file with necessary changes --- .../archive/api26.0.0_042223_luh2.xml | 30 +++++++++++++++++-- 1 file changed, 27 insertions(+), 3 deletions(-) diff --git a/parameter_files/archive/api26.0.0_042223_luh2.xml b/parameter_files/archive/api26.0.0_042223_luh2.xml index e68fb782cc..8b2afe7655 100644 --- a/parameter_files/archive/api26.0.0_042223_luh2.xml +++ b/parameter_files/archive/api26.0.0_042223_luh2.xml @@ -22,12 +22,36 @@ the variables --> - archive/api25.3.0_032223_fates_params_default.cdl + archive/api25.4.0_042223_fates_params_default.cdl fates_params_default.cdl 1,2,3,4,5,6,7,8,9,10,11,12 - - initial seedling density for a cold-start near-bare-ground simulation. If negative sets initial tree dbh - only to be used in nocomp mode + + fates_maxpatch_cropland + scalar + count + maximum number of cropland patches per site + 1 + + + fates_maxpatch_pastureland + scalar + count + maximum number of pastureland patches per site + 1 + + + fates_maxpatch_rangeland + scalar + count + maximum number of rangeland patches per site + 1 + + + fates_maxpatch_primaryland + + + fates_maxpatch_secondaryland From 9a9ef83913a915a502d9b113231b82d0d66940af Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Sat, 22 Apr 2023 11:32:49 -0700 Subject: [PATCH 042/250] add api25.4 fates default paramfile to archive --- .../api25.4.0_042223_fates_paras_default.cdl | 1559 +++++++++++++++++ 1 file changed, 1559 insertions(+) create mode 100644 parameter_files/archive/api25.4.0_042223_fates_paras_default.cdl diff --git a/parameter_files/archive/api25.4.0_042223_fates_paras_default.cdl b/parameter_files/archive/api25.4.0_042223_fates_paras_default.cdl new file mode 100644 index 0000000000..d461cb6fbb --- /dev/null +++ b/parameter_files/archive/api25.4.0_042223_fates_paras_default.cdl @@ -0,0 +1,1559 @@ +netcdf fates_params_default { +dimensions: + fates_NCWD = 4 ; + fates_history_age_bins = 7 ; + fates_history_coage_bins = 2 ; + fates_history_damage_bins = 2 ; + fates_history_height_bins = 6 ; + fates_history_size_bins = 13 ; + fates_hlm_pftno = 14 ; + fates_hydr_organs = 4 ; + fates_leafage_class = 1 ; + fates_litterclass = 6 ; + fates_pft = 12 ; + fates_plant_organs = 4 ; + fates_string_length = 60 ; +variables: + double fates_history_ageclass_bin_edges(fates_history_age_bins) ; + fates_history_ageclass_bin_edges:units = "yr" ; + fates_history_ageclass_bin_edges:long_name = "Lower edges for age class bins used in age-resolved patch history output" ; + double fates_history_coageclass_bin_edges(fates_history_coage_bins) ; + fates_history_coageclass_bin_edges:units = "years" ; + fates_history_coageclass_bin_edges:long_name = "Lower edges for cohort age class bins used in cohort age resolved history output" ; + double fates_history_height_bin_edges(fates_history_height_bins) ; + fates_history_height_bin_edges:units = "m" ; + fates_history_height_bin_edges:long_name = "Lower edges for height bins used in height-resolved history output" ; + double fates_history_damage_bin_edges(fates_history_damage_bins) ; + fates_history_damage_bin_edges:units = "% crown loss" ; + fates_history_damage_bin_edges:long_name = "Lower edges for damage class bins used in cohort history output" ; + double fates_history_sizeclass_bin_edges(fates_history_size_bins) ; + fates_history_sizeclass_bin_edges:units = "cm" ; + fates_history_sizeclass_bin_edges:long_name = "Lower edges for DBH size class bins used in size-resolved cohort history output" ; + double fates_alloc_organ_id(fates_plant_organs) ; + fates_alloc_organ_id:units = "unitless" ; + fates_alloc_organ_id:long_name = "This is the global index that the organ in this file is associated with, values match those in parteh/PRTGenericMod.F90" ; + double fates_hydro_htftype_node(fates_hydr_organs) ; + fates_hydro_htftype_node:units = "unitless" ; + fates_hydro_htftype_node:long_name = "Switch that defines the hydraulic transfer functions for each organ." ; + char fates_pftname(fates_pft, fates_string_length) ; + fates_pftname:units = "unitless - string" ; + fates_pftname:long_name = "Description of plant type" ; + char fates_hydro_organ_name(fates_hydr_organs, fates_string_length) ; + fates_hydro_organ_name:units = "unitless - string" ; + fates_hydro_organ_name:long_name = "Name of plant hydraulics organs (DONT CHANGE, order matches media list in FatesHydraulicsMemMod.F90)" ; + char fates_alloc_organ_name(fates_plant_organs, fates_string_length) ; + fates_alloc_organ_name:units = "unitless - string" ; + fates_alloc_organ_name:long_name = "Name of plant organs (with alloc_organ_id, must match PRTGenericMod.F90)" ; + char fates_litterclass_name(fates_litterclass, fates_string_length) ; + fates_litterclass_name:units = "unitless - string" ; + fates_litterclass_name:long_name = "Name of the litter classes, for variables associated with dimension fates_litterclass" ; + double fates_alloc_organ_priority(fates_plant_organs, fates_pft) ; + fates_alloc_organ_priority:units = "index" ; + fates_alloc_organ_priority:long_name = "Priority level for allocation, 1: replaces turnover from storage, 2: same priority as storage use/replacement, 3: ascending in order of least importance" ; + double fates_alloc_storage_cushion(fates_pft) ; + fates_alloc_storage_cushion:units = "fraction" ; + fates_alloc_storage_cushion:long_name = "maximum size of storage C pool, relative to maximum size of leaf C pool" ; + double fates_alloc_store_priority_frac(fates_pft) ; + fates_alloc_store_priority_frac:units = "unitless" ; + fates_alloc_store_priority_frac:long_name = "for high-priority organs, the fraction of their turnover demand that is gauranteed to be replaced, and if need-be by storage" ; + double fates_allom_agb1(fates_pft) ; + fates_allom_agb1:units = "variable" ; + fates_allom_agb1:long_name = "Parameter 1 for agb allometry" ; + double fates_allom_agb2(fates_pft) ; + fates_allom_agb2:units = "variable" ; + fates_allom_agb2:long_name = "Parameter 2 for agb allometry" ; + double fates_allom_agb3(fates_pft) ; + fates_allom_agb3:units = "variable" ; + fates_allom_agb3:long_name = "Parameter 3 for agb allometry" ; + double fates_allom_agb4(fates_pft) ; + fates_allom_agb4:units = "variable" ; + fates_allom_agb4:long_name = "Parameter 4 for agb allometry" ; + double fates_allom_agb_frac(fates_pft) ; + fates_allom_agb_frac:units = "fraction" ; + fates_allom_agb_frac:long_name = "Fraction of woody biomass that is above ground" ; + double fates_allom_amode(fates_pft) ; + fates_allom_amode:units = "index" ; + fates_allom_amode:long_name = "AGB allometry function index." ; + double fates_allom_blca_expnt_diff(fates_pft) ; + fates_allom_blca_expnt_diff:units = "unitless" ; + fates_allom_blca_expnt_diff:long_name = "difference between allometric DBH:bleaf and DBH:crown area exponents" ; + double fates_allom_cmode(fates_pft) ; + fates_allom_cmode:units = "index" ; + fates_allom_cmode:long_name = "coarse root biomass allometry function index." ; + double fates_allom_crown_depth_frac(fates_pft) ; + fates_allom_crown_depth_frac:units = "fraction" ; + fates_allom_crown_depth_frac:long_name = "the depth of a cohort crown as a fraction of its height" ; + double fates_allom_d2bl1(fates_pft) ; + fates_allom_d2bl1:units = "variable" ; + fates_allom_d2bl1:long_name = "Parameter 1 for d2bl allometry" ; + double fates_allom_d2bl2(fates_pft) ; + fates_allom_d2bl2:units = "variable" ; + fates_allom_d2bl2:long_name = "Parameter 2 for d2bl allometry" ; + double fates_allom_d2bl3(fates_pft) ; + fates_allom_d2bl3:units = "unitless" ; + fates_allom_d2bl3:long_name = "Parameter 3 for d2bl allometry" ; + double fates_allom_d2ca_coefficient_max(fates_pft) ; + fates_allom_d2ca_coefficient_max:units = "m2 cm^(-1/beta)" ; + fates_allom_d2ca_coefficient_max:long_name = "max (savanna) dbh to area multiplier factor where: area = n*d2ca_coeff*dbh^beta" ; + double fates_allom_d2ca_coefficient_min(fates_pft) ; + fates_allom_d2ca_coefficient_min:units = "m2 cm^(-1/beta)" ; + fates_allom_d2ca_coefficient_min:long_name = "min (forest) dbh to area multiplier factor where: area = n*d2ca_coeff*dbh^beta" ; + double fates_allom_d2h1(fates_pft) ; + fates_allom_d2h1:units = "variable" ; + fates_allom_d2h1:long_name = "Parameter 1 for d2h allometry (intercept, or c)" ; + double fates_allom_d2h2(fates_pft) ; + fates_allom_d2h2:units = "variable" ; + fates_allom_d2h2:long_name = "Parameter 2 for d2h allometry (slope, or m)" ; + double fates_allom_d2h3(fates_pft) ; + fates_allom_d2h3:units = "variable" ; + fates_allom_d2h3:long_name = "Parameter 3 for d2h allometry (optional)" ; + double fates_allom_dbh_maxheight(fates_pft) ; + fates_allom_dbh_maxheight:units = "cm" ; + fates_allom_dbh_maxheight:long_name = "the diameter (if any) corresponding to maximum height, diameters may increase beyond this" ; + double fates_allom_fmode(fates_pft) ; + fates_allom_fmode:units = "index" ; + fates_allom_fmode:long_name = "fine root biomass allometry function index." ; + double fates_allom_fnrt_prof_a(fates_pft) ; + fates_allom_fnrt_prof_a:units = "unitless" ; + fates_allom_fnrt_prof_a:long_name = "Fine root profile function, parameter a" ; + double fates_allom_fnrt_prof_b(fates_pft) ; + fates_allom_fnrt_prof_b:units = "unitless" ; + fates_allom_fnrt_prof_b:long_name = "Fine root profile function, parameter b" ; + double fates_allom_fnrt_prof_mode(fates_pft) ; + fates_allom_fnrt_prof_mode:units = "index" ; + fates_allom_fnrt_prof_mode:long_name = "Index to select fine root profile function: 1) Jackson Beta, 2) 1-param exponential 3) 2-param exponential" ; + double fates_allom_frbstor_repro(fates_pft) ; + fates_allom_frbstor_repro:units = "fraction" ; + fates_allom_frbstor_repro:long_name = "fraction of bstore goes to reproduction after plant dies" ; + double fates_allom_hmode(fates_pft) ; + fates_allom_hmode:units = "index" ; + fates_allom_hmode:long_name = "height allometry function index." ; + double fates_allom_l2fr(fates_pft) ; + fates_allom_l2fr:units = "gC/gC" ; + fates_allom_l2fr:long_name = "Allocation parameter: fine root C per leaf C" ; + double fates_allom_la_per_sa_int(fates_pft) ; + fates_allom_la_per_sa_int:units = "m2/cm2" ; + fates_allom_la_per_sa_int:long_name = "Leaf area per sapwood area, intercept" ; + double fates_allom_la_per_sa_slp(fates_pft) ; + fates_allom_la_per_sa_slp:units = "m2/cm2/m" ; + fates_allom_la_per_sa_slp:long_name = "Leaf area per sapwood area rate of change with height, slope (optional)" ; + double fates_allom_lmode(fates_pft) ; + fates_allom_lmode:units = "index" ; + fates_allom_lmode:long_name = "leaf biomass allometry function index." ; + double fates_allom_sai_scaler(fates_pft) ; + fates_allom_sai_scaler:units = "m2/m2" ; + fates_allom_sai_scaler:long_name = "allometric ratio of SAI per LAI" ; + double fates_allom_smode(fates_pft) ; + fates_allom_smode:units = "index" ; + fates_allom_smode:long_name = "sapwood allometry function index." ; + double fates_allom_stmode(fates_pft) ; + fates_allom_stmode:units = "index" ; + fates_allom_stmode:long_name = "storage allometry function index: 1) Storage proportional to leaf biomass (with trimming), 2) Storage proportional to maximum leaf biomass (not trimmed)" ; + double fates_allom_zroot_k(fates_pft) ; + fates_allom_zroot_k:units = "unitless" ; + fates_allom_zroot_k:long_name = "scale coefficient of logistic rooting depth model" ; + double fates_allom_zroot_max_dbh(fates_pft) ; + fates_allom_zroot_max_dbh:units = "cm" ; + fates_allom_zroot_max_dbh:long_name = "dbh at which a plant reaches the maximum value for its maximum rooting depth" ; + double fates_allom_zroot_max_z(fates_pft) ; + fates_allom_zroot_max_z:units = "m" ; + fates_allom_zroot_max_z:long_name = "the maximum rooting depth defined at dbh = fates_allom_zroot_max_dbh. note: max_z=min_z=large, sets rooting depth to soil depth" ; + double fates_allom_zroot_min_dbh(fates_pft) ; + fates_allom_zroot_min_dbh:units = "cm" ; + fates_allom_zroot_min_dbh:long_name = "dbh at which the maximum rooting depth for a recruit is defined" ; + double fates_allom_zroot_min_z(fates_pft) ; + fates_allom_zroot_min_z:units = "m" ; + fates_allom_zroot_min_z:long_name = "the maximum rooting depth defined at dbh = fates_allom_zroot_min_dbh. note: max_z=min_z=large, sets rooting depth to soil depth" ; + double fates_c2b(fates_pft) ; + fates_c2b:units = "ratio" ; + fates_c2b:long_name = "Carbon to biomass multiplier of bulk structural tissues" ; + double fates_cnp_eca_alpha_ptase(fates_pft) ; + fates_cnp_eca_alpha_ptase:units = "g/m3" ; + fates_cnp_eca_alpha_ptase:long_name = "fraction of P from ptase activity sent directly to plant (ECA)" ; + double fates_cnp_eca_decompmicc(fates_pft) ; + fates_cnp_eca_decompmicc:units = "gC/m3" ; + fates_cnp_eca_decompmicc:long_name = "maximum soil microbial decomposer biomass found over depth (will be applied at a reference depth w/ exponential attenuation) (ECA)" ; + double fates_cnp_eca_km_nh4(fates_pft) ; + fates_cnp_eca_km_nh4:units = "gN/m3" ; + fates_cnp_eca_km_nh4:long_name = "half-saturation constant for plant nh4 uptake (ECA)" ; + double fates_cnp_eca_km_no3(fates_pft) ; + fates_cnp_eca_km_no3:units = "gN/m3" ; + fates_cnp_eca_km_no3:long_name = "half-saturation constant for plant no3 uptake (ECA)" ; + double fates_cnp_eca_km_p(fates_pft) ; + fates_cnp_eca_km_p:units = "gP/m3" ; + fates_cnp_eca_km_p:long_name = "half-saturation constant for plant p uptake (ECA)" ; + double fates_cnp_eca_km_ptase(fates_pft) ; + fates_cnp_eca_km_ptase:units = "gP/m3" ; + fates_cnp_eca_km_ptase:long_name = "half-saturation constant for biochemical P (ECA)" ; + double fates_cnp_eca_lambda_ptase(fates_pft) ; + fates_cnp_eca_lambda_ptase:units = "g/m3" ; + fates_cnp_eca_lambda_ptase:long_name = "critical value for biochemical production (ECA)" ; + double fates_cnp_eca_vmax_ptase(fates_pft) ; + fates_cnp_eca_vmax_ptase:units = "gP/m2/s" ; + fates_cnp_eca_vmax_ptase:long_name = "maximum production rate for biochemical P (per m2) (ECA)" ; + double fates_cnp_nfix1(fates_pft) ; + fates_cnp_nfix1:units = "fraction" ; + fates_cnp_nfix1:long_name = "fractional surcharge added to maintenance respiration that drives symbiotic fixation" ; + double fates_cnp_nitr_store_ratio(fates_pft) ; + fates_cnp_nitr_store_ratio:units = "(gN/gN)" ; + fates_cnp_nitr_store_ratio:long_name = "storeable (labile) N, as a ratio compared to the N bound in cell structures of other organs (see code)" ; + double fates_cnp_phos_store_ratio(fates_pft) ; + fates_cnp_phos_store_ratio:units = "(gP/gP)" ; + fates_cnp_phos_store_ratio:long_name = "storeable (labile) P, as a ratio compared to the P bound in cell structures of other organs (see code)" ; + double fates_cnp_pid_kd(fates_pft) ; + fates_cnp_pid_kd:units = "unknown" ; + fates_cnp_pid_kd:long_name = "derivative constant of the PID controller on adaptive fine-root biomass" ; + double fates_cnp_pid_ki(fates_pft) ; + fates_cnp_pid_ki:units = "unknown" ; + fates_cnp_pid_ki:long_name = "integral constant of the PID controller on adaptive fine-root biomass" ; + double fates_cnp_pid_kp(fates_pft) ; + fates_cnp_pid_kp:units = "unknown" ; + fates_cnp_pid_kp:long_name = "proportional constant of the PID controller on adaptive fine-root biomass" ; + double fates_cnp_prescribed_nuptake(fates_pft) ; + fates_cnp_prescribed_nuptake:units = "fraction" ; + fates_cnp_prescribed_nuptake:long_name = "Prescribed N uptake flux. 0=fully coupled simulation >0=prescribed (experimental)" ; + double fates_cnp_prescribed_puptake(fates_pft) ; + fates_cnp_prescribed_puptake:units = "fraction" ; + fates_cnp_prescribed_puptake:long_name = "Prescribed P uptake flux. 0=fully coupled simulation, >0=prescribed (experimental)" ; + double fates_cnp_store_ovrflw_frac(fates_pft) ; + fates_cnp_store_ovrflw_frac:units = "fraction" ; + fates_cnp_store_ovrflw_frac:long_name = "size of overflow storage (for excess C,N or P) as a fraction of storage target" ; + double fates_cnp_turnover_nitr_retrans(fates_plant_organs, fates_pft) ; + fates_cnp_turnover_nitr_retrans:units = "fraction" ; + fates_cnp_turnover_nitr_retrans:long_name = "retranslocation (reabsorbtion) fraction of nitrogen in turnover of scenescing tissues" ; + double fates_cnp_turnover_phos_retrans(fates_plant_organs, fates_pft) ; + fates_cnp_turnover_phos_retrans:units = "fraction" ; + fates_cnp_turnover_phos_retrans:long_name = "retranslocation (reabsorbtion) fraction of phosphorus in turnover of scenescing tissues" ; + double fates_cnp_vmax_nh4(fates_pft) ; + fates_cnp_vmax_nh4:units = "gN/gC/s" ; + fates_cnp_vmax_nh4:long_name = "maximum (potential) uptake rate of NH4 per gC of fineroot biomass (see main/EDPftvarcon.F90 vmax_nh4 for usage)" ; + double fates_cnp_vmax_no3(fates_pft) ; + fates_cnp_vmax_no3:units = "gN/gC/s" ; + fates_cnp_vmax_no3:long_name = "maximum (potential) uptake rate of NO3 per gC of fineroot biomass (see main/EDPftvarcon.F90 vmax_no3 for usage)" ; + double fates_cnp_vmax_p(fates_pft) ; + fates_cnp_vmax_p:units = "gP/gC/s" ; + fates_cnp_vmax_p:long_name = "maximum production rate for phosphorus (ECA and RD)" ; + double fates_damage_frac(fates_pft) ; + fates_damage_frac:units = "fraction" ; + fates_damage_frac:long_name = "fraction of cohort damaged in each damage event (event frequency specified in the is_it_damage_time subroutine)" ; + double fates_damage_mort_p1(fates_pft) ; + fates_damage_mort_p1:units = "fraction" ; + fates_damage_mort_p1:long_name = "inflection point of damage mortality function, a value of 0.8 means 50% mortality with 80% loss of crown, turn off with a large number" ; + double fates_damage_mort_p2(fates_pft) ; + fates_damage_mort_p2:units = "unitless" ; + fates_damage_mort_p2:long_name = "rate of mortality increase with damage" ; + double fates_damage_recovery_scalar(fates_pft) ; + fates_damage_recovery_scalar:units = "unitless" ; + fates_damage_recovery_scalar:long_name = "fraction of the cohort that recovers from damage" ; + double fates_dev_arbitrary_pft(fates_pft) ; + fates_dev_arbitrary_pft:units = "unknown" ; + fates_dev_arbitrary_pft:long_name = "Unassociated pft dimensioned free parameter that developers can use for testing arbitrary new hypotheses" ; + double fates_fire_alpha_SH(fates_pft) ; + fates_fire_alpha_SH:units = "m / (kw/m)**(2/3)" ; + fates_fire_alpha_SH:long_name = "spitfire parameter, alpha scorch height, Equation 16 Thonicke et al 2010" ; + double fates_fire_bark_scaler(fates_pft) ; + fates_fire_bark_scaler:units = "fraction" ; + fates_fire_bark_scaler:long_name = "the thickness of a cohorts bark as a fraction of its dbh" ; + double fates_fire_crown_kill(fates_pft) ; + fates_fire_crown_kill:units = "NA" ; + fates_fire_crown_kill:long_name = "fire parameter, see equation 22 in Thonicke et al 2010" ; + double fates_frag_fnrt_fcel(fates_pft) ; + fates_frag_fnrt_fcel:units = "fraction" ; + fates_frag_fnrt_fcel:long_name = "Fine root litter cellulose fraction" ; + double fates_frag_fnrt_flab(fates_pft) ; + fates_frag_fnrt_flab:units = "fraction" ; + fates_frag_fnrt_flab:long_name = "Fine root litter labile fraction" ; + double fates_frag_fnrt_flig(fates_pft) ; + fates_frag_fnrt_flig:units = "fraction" ; + fates_frag_fnrt_flig:long_name = "Fine root litter lignin fraction" ; + double fates_frag_leaf_fcel(fates_pft) ; + fates_frag_leaf_fcel:units = "fraction" ; + fates_frag_leaf_fcel:long_name = "Leaf litter cellulose fraction" ; + double fates_frag_leaf_flab(fates_pft) ; + fates_frag_leaf_flab:units = "fraction" ; + fates_frag_leaf_flab:long_name = "Leaf litter labile fraction" ; + double fates_frag_leaf_flig(fates_pft) ; + fates_frag_leaf_flig:units = "fraction" ; + fates_frag_leaf_flig:long_name = "Leaf litter lignin fraction" ; + double fates_frag_seed_decay_rate(fates_pft) ; + fates_frag_seed_decay_rate:units = "yr-1" ; + fates_frag_seed_decay_rate:long_name = "fraction of seeds that decay per year" ; + double fates_grperc(fates_pft) ; + fates_grperc:units = "unitless" ; + fates_grperc:long_name = "Growth respiration factor" ; + double fates_hydro_avuln_gs(fates_pft) ; + fates_hydro_avuln_gs:units = "unitless" ; + fates_hydro_avuln_gs:long_name = "shape parameter for stomatal control of water vapor exiting leaf" ; + double fates_hydro_avuln_node(fates_hydr_organs, fates_pft) ; + fates_hydro_avuln_node:units = "unitless" ; + fates_hydro_avuln_node:long_name = "xylem vulnerability curve shape parameter" ; + double fates_hydro_epsil_node(fates_hydr_organs, fates_pft) ; + fates_hydro_epsil_node:units = "MPa" ; + fates_hydro_epsil_node:long_name = "bulk elastic modulus" ; + double fates_hydro_fcap_node(fates_hydr_organs, fates_pft) ; + fates_hydro_fcap_node:units = "unitless" ; + fates_hydro_fcap_node:long_name = "fraction of non-residual water that is capillary in source" ; + double fates_hydro_k_lwp(fates_pft) ; + fates_hydro_k_lwp:units = "unitless" ; + fates_hydro_k_lwp:long_name = "inner leaf humidity scaling coefficient" ; + double fates_hydro_kmax_node(fates_hydr_organs, fates_pft) ; + fates_hydro_kmax_node:units = "kg/MPa/m/s" ; + fates_hydro_kmax_node:long_name = "maximum xylem conductivity per unit conducting xylem area" ; + double fates_hydro_p50_gs(fates_pft) ; + fates_hydro_p50_gs:units = "MPa" ; + fates_hydro_p50_gs:long_name = "water potential at 50% loss of stomatal conductance" ; + double fates_hydro_p50_node(fates_hydr_organs, fates_pft) ; + fates_hydro_p50_node:units = "MPa" ; + fates_hydro_p50_node:long_name = "xylem water potential at 50% loss of conductivity" ; + double fates_hydro_p_taper(fates_pft) ; + fates_hydro_p_taper:units = "unitless" ; + fates_hydro_p_taper:long_name = "xylem taper exponent" ; + double fates_hydro_pinot_node(fates_hydr_organs, fates_pft) ; + fates_hydro_pinot_node:units = "MPa" ; + fates_hydro_pinot_node:long_name = "osmotic potential at full turgor" ; + double fates_hydro_pitlp_node(fates_hydr_organs, fates_pft) ; + fates_hydro_pitlp_node:units = "MPa" ; + fates_hydro_pitlp_node:long_name = "turgor loss point" ; + double fates_hydro_resid_node(fates_hydr_organs, fates_pft) ; + fates_hydro_resid_node:units = "cm3/cm3" ; + fates_hydro_resid_node:long_name = "residual water conent" ; + double fates_hydro_rfrac_stem(fates_pft) ; + fates_hydro_rfrac_stem:units = "fraction" ; + fates_hydro_rfrac_stem:long_name = "fraction of total tree resistance from troot to canopy" ; + double fates_hydro_rs2(fates_pft) ; + fates_hydro_rs2:units = "m" ; + fates_hydro_rs2:long_name = "absorbing root radius" ; + double fates_hydro_srl(fates_pft) ; + fates_hydro_srl:units = "m g-1" ; + fates_hydro_srl:long_name = "specific root length" ; + double fates_hydro_thetas_node(fates_hydr_organs, fates_pft) ; + fates_hydro_thetas_node:units = "cm3/cm3" ; + fates_hydro_thetas_node:long_name = "saturated water content" ; + double fates_hydro_vg_alpha_node(fates_hydr_organs, fates_pft) ; + fates_hydro_vg_alpha_node:units = "MPa-1" ; + fates_hydro_vg_alpha_node:long_name = "(used if hydr_htftype_node = 2), capillary length parameter in van Genuchten model" ; + double fates_hydro_vg_m_node(fates_hydr_organs, fates_pft) ; + fates_hydro_vg_m_node:units = "unitless" ; + fates_hydro_vg_m_node:long_name = "(used if hydr_htftype_node = 2),m in van Genuchten 1980 model, 2nd pore size distribution parameter" ; + double fates_hydro_vg_n_node(fates_hydr_organs, fates_pft) ; + fates_hydro_vg_n_node:units = "unitless" ; + fates_hydro_vg_n_node:long_name = "(used if hydr_htftype_node = 2),n in van Genuchten 1980 model, pore size distribution parameter" ; + double fates_leaf_c3psn(fates_pft) ; + fates_leaf_c3psn:units = "flag" ; + fates_leaf_c3psn:long_name = "Photosynthetic pathway (1=c3, 0=c4)" ; + double fates_leaf_jmaxha(fates_pft) ; + fates_leaf_jmaxha:units = "J/mol" ; + fates_leaf_jmaxha:long_name = "activation energy for jmax. NOTE: if fates_leaf_photo_tempsens_model=2 then these values are NOT USED" ; + double fates_leaf_jmaxhd(fates_pft) ; + fates_leaf_jmaxhd:units = "J/mol" ; + fates_leaf_jmaxhd:long_name = "deactivation energy for jmax. NOTE: if fates_leaf_photo_tempsens_model=2 then these values are NOT USED" ; + double fates_leaf_jmaxse(fates_pft) ; + fates_leaf_jmaxse:units = "J/mol/K" ; + fates_leaf_jmaxse:long_name = "entropy term for jmax. NOTE: if fates_leaf_photo_tempsens_model=2 then these values are NOT USED" ; + double fates_leaf_slamax(fates_pft) ; + fates_leaf_slamax:units = "m^2/gC" ; + fates_leaf_slamax:long_name = "Maximum Specific Leaf Area (SLA), even if under a dense canopy" ; + double fates_leaf_slatop(fates_pft) ; + fates_leaf_slatop:units = "m^2/gC" ; + fates_leaf_slatop:long_name = "Specific Leaf Area (SLA) at top of canopy, projected area basis" ; + double fates_leaf_stomatal_intercept(fates_pft) ; + fates_leaf_stomatal_intercept:units = "umol H2O/m**2/s" ; + fates_leaf_stomatal_intercept:long_name = "Minimum unstressed stomatal conductance for Ball-Berry model and Medlyn model" ; + double fates_leaf_stomatal_slope_ballberry(fates_pft) ; + fates_leaf_stomatal_slope_ballberry:units = "unitless" ; + fates_leaf_stomatal_slope_ballberry:long_name = "stomatal slope parameter, as per Ball-Berry" ; + double fates_leaf_stomatal_slope_medlyn(fates_pft) ; + fates_leaf_stomatal_slope_medlyn:units = "KPa**0.5" ; + fates_leaf_stomatal_slope_medlyn:long_name = "stomatal slope parameter, as per Medlyn" ; + double fates_leaf_vcmax25top(fates_leafage_class, fates_pft) ; + fates_leaf_vcmax25top:units = "umol CO2/m^2/s" ; + fates_leaf_vcmax25top:long_name = "maximum carboxylation rate of Rub. at 25C, canopy top" ; + double fates_leaf_vcmaxha(fates_pft) ; + fates_leaf_vcmaxha:units = "J/mol" ; + fates_leaf_vcmaxha:long_name = "activation energy for vcmax. NOTE: if fates_leaf_photo_tempsens_model=2 then these values are NOT USED" ; + double fates_leaf_vcmaxhd(fates_pft) ; + fates_leaf_vcmaxhd:units = "J/mol" ; + fates_leaf_vcmaxhd:long_name = "deactivation energy for vcmax. NOTE: if fates_leaf_photo_tempsens_model=2 then these values are NOT USED" ; + double fates_leaf_vcmaxse(fates_pft) ; + fates_leaf_vcmaxse:units = "J/mol/K" ; + fates_leaf_vcmaxse:long_name = "entropy term for vcmax. NOTE: if fates_leaf_photo_tempsens_model=2 then these values are NOT USED" ; + double fates_maintresp_leaf_atkin2017_baserate(fates_pft) ; + fates_maintresp_leaf_atkin2017_baserate:units = "umol CO2/m^2/s" ; + fates_maintresp_leaf_atkin2017_baserate:long_name = "Leaf maintenance respiration base rate parameter (r0) per Atkin et al 2017" ; + double fates_maintresp_leaf_ryan1991_baserate(fates_pft) ; + fates_maintresp_leaf_ryan1991_baserate:units = "gC/gN/s" ; + fates_maintresp_leaf_ryan1991_baserate:long_name = "Leaf maintenance respiration base rate per Ryan et al 1991" ; + double fates_maintresp_reduction_curvature(fates_pft) ; + fates_maintresp_reduction_curvature:units = "unitless (0-1)" ; + fates_maintresp_reduction_curvature:long_name = "curvature of MR reduction as f(carbon storage), 1=linear, 0=very curved" ; + double fates_maintresp_reduction_intercept(fates_pft) ; + fates_maintresp_reduction_intercept:units = "unitless (0-1)" ; + fates_maintresp_reduction_intercept:long_name = "intercept of MR reduction as f(carbon storage), 0=no throttling, 1=max throttling" ; + double fates_mort_bmort(fates_pft) ; + fates_mort_bmort:units = "1/yr" ; + fates_mort_bmort:long_name = "background mortality rate" ; + double fates_mort_freezetol(fates_pft) ; + fates_mort_freezetol:units = "degrees C" ; + fates_mort_freezetol:long_name = "minimum temperature tolerance" ; + double fates_mort_hf_flc_threshold(fates_pft) ; + fates_mort_hf_flc_threshold:units = "fraction" ; + fates_mort_hf_flc_threshold:long_name = "plant fractional loss of conductivity at which drought mortality begins for hydraulic model" ; + double fates_mort_hf_sm_threshold(fates_pft) ; + fates_mort_hf_sm_threshold:units = "unitless" ; + fates_mort_hf_sm_threshold:long_name = "soil moisture (btran units) at which drought mortality begins for non-hydraulic model" ; + double fates_mort_ip_age_senescence(fates_pft) ; + fates_mort_ip_age_senescence:units = "years" ; + fates_mort_ip_age_senescence:long_name = "Mortality cohort age senescence inflection point. If _ this mortality term is off. Setting this value turns on age dependent mortality. " ; + double fates_mort_ip_size_senescence(fates_pft) ; + fates_mort_ip_size_senescence:units = "dbh cm" ; + fates_mort_ip_size_senescence:long_name = "Mortality dbh senescence inflection point. If _ this mortality term is off. Setting this value turns on size dependent mortality" ; + double fates_mort_prescribed_canopy(fates_pft) ; + fates_mort_prescribed_canopy:units = "1/yr" ; + fates_mort_prescribed_canopy:long_name = "mortality rate of canopy trees for prescribed physiology mode" ; + double fates_mort_prescribed_understory(fates_pft) ; + fates_mort_prescribed_understory:units = "1/yr" ; + fates_mort_prescribed_understory:long_name = "mortality rate of understory trees for prescribed physiology mode" ; + double fates_mort_r_age_senescence(fates_pft) ; + fates_mort_r_age_senescence:units = "mortality rate year^-1" ; + fates_mort_r_age_senescence:long_name = "Mortality age senescence rate of change. Sensible range is around 0.03-0.06. Larger values givesteeper mortality curves." ; + double fates_mort_r_size_senescence(fates_pft) ; + fates_mort_r_size_senescence:units = "mortality rate dbh^-1" ; + fates_mort_r_size_senescence:long_name = "Mortality dbh senescence rate of change. Sensible range is around 0.03-0.06. Larger values give steeper mortality curves." ; + double fates_mort_scalar_coldstress(fates_pft) ; + fates_mort_scalar_coldstress:units = "1/yr" ; + fates_mort_scalar_coldstress:long_name = "maximum mortality rate from cold stress" ; + double fates_mort_scalar_cstarvation(fates_pft) ; + fates_mort_scalar_cstarvation:units = "1/yr" ; + fates_mort_scalar_cstarvation:long_name = "maximum mortality rate from carbon starvation" ; + double fates_mort_scalar_hydrfailure(fates_pft) ; + fates_mort_scalar_hydrfailure:units = "1/yr" ; + fates_mort_scalar_hydrfailure:long_name = "maximum mortality rate from hydraulic failure" ; + double fates_nonhydro_smpsc(fates_pft) ; + fates_nonhydro_smpsc:units = "mm" ; + fates_nonhydro_smpsc:long_name = "Soil water potential at full stomatal closure" ; + double fates_nonhydro_smpso(fates_pft) ; + fates_nonhydro_smpso:units = "mm" ; + fates_nonhydro_smpso:long_name = "Soil water potential at full stomatal opening" ; + double fates_phen_cold_size_threshold(fates_pft) ; + fates_phen_cold_size_threshold:units = "cm" ; + fates_phen_cold_size_threshold:long_name = "the dbh size above which will lead to phenology-related stem and leaf drop" ; + double fates_phen_evergreen(fates_pft) ; + fates_phen_evergreen:units = "logical flag" ; + fates_phen_evergreen:long_name = "Binary flag for evergreen leaf habit" ; + double fates_phen_flush_fraction(fates_pft) ; + fates_phen_flush_fraction:units = "fraction" ; + fates_phen_flush_fraction:long_name = "Upon bud-burst, the maximum fraction of storage carbon used for flushing leaves" ; + double fates_phen_fnrt_drop_frac(fates_pft) ; + fates_phen_fnrt_drop_frac:units = "fraction" ; + fates_phen_fnrt_drop_frac:long_name = "fraction of fine roots to drop during drought or cold" ; + double fates_phen_season_decid(fates_pft) ; + fates_phen_season_decid:units = "logical flag" ; + fates_phen_season_decid:long_name = "Binary flag for seasonal-deciduous leaf habit" ; + double fates_phen_stem_drop_fraction(fates_pft) ; + fates_phen_stem_drop_fraction:units = "fraction" ; + fates_phen_stem_drop_fraction:long_name = "fraction of stems to drop for non-woody species during drought/cold" ; + double fates_phen_stress_decid(fates_pft) ; + fates_phen_stress_decid:units = "logical flag" ; + fates_phen_stress_decid:long_name = "Binary flag for stress-deciduous leaf habit" ; + double fates_prescribed_npp_canopy(fates_pft) ; + fates_prescribed_npp_canopy:units = "kgC / m^2 / yr" ; + fates_prescribed_npp_canopy:long_name = "NPP per unit crown area of canopy trees for prescribed physiology mode" ; + double fates_prescribed_npp_understory(fates_pft) ; + fates_prescribed_npp_understory:units = "kgC / m^2 / yr" ; + fates_prescribed_npp_understory:long_name = "NPP per unit crown area of understory trees for prescribed physiology mode" ; + double fates_rad_leaf_clumping_index(fates_pft) ; + fates_rad_leaf_clumping_index:units = "fraction (0-1)" ; + fates_rad_leaf_clumping_index:long_name = "factor describing how much self-occlusion of leaf scattering elements decreases light interception" ; + double fates_rad_leaf_rhonir(fates_pft) ; + fates_rad_leaf_rhonir:units = "fraction" ; + fates_rad_leaf_rhonir:long_name = "Leaf reflectance: near-IR" ; + double fates_rad_leaf_rhovis(fates_pft) ; + fates_rad_leaf_rhovis:units = "fraction" ; + fates_rad_leaf_rhovis:long_name = "Leaf reflectance: visible" ; + double fates_rad_leaf_taunir(fates_pft) ; + fates_rad_leaf_taunir:units = "fraction" ; + fates_rad_leaf_taunir:long_name = "Leaf transmittance: near-IR" ; + double fates_rad_leaf_tauvis(fates_pft) ; + fates_rad_leaf_tauvis:units = "fraction" ; + fates_rad_leaf_tauvis:long_name = "Leaf transmittance: visible" ; + double fates_rad_leaf_xl(fates_pft) ; + fates_rad_leaf_xl:units = "unitless" ; + fates_rad_leaf_xl:long_name = "Leaf/stem orientation index" ; + double fates_rad_stem_rhonir(fates_pft) ; + fates_rad_stem_rhonir:units = "fraction" ; + fates_rad_stem_rhonir:long_name = "Stem reflectance: near-IR" ; + double fates_rad_stem_rhovis(fates_pft) ; + fates_rad_stem_rhovis:units = "fraction" ; + fates_rad_stem_rhovis:long_name = "Stem reflectance: visible" ; + double fates_rad_stem_taunir(fates_pft) ; + fates_rad_stem_taunir:units = "fraction" ; + fates_rad_stem_taunir:long_name = "Stem transmittance: near-IR" ; + double fates_rad_stem_tauvis(fates_pft) ; + fates_rad_stem_tauvis:units = "fraction" ; + fates_rad_stem_tauvis:long_name = "Stem transmittance: visible" ; + double fates_recruit_height_min(fates_pft) ; + fates_recruit_height_min:units = "m" ; + fates_recruit_height_min:long_name = "the minimum height (ie starting height) of a newly recruited plant" ; + double fates_recruit_init_density(fates_pft) ; + fates_recruit_init_density:units = "stems/m2" ; + fates_recruit_init_density:long_name = "initial seedling density for a cold-start near-bare-ground simulation. If negative sets initial tree dbh - only to be used in nocomp mode" ; + double fates_recruit_prescribed_rate(fates_pft) ; + fates_recruit_prescribed_rate:units = "n/yr" ; + fates_recruit_prescribed_rate:long_name = "recruitment rate for prescribed physiology mode" ; + double fates_recruit_seed_alloc(fates_pft) ; + fates_recruit_seed_alloc:units = "fraction" ; + fates_recruit_seed_alloc:long_name = "fraction of available carbon balance allocated to seeds" ; + double fates_recruit_seed_alloc_mature(fates_pft) ; + fates_recruit_seed_alloc_mature:units = "fraction" ; + fates_recruit_seed_alloc_mature:long_name = "fraction of available carbon balance allocated to seeds in mature plants (adds to fates_seed_alloc)" ; + double fates_recruit_seed_dbh_repro_threshold(fates_pft) ; + fates_recruit_seed_dbh_repro_threshold:units = "cm" ; + fates_recruit_seed_dbh_repro_threshold:long_name = "the diameter where the plant will increase allocation to the seed pool by fraction: fates_recruit_seed_alloc_mature" ; + double fates_recruit_seed_germination_rate(fates_pft) ; + fates_recruit_seed_germination_rate:units = "yr-1" ; + fates_recruit_seed_germination_rate:long_name = "fraction of seeds that germinate per year" ; + double fates_recruit_seed_supplement(fates_pft) ; + fates_recruit_seed_supplement:units = "KgC/m2/yr" ; + fates_recruit_seed_supplement:long_name = "Supplemental external seed rain source term (non-mass conserving)" ; + double fates_stoich_nitr(fates_plant_organs, fates_pft) ; + fates_stoich_nitr:units = "gN/gC" ; + fates_stoich_nitr:long_name = "target nitrogen concentration (ratio with carbon) of organs" ; + double fates_stoich_phos(fates_plant_organs, fates_pft) ; + fates_stoich_phos:units = "gP/gC" ; + fates_stoich_phos:long_name = "target phosphorus concentration (ratio with carbon) of organs" ; + double fates_trim_inc(fates_pft) ; + fates_trim_inc:units = "m2/m2" ; + fates_trim_inc:long_name = "Arbitrary incremental change in trimming function." ; + double fates_trim_limit(fates_pft) ; + fates_trim_limit:units = "m2/m2" ; + fates_trim_limit:long_name = "Arbitrary limit to reductions in leaf area with stress" ; + double fates_turb_displar(fates_pft) ; + fates_turb_displar:units = "unitless" ; + fates_turb_displar:long_name = "Ratio of displacement height to canopy top height" ; + double fates_turb_leaf_diameter(fates_pft) ; + fates_turb_leaf_diameter:units = "m" ; + fates_turb_leaf_diameter:long_name = "Characteristic leaf dimension" ; + double fates_turb_z0mr(fates_pft) ; + fates_turb_z0mr:units = "unitless" ; + fates_turb_z0mr:long_name = "Ratio of momentum roughness length to canopy top height" ; + double fates_turnover_branch(fates_pft) ; + fates_turnover_branch:units = "yr" ; + fates_turnover_branch:long_name = "turnover time of branches" ; + double fates_turnover_fnrt(fates_pft) ; + fates_turnover_fnrt:units = "yr" ; + fates_turnover_fnrt:long_name = "root longevity (alternatively, turnover time)" ; + double fates_turnover_leaf(fates_leafage_class, fates_pft) ; + fates_turnover_leaf:units = "yr" ; + fates_turnover_leaf:long_name = "Leaf longevity (ie turnover timescale)" ; + double fates_turnover_senleaf_fdrought(fates_pft) ; + fates_turnover_senleaf_fdrought:units = "unitless[0-1]" ; + fates_turnover_senleaf_fdrought:long_name = "multiplication factor for leaf longevity of senescent leaves during drought" ; + double fates_wood_density(fates_pft) ; + fates_wood_density:units = "g/cm3" ; + fates_wood_density:long_name = "mean density of woody tissue in plant" ; + double fates_woody(fates_pft) ; + fates_woody:units = "logical flag" ; + fates_woody:long_name = "Binary woody lifeform flag" ; + double fates_hlm_pft_map(fates_hlm_pftno, fates_pft) ; + fates_hlm_pft_map:units = "area fraction" ; + fates_hlm_pft_map:long_name = "In fixed biogeog mode, fraction of HLM area associated with each FATES PFT" ; + double fates_fire_FBD(fates_litterclass) ; + fates_fire_FBD:units = "kg Biomass/m3" ; + fates_fire_FBD:long_name = "fuel bulk density" ; + double fates_fire_low_moisture_Coeff(fates_litterclass) ; + fates_fire_low_moisture_Coeff:units = "NA" ; + fates_fire_low_moisture_Coeff:long_name = "spitfire parameter, equation B1 Thonicke et al 2010" ; + double fates_fire_low_moisture_Slope(fates_litterclass) ; + fates_fire_low_moisture_Slope:units = "NA" ; + fates_fire_low_moisture_Slope:long_name = "spitfire parameter, equation B1 Thonicke et al 2010" ; + double fates_fire_mid_moisture(fates_litterclass) ; + fates_fire_mid_moisture:units = "NA" ; + fates_fire_mid_moisture:long_name = "spitfire litter moisture threshold to be considered medium dry" ; + double fates_fire_mid_moisture_Coeff(fates_litterclass) ; + fates_fire_mid_moisture_Coeff:units = "NA" ; + fates_fire_mid_moisture_Coeff:long_name = "spitfire parameter, equation B1 Thonicke et al 2010" ; + double fates_fire_mid_moisture_Slope(fates_litterclass) ; + fates_fire_mid_moisture_Slope:units = "NA" ; + fates_fire_mid_moisture_Slope:long_name = "spitfire parameter, equation B1 Thonicke et al 2010" ; + double fates_fire_min_moisture(fates_litterclass) ; + fates_fire_min_moisture:units = "NA" ; + fates_fire_min_moisture:long_name = "spitfire litter moisture threshold to be considered very dry" ; + double fates_fire_SAV(fates_litterclass) ; + fates_fire_SAV:units = "cm-1" ; + fates_fire_SAV:long_name = "fuel surface area to volume ratio" ; + double fates_frag_maxdecomp(fates_litterclass) ; + fates_frag_maxdecomp:units = "yr-1" ; + fates_frag_maxdecomp:long_name = "maximum rate of litter & CWD transfer from non-decomposing class into decomposing class" ; + double fates_frag_cwd_frac(fates_NCWD) ; + fates_frag_cwd_frac:units = "fraction" ; + fates_frag_cwd_frac:long_name = "fraction of woody (bdead+bsw) biomass destined for CWD pool" ; + double fates_canopy_closure_thresh ; + fates_canopy_closure_thresh:units = "unitless" ; + fates_canopy_closure_thresh:long_name = "tree canopy coverage at which crown area allometry changes from savanna to forest value" ; + double fates_cnp_eca_plant_escalar ; + fates_cnp_eca_plant_escalar:units = "" ; + fates_cnp_eca_plant_escalar:long_name = "scaling factor for plant fine root biomass to calculate nutrient carrier enzyme abundance (ECA)" ; + double fates_cohort_age_fusion_tol ; + fates_cohort_age_fusion_tol:units = "unitless" ; + fates_cohort_age_fusion_tol:long_name = "minimum fraction in differece in cohort age between cohorts." ; + double fates_cohort_size_fusion_tol ; + fates_cohort_size_fusion_tol:units = "unitless" ; + fates_cohort_size_fusion_tol:long_name = "minimum fraction in difference in dbh between cohorts" ; + double fates_comp_excln ; + fates_comp_excln:units = "none" ; + fates_comp_excln:long_name = "IF POSITIVE: weighting factor (exponent on dbh) for canopy layer exclusion and promotion, IF NEGATIVE: switch to use deterministic height sorting" ; + double fates_damage_canopy_layer_code ; + fates_damage_canopy_layer_code:units = "unitless" ; + fates_damage_canopy_layer_code:long_name = "Integer code that decides whether damage affects canopy trees (1), understory trees (2)" ; + double fates_damage_event_code ; + fates_damage_event_code:units = "unitless" ; + fates_damage_event_code:long_name = "Integer code that options how damage events are structured" ; + double fates_dev_arbitrary ; + fates_dev_arbitrary:units = "unknown" ; + fates_dev_arbitrary:long_name = "Unassociated free parameter that developers can use for testing arbitrary new hypotheses" ; + double fates_fire_active_crown_fire ; + fates_fire_active_crown_fire:units = "0 or 1" ; + fates_fire_active_crown_fire:long_name = "flag, 1=active crown fire 0=no active crown fire" ; + double fates_fire_cg_strikes ; + fates_fire_cg_strikes:units = "fraction (0-1)" ; + fates_fire_cg_strikes:long_name = "fraction of cloud to ground lightning strikes" ; + double fates_fire_drying_ratio ; + fates_fire_drying_ratio:units = "NA" ; + fates_fire_drying_ratio:long_name = "spitfire parameter, fire drying ratio for fuel moisture, alpha_FMC EQ 6 Thonicke et al 2010" ; + double fates_fire_durat_slope ; + fates_fire_durat_slope:units = "NA" ; + fates_fire_durat_slope:long_name = "spitfire parameter, fire max duration slope, Equation 14 Thonicke et al 2010" ; + double fates_fire_fdi_a ; + fates_fire_fdi_a:units = "NA" ; + fates_fire_fdi_a:long_name = "spitfire parameter, fire danger index, EQ 5 Thonicke et al 2010" ; + double fates_fire_fdi_alpha ; + fates_fire_fdi_alpha:units = "NA" ; + fates_fire_fdi_alpha:long_name = "spitfire parameter, EQ 7 Venevsky et al. GCB 2002,(modified EQ 8 Thonicke et al. 2010) " ; + double fates_fire_fdi_b ; + fates_fire_fdi_b:units = "NA" ; + fates_fire_fdi_b:long_name = "spitfire parameter, fire danger index, EQ 5 Thonicke et al 2010 " ; + double fates_fire_fuel_energy ; + fates_fire_fuel_energy:units = "kJ/kg" ; + fates_fire_fuel_energy:long_name = "spitfire parameter, heat content of fuel" ; + double fates_fire_max_durat ; + fates_fire_max_durat:units = "minutes" ; + fates_fire_max_durat:long_name = "spitfire parameter, fire maximum duration, Equation 14 Thonicke et al 2010" ; + double fates_fire_miner_damp ; + fates_fire_miner_damp:units = "NA" ; + fates_fire_miner_damp:long_name = "spitfire parameter, mineral-dampening coefficient EQ A1 Thonicke et al 2010 " ; + double fates_fire_miner_total ; + fates_fire_miner_total:units = "fraction" ; + fates_fire_miner_total:long_name = "spitfire parameter, total mineral content, Table A1 Thonicke et al 2010" ; + double fates_fire_nignitions ; + fates_fire_nignitions:units = "ignitions per year per km2" ; + fates_fire_nignitions:long_name = "number of annual ignitions per square km" ; + double fates_fire_part_dens ; + fates_fire_part_dens:units = "kg/m2" ; + fates_fire_part_dens:long_name = "spitfire parameter, oven dry particle density, Table A1 Thonicke et al 2010" ; + double fates_fire_threshold ; + fates_fire_threshold:units = "kW/m" ; + fates_fire_threshold:long_name = "spitfire parameter, fire intensity threshold for tracking fires that spread" ; + double fates_frag_cwd_fcel ; + fates_frag_cwd_fcel:units = "unitless" ; + fates_frag_cwd_fcel:long_name = "Cellulose fraction for CWD" ; + double fates_frag_cwd_flig ; + fates_frag_cwd_flig:units = "unitless" ; + fates_frag_cwd_flig:long_name = "Lignin fraction of coarse woody debris" ; + double fates_hydro_kmax_rsurf1 ; + fates_hydro_kmax_rsurf1:units = "kg water/m2 root area/Mpa/s" ; + fates_hydro_kmax_rsurf1:long_name = "maximum conducitivity for unit root surface (into root)" ; + double fates_hydro_kmax_rsurf2 ; + fates_hydro_kmax_rsurf2:units = "kg water/m2 root area/Mpa/s" ; + fates_hydro_kmax_rsurf2:long_name = "maximum conducitivity for unit root surface (out of root)" ; + double fates_hydro_psi0 ; + fates_hydro_psi0:units = "MPa" ; + fates_hydro_psi0:long_name = "sapwood water potential at saturation" ; + double fates_hydro_psicap ; + fates_hydro_psicap:units = "MPa" ; + fates_hydro_psicap:long_name = "sapwood water potential at which capillary reserves exhausted" ; + double fates_hydro_solver ; + fates_hydro_solver:units = "unitless" ; + fates_hydro_solver:long_name = "switch designating which numerical solver for plant hydraulics, 1 = 1D taylor, 2 = 2D Picard, 3 = 2D Newton (deprecated)" ; + double fates_landuse_logging_coll_under_frac ; + fates_landuse_logging_coll_under_frac:units = "fraction" ; + fates_landuse_logging_coll_under_frac:long_name = "Fraction of stems killed in the understory when logging generates disturbance" ; + double fates_landuse_logging_collateral_frac ; + fates_landuse_logging_collateral_frac:units = "fraction" ; + fates_landuse_logging_collateral_frac:long_name = "Fraction of large stems in upperstory that die from logging collateral damage" ; + double fates_landuse_logging_dbhmax ; + fates_landuse_logging_dbhmax:units = "cm" ; + fates_landuse_logging_dbhmax:long_name = "Maximum dbh below which logging is applied (unset values flag this to be unused)" ; + double fates_landuse_logging_dbhmax_infra ; + fates_landuse_logging_dbhmax_infra:units = "cm" ; + fates_landuse_logging_dbhmax_infra:long_name = "Tree diameter, above which infrastructure from logging does not impact damage or mortality." ; + double fates_landuse_logging_dbhmin ; + fates_landuse_logging_dbhmin:units = "cm" ; + fates_landuse_logging_dbhmin:long_name = "Minimum dbh at which logging is applied" ; + double fates_landuse_logging_direct_frac ; + fates_landuse_logging_direct_frac:units = "fraction" ; + fates_landuse_logging_direct_frac:long_name = "Fraction of stems logged directly per event" ; + double fates_landuse_logging_event_code ; + fates_landuse_logging_event_code:units = "unitless" ; + fates_landuse_logging_event_code:long_name = "Integer code that options how logging events are structured" ; + double fates_landuse_logging_export_frac ; + fates_landuse_logging_export_frac:units = "fraction" ; + fates_landuse_logging_export_frac:long_name = "fraction of trunk product being shipped offsite, the leftovers will be left onsite as large CWD" ; + double fates_landuse_logging_mechanical_frac ; + fates_landuse_logging_mechanical_frac:units = "fraction" ; + fates_landuse_logging_mechanical_frac:long_name = "Fraction of stems killed due infrastructure an other mechanical means" ; + double fates_landuse_pprodharv10_forest_mean ; + fates_landuse_pprodharv10_forest_mean:units = "fraction" ; + fates_landuse_pprodharv10_forest_mean:long_name = "mean harvest mortality proportion of deadstem to 10-yr product (pprodharv10) of all woody PFT types" ; + double fates_leaf_photo_temp_acclim_thome_time ; + fates_leaf_photo_temp_acclim_thome_time:units = "years" ; + fates_leaf_photo_temp_acclim_thome_time:long_name = "Length of the window for the long-term (i.e. T_home in Kumarathunge et al 2019) exponential moving average (ema) of vegetation temperature used in photosynthesis temperature acclimation (used if fates_leaf_photo_tempsens_model = 2)" ; + double fates_leaf_photo_temp_acclim_timescale ; + fates_leaf_photo_temp_acclim_timescale:units = "days" ; + fates_leaf_photo_temp_acclim_timescale:long_name = "Length of the window for the exponential moving average (ema) of vegetation temperature used in photosynthesis temperature acclimation (used if fates_maintresp_leaf_model=2 or fates_leaf_photo_tempsens_model = 2)" ; + double fates_leaf_photo_tempsens_model ; + fates_leaf_photo_tempsens_model:units = "unitless" ; + fates_leaf_photo_tempsens_model:long_name = "switch for choosing the model that defines the temperature sensitivity of photosynthetic parameters (vcmax, jmax). 1=non-acclimating; 2=Kumarathunge et al 2019" ; + double fates_leaf_stomatal_assim_model ; + fates_leaf_stomatal_assim_model:units = "unitless" ; + fates_leaf_stomatal_assim_model:long_name = "a switch designating whether to use net (1) or gross (2) assimilation in the stomatal model" ; + double fates_leaf_stomatal_model ; + fates_leaf_stomatal_model:units = "unitless" ; + fates_leaf_stomatal_model:long_name = "switch for choosing between Ball-Berry (1) stomatal conductance model and Medlyn (2) model" ; + double fates_leaf_theta_cj_c3 ; + fates_leaf_theta_cj_c3:units = "unitless" ; + fates_leaf_theta_cj_c3:long_name = "Empirical curvature parameter for ac, aj photosynthesis co-limitation in c3 plants" ; + double fates_leaf_theta_cj_c4 ; + fates_leaf_theta_cj_c4:units = "unitless" ; + fates_leaf_theta_cj_c4:long_name = "Empirical curvature parameter for ac, aj photosynthesis co-limitation in c4 plants" ; + double fates_maintresp_leaf_model ; + fates_maintresp_leaf_model:units = "unitless" ; + fates_maintresp_leaf_model:long_name = "switch for choosing between maintenance respiration models. 1=Ryan (1991), 2=Atkin et al., (2017)" ; + double fates_maintresp_nonleaf_baserate ; + fates_maintresp_nonleaf_baserate:units = "gC/gN/s" ; + fates_maintresp_nonleaf_baserate:long_name = "Base maintenance respiration rate for plant tissues, using Ryan 1991" ; + double fates_maxcohort ; + fates_maxcohort:units = "count" ; + fates_maxcohort:long_name = "maximum number of cohorts per patch. Actual number of cohorts also depend on cohort fusion tolerances" ; + double fates_maxpatch_primary ; + fates_maxpatch_primary:units = "count" ; + fates_maxpatch_primary:long_name = "maximum number of primary vegetation patches per site" ; + double fates_maxpatch_secondary ; + fates_maxpatch_secondary:units = "count" ; + fates_maxpatch_secondary:long_name = "maximum number of secondary vegetation patches per site" ; + double fates_mort_disturb_frac ; + fates_mort_disturb_frac:units = "fraction" ; + fates_mort_disturb_frac:long_name = "fraction of canopy mortality that results in disturbance (i.e. transfer of area from new to old patch)" ; + double fates_mort_understorey_death ; + fates_mort_understorey_death:units = "fraction" ; + fates_mort_understorey_death:long_name = "fraction of plants in understorey cohort impacted by overstorey tree-fall" ; + double fates_patch_fusion_tol ; + fates_patch_fusion_tol:units = "unitless" ; + fates_patch_fusion_tol:long_name = "minimum fraction in difference in profiles between patches" ; + double fates_phen_chilltemp ; + fates_phen_chilltemp:units = "degrees C" ; + fates_phen_chilltemp:long_name = "chilling day counting threshold for vegetation" ; + double fates_phen_coldtemp ; + fates_phen_coldtemp:units = "degrees C" ; + fates_phen_coldtemp:long_name = "vegetation temperature exceedance that flags a cold-day for leaf-drop" ; + double fates_phen_drought_model ; + fates_phen_drought_model:units = "unitless" ; + fates_phen_drought_model:long_name = "which method to use for drought phenology: 0 - FATES default; 1 - Semi-deciduous (ED2-like)" ; + double fates_phen_drought_threshold ; + fates_phen_drought_threshold:units = "m3/m3 or mm" ; + fates_phen_drought_threshold:long_name = "threshold for drought phenology (or lower threshold when fates_phen_drought_model = 1); the quantity depends on the sign: if positive, the threshold is volumetric soil moisture (m3/m3). If negative, the threshold is soil matric potentical (mm)" ; + double fates_phen_gddthresh_a ; + fates_phen_gddthresh_a:units = "none" ; + fates_phen_gddthresh_a:long_name = "GDD accumulation function, intercept parameter: gdd_thesh = a + b exp(c*ncd)" ; + double fates_phen_gddthresh_b ; + fates_phen_gddthresh_b:units = "none" ; + fates_phen_gddthresh_b:long_name = "GDD accumulation function, multiplier parameter: gdd_thesh = a + b exp(c*ncd)" ; + double fates_phen_gddthresh_c ; + fates_phen_gddthresh_c:units = "none" ; + fates_phen_gddthresh_c:long_name = "GDD accumulation function, exponent parameter: gdd_thesh = a + b exp(c*ncd)" ; + double fates_phen_mindaysoff ; + fates_phen_mindaysoff:units = "days" ; + fates_phen_mindaysoff:long_name = "day threshold compared against days since leaves became off-allometry" ; + double fates_phen_mindayson ; + fates_phen_mindayson:units = "days" ; + fates_phen_mindayson:long_name = "day threshold compared against days since leaves became on-allometry" ; + double fates_phen_moist_threshold ; + fates_phen_moist_threshold:units = "m3/m3 or mm" ; + fates_phen_moist_threshold:long_name = "upper threshold for drought phenology (only for fates_phen_drought_model=1); the quantity depends on the sign: if positive, the threshold is volumetric soil moisture (m3/m3). If negative, the threshold is soil matric potentical (mm)" ; + double fates_phen_ncolddayslim ; + fates_phen_ncolddayslim:units = "days" ; + fates_phen_ncolddayslim:long_name = "day threshold exceedance for temperature leaf-drop" ; + double fates_q10_froz ; + fates_q10_froz:units = "unitless" ; + fates_q10_froz:long_name = "Q10 for frozen-soil respiration rates" ; + double fates_q10_mr ; + fates_q10_mr:units = "unitless" ; + fates_q10_mr:long_name = "Q10 for maintenance respiration" ; + double fates_soil_salinity ; + fates_soil_salinity:units = "ppt" ; + fates_soil_salinity:long_name = "soil salinity used for model when not coupled to dynamic soil salinity" ; + double fates_vai_top_bin_width ; + fates_vai_top_bin_width:units = "m2/m2" ; + fates_vai_top_bin_width:long_name = "width in VAI units of uppermost leaf+stem layer scattering element in each canopy layer" ; + double fates_vai_width_increase_factor ; + fates_vai_width_increase_factor:units = "unitless" ; + fates_vai_width_increase_factor:long_name = "factor by which each leaf+stem scattering element increases in VAI width (1 = uniform spacing)" ; + +// global attributes: + :history = "This file was generated by BatchPatchParams.py:\nCDL Base File = archive/api24.1.0_101722_fates_params_default.cdl\nXML patch file = archive/api24.1.0_101722_patch_params.xml" ; +data: + + fates_history_ageclass_bin_edges = 0, 1, 2, 5, 10, 20, 50 ; + + fates_history_coageclass_bin_edges = 0, 5 ; + + fates_history_height_bin_edges = 0, 0.1, 0.3, 1, 3, 10 ; + + fates_history_damage_bin_edges = 0, 80 ; + + fates_history_sizeclass_bin_edges = 0, 5, 10, 15, 20, 30, 40, 50, 60, 70, + 80, 90, 100 ; + + fates_alloc_organ_id = 1, 2, 3, 6 ; + + fates_hydro_htftype_node = 1, 1, 1, 1 ; + + fates_pftname = + "broadleaf_evergreen_tropical_tree ", + "needleleaf_evergreen_extratrop_tree ", + "needleleaf_colddecid_extratrop_tree ", + "broadleaf_evergreen_extratrop_tree ", + "broadleaf_hydrodecid_tropical_tree ", + "broadleaf_colddecid_extratrop_tree ", + "broadleaf_evergreen_extratrop_shrub ", + "broadleaf_hydrodecid_extratrop_shrub ", + "broadleaf_colddecid_extratrop_shrub ", + "arctic_c3_grass ", + "cool_c3_grass ", + "c4_grass " ; + + fates_hydro_organ_name = + "leaf ", + "stem ", + "transporting root ", + "absorbing root " ; + + fates_alloc_organ_name = + "leaf", + "fine root", + "sapwood", + "structure" ; + + fates_litterclass_name = + "twig ", + "small branch ", + "large branch ", + "trunk ", + "dead leaves ", + "live grass " ; + + fates_alloc_organ_priority = + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 ; + + fates_alloc_storage_cushion = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, + 1.2, 1.2, 1.2 ; + + fates_alloc_store_priority_frac = 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, + 0.8, 0.8, 0.8, 0.8 ; + + fates_allom_agb1 = 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, + 0.06896, 0.06896, 0.06896, 0.01, 0.01, 0.01 ; + + fates_allom_agb2 = 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, + 0.572, 0.572, 0.572, 0.572 ; + + fates_allom_agb3 = 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, + 1.94, 1.94, 1.94 ; + + fates_allom_agb4 = 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, + 0.931, 0.931, 0.931, 0.931 ; + + fates_allom_agb_frac = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, + 0.6, 0.6 ; + + fates_allom_amode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_blca_expnt_diff = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_allom_cmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_crown_depth_frac = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.95, 0.95, + 0.95, 1, 1, 1 ; + + fates_allom_d2bl1 = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, + 0.07, 0.07, 0.07 ; + + fates_allom_d2bl2 = 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, + 1.3 ; + + fates_allom_d2bl3 = 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, + 0.55, 0.55, 0.55 ; + + fates_allom_d2ca_coefficient_max = 0.6568464, 0.6568464, 0.6568464, + 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464, + 0.6568464, 0.6568464, 0.6568464 ; + + fates_allom_d2ca_coefficient_min = 0.3381119, 0.3381119, 0.3381119, + 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119, + 0.3381119, 0.3381119, 0.3381119 ; + + fates_allom_d2h1 = 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, + 0.64, 0.64, 0.64 ; + + fates_allom_d2h2 = 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, + 0.37, 0.37, 0.37 ; + + fates_allom_d2h3 = -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, + -999.9, -999.9, -999.9, -999.9, -999.9 ; + + fates_allom_dbh_maxheight = 90, 80, 80, 80, 90, 80, 3, 3, 2, 0.35, 0.35, 0.35 ; + + fates_allom_fmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_fnrt_prof_a = 7, 7, 7, 7, 6, 6, 7, 7, 7, 11, 11, 11 ; + + fates_allom_fnrt_prof_b = 1, 2, 2, 1, 2, 2, 1.5, 1.5, 1.5, 2, 2, 2 ; + + fates_allom_fnrt_prof_mode = 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3 ; + + fates_allom_frbstor_repro = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_allom_hmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_l2fr = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_la_per_sa_int = 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, + 0.8, 0.8, 0.8 ; + + fates_allom_la_per_sa_slp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_allom_lmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_sai_scaler = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, + 0.1, 0.1 ; + + fates_allom_smode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_stmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_zroot_k = 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10 ; + + fates_allom_zroot_max_dbh = 100, 100, 100, 100, 100, 100, 2, 2, 2, 2, 2, 2 ; + + fates_allom_zroot_max_z = 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100 ; + + fates_allom_zroot_min_dbh = 1, 1, 1, 2.5, 2.5, 2.5, 0.1, 0.1, 0.1, 0.1, 0.1, + 0.1 ; + + fates_allom_zroot_min_z = 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100 ; + + fates_c2b = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 ; + + fates_cnp_eca_alpha_ptase = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5 ; + + fates_cnp_eca_decompmicc = 280, 280, 280, 280, 280, 280, 280, 280, 280, 280, + 280, 280 ; + + fates_cnp_eca_km_nh4 = 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, + 0.14, 0.14, 0.14 ; + + fates_cnp_eca_km_no3 = 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, + 0.27, 0.27, 0.27 ; + + fates_cnp_eca_km_p = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, + 0.1 ; + + fates_cnp_eca_km_ptase = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_cnp_eca_lambda_ptase = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_cnp_eca_vmax_ptase = 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, + 5e-09, 5e-09, 5e-09, 5e-09, 5e-09 ; + + fates_cnp_nfix1 = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_cnp_nitr_store_ratio = 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, + 1.5, 1.5, 1.5 ; + + fates_cnp_phos_store_ratio = 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, + 1.5, 1.5, 1.5 ; + + fates_cnp_pid_kd = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 ; + + fates_cnp_pid_ki = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_cnp_pid_kp = 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005 ; + + fates_cnp_prescribed_nuptake = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_cnp_prescribed_puptake = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_cnp_store_ovrflw_frac = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_cnp_turnover_nitr_retrans = + 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_cnp_turnover_phos_retrans = + 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_cnp_vmax_nh4 = 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, + 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09 ; + + fates_cnp_vmax_no3 = 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, + 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09, 2.5e-09 ; + + fates_cnp_vmax_p = 5e-10, 5e-10, 5e-10, 5e-10, 5e-10, 5e-10, 5e-10, 5e-10, + 5e-10, 5e-10, 5e-10, 5e-10 ; + + fates_damage_frac = 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, + 0.01, 0.01, 0.01 ; + + fates_damage_mort_p1 = 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9 ; + + fates_damage_mort_p2 = 5.5, 5.5, 5.5, 5.5, 5.5, 5.5, 5.5, 5.5, 5.5, 5.5, + 5.5, 5.5 ; + + fates_damage_recovery_scalar = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_dev_arbitrary_pft = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_fire_alpha_SH = 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, + 0.2 ; + + fates_fire_bark_scaler = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, + 0.07, 0.07, 0.07, 0.07 ; + + fates_fire_crown_kill = 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, + 0.775, 0.775, 0.775, 0.775, 0.775 ; + + fates_frag_fnrt_fcel = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5 ; + + fates_frag_fnrt_flab = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0.25, 0.25, 0.25 ; + + fates_frag_fnrt_flig = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0.25, 0.25, 0.25 ; + + fates_frag_leaf_fcel = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5 ; + + fates_frag_leaf_flab = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0.25, 0.25, 0.25 ; + + fates_frag_leaf_flig = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0.25, 0.25, 0.25 ; + + fates_frag_seed_decay_rate = 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, + 0.51, 0.51, 0.51, 0.51 ; + + fates_grperc = 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, + 0.11, 0.11 ; + + fates_hydro_avuln_gs = 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, + 2.5, 2.5 ; + + fates_hydro_avuln_node = + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 ; + + fates_hydro_epsil_node = + 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, + 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, + 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, + 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8 ; + + fates_hydro_fcap_node = + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, + 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_hydro_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_hydro_kmax_node = + -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, + -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999 ; + + fates_hydro_p50_gs = -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, + -1.5, -1.5, -1.5 ; + + fates_hydro_p50_node = + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25, + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25, + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25, + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25 ; + + fates_hydro_p_taper = 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, + 0.333, 0.333, 0.333, 0.333, 0.333 ; + + fates_hydro_pinot_node = + -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, + -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, + -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, + -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, + -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, + -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, + -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, + -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478 ; + + fates_hydro_pitlp_node = + -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, + -1.67, -1.67, + -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, + -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, + -1.2, -1.2, -1.2, -1.2, -1.2, -1.2, -1.2, -1.2, -1.2, -1.2, -1.2, -1.2 ; + + fates_hydro_resid_node = + 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, + 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, + 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, + 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11 ; + + fates_hydro_rfrac_stem = 0.625, 0.625, 0.625, 0.625, 0.625, 0.625, 0.625, + 0.625, 0.625, 0.625, 0.625, 0.625 ; + + fates_hydro_rs2 = 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, + 0.0001, 0.0001, 0.0001, 0.0001, 0.0001 ; + + fates_hydro_srl = 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25 ; + + fates_hydro_thetas_node = + 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, + 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, + 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, + 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75 ; + + fates_hydro_vg_alpha_node = + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005, + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005, + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005, + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005 ; + + fates_hydro_vg_m_node = + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; + + fates_hydro_vg_n_node = + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 ; + + fates_leaf_c3psn = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0 ; + + fates_leaf_jmaxha = 43540, 43540, 43540, 43540, 43540, 43540, 43540, 43540, + 43540, 43540, 43540, 43540 ; + + fates_leaf_jmaxhd = 152040, 152040, 152040, 152040, 152040, 152040, 152040, + 152040, 152040, 152040, 152040, 152040 ; + + fates_leaf_jmaxse = 495, 495, 495, 495, 495, 495, 495, 495, 495, 495, 495, + 495 ; + + fates_leaf_slamax = 0.0954, 0.0954, 0.0954, 0.0954, 0.0954, 0.0954, 0.012, + 0.03, 0.03, 0.03, 0.03, 0.03 ; + + fates_leaf_slatop = 0.012, 0.005, 0.024, 0.009, 0.03, 0.03, 0.012, 0.03, + 0.03, 0.03, 0.03, 0.03 ; + + fates_leaf_stomatal_intercept = 10000, 10000, 10000, 10000, 10000, 10000, + 10000, 10000, 10000, 10000, 10000, 40000 ; + + fates_leaf_stomatal_slope_ballberry = 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8 ; + + fates_leaf_stomatal_slope_medlyn = 4.1, 2.3, 2.3, 4.1, 4.4, 4.4, 4.7, 4.7, + 4.7, 2.2, 5.3, 1.6 ; + + fates_leaf_vcmax25top = + 50, 62, 39, 61, 41, 58, 62, 54, 54, 78, 78, 78 ; + + fates_leaf_vcmaxha = 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330, + 65330, 65330, 65330, 65330 ; + + fates_leaf_vcmaxhd = 149250, 149250, 149250, 149250, 149250, 149250, 149250, + 149250, 149250, 149250, 149250, 149250 ; + + fates_leaf_vcmaxse = 485, 485, 485, 485, 485, 485, 485, 485, 485, 485, 485, + 485 ; + + fates_maintresp_leaf_atkin2017_baserate = 1.756, 1.4995, 1.4995, 1.756, + 1.756, 1.756, 2.0749, 2.0749, 2.0749, 2.1956, 2.1956, 2.1956 ; + + fates_maintresp_leaf_ryan1991_baserate = 2.525e-06, 2.525e-06, 2.525e-06, + 2.525e-06, 2.525e-06, 2.525e-06, 2.525e-06, 2.525e-06, 2.525e-06, + 2.525e-06, 2.525e-06, 2.525e-06 ; + + fates_maintresp_reduction_curvature = 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, + 0.01, 0.01, 0.01, 0.01, 0.01, 0.01 ; + + fates_maintresp_reduction_intercept = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_mort_bmort = 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, + 0.014, 0.014, 0.014, 0.014 ; + + fates_mort_freezetol = 2.5, -55, -80, -30, 2.5, -80, -60, -10, -80, -80, + -20, 2.5 ; + + fates_mort_hf_flc_threshold = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5 ; + + fates_mort_hf_sm_threshold = 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, + 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06 ; + + fates_mort_ip_age_senescence = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_mort_ip_size_senescence = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_mort_prescribed_canopy = 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, + 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194 ; + + fates_mort_prescribed_understory = 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, + 0.025, 0.025, 0.025, 0.025, 0.025, 0.025 ; + + fates_mort_r_age_senescence = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_mort_r_size_senescence = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_mort_scalar_coldstress = 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3 ; + + fates_mort_scalar_cstarvation = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, + 0.6, 0.6, 0.6 ; + + fates_mort_scalar_hydrfailure = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, + 0.6, 0.6, 0.6 ; + + fates_nonhydro_smpsc = -255000, -255000, -255000, -255000, -255000, -255000, + -255000, -255000, -255000, -255000, -255000, -255000 ; + + fates_nonhydro_smpso = -66000, -66000, -66000, -66000, -66000, -66000, + -66000, -66000, -66000, -66000, -66000, -66000 ; + + fates_phen_cold_size_threshold = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_phen_evergreen = 1, 1, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0 ; + + fates_phen_flush_fraction = _, _, 0.5, _, 0.5, 0.5, _, 0.5, 0.5, 0.5, 0.5, + 0.5 ; + + fates_phen_fnrt_drop_frac = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_phen_season_decid = 0, 0, 1, 0, 0, 1, 0, 0, 1, 1, 0, 0 ; + + fates_phen_stem_drop_fraction = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_phen_stress_decid = 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 1 ; + + fates_prescribed_npp_canopy = 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, + 0.4, 0.4, 0.4 ; + + fates_prescribed_npp_understory = 0.03125, 0.03125, 0.03125, 0.03125, + 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125 ; + + fates_rad_leaf_clumping_index = 0.85, 0.85, 0.8, 0.85, 0.85, 0.9, 0.85, 0.9, + 0.9, 0.75, 0.75, 0.75 ; + + fates_rad_leaf_rhonir = 0.46, 0.41, 0.39, 0.46, 0.41, 0.41, 0.46, 0.41, + 0.41, 0.28, 0.28, 0.28 ; + + fates_rad_leaf_rhovis = 0.11, 0.09, 0.08, 0.11, 0.08, 0.08, 0.11, 0.08, + 0.08, 0.05, 0.05, 0.05 ; + + fates_rad_leaf_taunir = 0.33, 0.32, 0.42, 0.33, 0.43, 0.43, 0.33, 0.43, + 0.43, 0.4, 0.4, 0.4 ; + + fates_rad_leaf_tauvis = 0.06, 0.04, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, + 0.06, 0.05, 0.05, 0.05 ; + + fates_rad_leaf_xl = 0.32, 0.01, 0.01, 0.32, 0.2, 0.59, 0.32, 0.59, 0.59, + -0.23, -0.23, -0.23 ; + + fates_rad_stem_rhonir = 0.49, 0.36, 0.36, 0.49, 0.49, 0.49, 0.49, 0.49, + 0.49, 0.53, 0.53, 0.53 ; + + fates_rad_stem_rhovis = 0.21, 0.12, 0.12, 0.21, 0.21, 0.21, 0.21, 0.21, + 0.21, 0.31, 0.31, 0.31 ; + + fates_rad_stem_taunir = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, + 0.001, 0.001, 0.25, 0.25, 0.25 ; + + fates_rad_stem_tauvis = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, + 0.001, 0.001, 0.12, 0.12, 0.12 ; + + fates_recruit_height_min = 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 0.2, 0.2, 0.2, + 0.125, 0.125, 0.125 ; + + fates_recruit_init_density = 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, + 0.2, 0.2, 0.2 ; + + fates_recruit_prescribed_rate = 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, + 0.02, 0.02, 0.02, 0.02, 0.02 ; + + fates_recruit_seed_alloc = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, + 0.1, 0.1 ; + + fates_recruit_seed_alloc_mature = 0, 0, 0, 0, 0, 0, 0.9, 0.9, 0.9, 0.9, 0.9, + 0.9 ; + + fates_recruit_seed_dbh_repro_threshold = 90, 80, 80, 80, 90, 80, 3, 3, 2, + 0.35, 0.35, 0.35 ; + + fates_recruit_seed_germination_rate = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5 ; + + fates_recruit_seed_supplement = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_stoich_nitr = + 0.033, 0.029, 0.04, 0.033, 0.04, 0.04, 0.033, 0.04, 0.04, 0.04, 0.04, 0.04, + 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, + 0.024, 0.024, + 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, + 1e-08, 1e-08, + 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, + 0.0047, 0.0047, 0.0047 ; + + fates_stoich_phos = + 0.0033, 0.0029, 0.004, 0.0033, 0.004, 0.004, 0.0033, 0.004, 0.004, 0.004, + 0.004, 0.004, + 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, + 0.0024, 0.0024, 0.0024, + 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, + 1e-09, 1e-09, + 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, + 0.00047, 0.00047, 0.00047, 0.00047 ; + + fates_trim_inc = 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, + 0.03, 0.03 ; + + fates_trim_limit = 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3 ; + + fates_turb_displar = 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, + 0.67, 0.67, 0.67 ; + + fates_turb_leaf_diameter = 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, + 0.04, 0.04, 0.04, 0.04 ; + + fates_turb_z0mr = 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, + 0.055, 0.055, 0.055, 0.055 ; + + fates_turnover_branch = 150, 150, 150, 150, 150, 150, 150, 150, 150, 0, 0, 0 ; + + fates_turnover_fnrt = 1, 2, 1, 1.5, 1, 1, 1.5, 1, 1, 1, 1, 1 ; + + fates_turnover_leaf = + 1.5, 4, 1, 1.5, 1, 1, 1.5, 1, 1, 1, 1, 1 ; + + fates_turnover_senleaf_fdrought = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_wood_density = 0.7, 0.4, 0.7, 0.53, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, + 0.7 ; + + fates_woody = 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0 ; + + fates_hlm_pft_map = + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 ; + + fates_fire_FBD = 15.4, 16.8, 19.6, 999, 4, 4 ; + + fates_fire_low_moisture_Coeff = 1.12, 1.09, 0.98, 0.8, 1.15, 1.15 ; + + fates_fire_low_moisture_Slope = 0.62, 0.72, 0.85, 0.8, 0.62, 0.62 ; + + fates_fire_mid_moisture = 0.72, 0.51, 0.38, 1, 0.8, 0.8 ; + + fates_fire_mid_moisture_Coeff = 2.35, 1.47, 1.06, 0.8, 3.2, 3.2 ; + + fates_fire_mid_moisture_Slope = 2.35, 1.47, 1.06, 0.8, 3.2, 3.2 ; + + fates_fire_min_moisture = 0.18, 0.12, 0, 0, 0.24, 0.24 ; + + fates_fire_SAV = 13, 3.58, 0.98, 0.2, 66, 66 ; + + fates_frag_maxdecomp = 0.52, 0.383, 0.383, 0.19, 1, 999 ; + + fates_frag_cwd_frac = 0.045, 0.075, 0.21, 0.67 ; + + fates_canopy_closure_thresh = 0.8 ; + + fates_cnp_eca_plant_escalar = 1.25e-05 ; + + fates_cohort_age_fusion_tol = 0.08 ; + + fates_cohort_size_fusion_tol = 0.08 ; + + fates_comp_excln = 3 ; + + fates_damage_canopy_layer_code = 1 ; + + fates_damage_event_code = 1 ; + + fates_dev_arbitrary = _ ; + + fates_fire_active_crown_fire = 0 ; + + fates_fire_cg_strikes = 0.2 ; + + fates_fire_drying_ratio = 66000 ; + + fates_fire_durat_slope = -11.06 ; + + fates_fire_fdi_a = 17.62 ; + + fates_fire_fdi_alpha = 0.00037 ; + + fates_fire_fdi_b = 243.12 ; + + fates_fire_fuel_energy = 18000 ; + + fates_fire_max_durat = 240 ; + + fates_fire_miner_damp = 0.41739 ; + + fates_fire_miner_total = 0.055 ; + + fates_fire_nignitions = 15 ; + + fates_fire_part_dens = 513 ; + + fates_fire_threshold = 50 ; + + fates_frag_cwd_fcel = 0.76 ; + + fates_frag_cwd_flig = 0.24 ; + + fates_hydro_kmax_rsurf1 = 20 ; + + fates_hydro_kmax_rsurf2 = 0.0001 ; + + fates_hydro_psi0 = 0 ; + + fates_hydro_psicap = -0.6 ; + + fates_hydro_solver = 1 ; + + fates_landuse_logging_coll_under_frac = 0.55983 ; + + fates_landuse_logging_collateral_frac = 0.05 ; + + fates_landuse_logging_dbhmax = _ ; + + fates_landuse_logging_dbhmax_infra = 35 ; + + fates_landuse_logging_dbhmin = 50 ; + + fates_landuse_logging_direct_frac = 0.15 ; + + fates_landuse_logging_event_code = -30 ; + + fates_landuse_logging_export_frac = 0.8 ; + + fates_landuse_logging_mechanical_frac = 0.05 ; + + fates_landuse_pprodharv10_forest_mean = 0.8125 ; + + fates_leaf_photo_temp_acclim_thome_time = 30 ; + + fates_leaf_photo_temp_acclim_timescale = 30 ; + + fates_leaf_photo_tempsens_model = 1 ; + + fates_leaf_stomatal_assim_model = 1 ; + + fates_leaf_stomatal_model = 1 ; + + fates_leaf_theta_cj_c3 = 0.999 ; + + fates_leaf_theta_cj_c4 = 0.999 ; + + fates_maintresp_leaf_model = 1 ; + + fates_maintresp_nonleaf_baserate = 2.525e-06 ; + + fates_maxcohort = 100 ; + + fates_maxpatch_primary = 10 ; + + fates_maxpatch_secondary = 4 ; + + fates_mort_disturb_frac = 1 ; + + fates_mort_understorey_death = 0.55983 ; + + fates_patch_fusion_tol = 0.05 ; + + fates_phen_chilltemp = 5 ; + + fates_phen_coldtemp = 7.5 ; + + fates_phen_drought_model = 0 ; + + fates_phen_drought_threshold = 0.15 ; + + fates_phen_gddthresh_a = -68 ; + + fates_phen_gddthresh_b = 638 ; + + fates_phen_gddthresh_c = -0.01 ; + + fates_phen_mindaysoff = 100 ; + + fates_phen_mindayson = 90 ; + + fates_phen_moist_threshold = 0.18 ; + + fates_phen_ncolddayslim = 5 ; + + fates_q10_froz = 1.5 ; + + fates_q10_mr = 1.5 ; + + fates_soil_salinity = 0.4 ; + + fates_vai_top_bin_width = 1 ; + + fates_vai_width_increase_factor = 1 ; +} From bf35c78eea209abf6f00896a246f496555737767 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Mon, 24 Apr 2023 11:18:51 -0700 Subject: [PATCH 043/250] changing some variable names in patch fusion --- biogeochem/EDPatchDynamicsMod.F90 | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 0d83500fa2..f795e083cf 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2616,7 +2616,7 @@ subroutine fuse_patches( csite, bc_in ) integer :: nopatches(n_landuse_cats) !number of patches presently in gridcell integer :: iterate !switch of patch reduction iteration scheme. 1 to keep going, 0 to stop integer :: fuse_flag !do patches get fused (1) or not (0). - integer :: i_disttype !iterator over anthropogenic disturbance categories + integer :: i_lulabel !iterator over anthropogenic disturbance categories integer :: i_pftlabel !nocomp pft iterator real(r8) :: primary_land_fraction_beforefusion,primary_land_fraction_afterfusion integer :: pftlabelmin, pftlabelmax @@ -2678,10 +2678,10 @@ subroutine fuse_patches( csite, bc_in ) endif !---------------------------------------------------------------------! - ! iterate over anthropogenic disturbance categories + ! iterate over land use categories !---------------------------------------------------------------------! - disttype_loop: do i_disttype = 1, n_landuse_cats + lulabel_loop: do i_lulabel = 1, n_landuse_cats !---------------------------------------------------------------------! ! We only really care about fusing patches if nopatches > 1 ! @@ -2723,8 +2723,8 @@ subroutine fuse_patches( csite, bc_in ) ! only fuse patches whose anthropogenic disturbance category matches ! ! that of the outer loop that we are in ! !--------------------------------------------------------------------! - anthro_dist_labels_match_if: if ( tpp%land_use_label .eq. i_disttype .and. & - currentPatch%land_use_label .eq. i_disttype) then + landuse_labels_match_if: if ( tpp%land_use_label .eq. i_lulabel .and. & + currentPatch%land_use_label .eq. i_lulabel) then nocomp_pft_labels_match_if: if (hlm_use_nocomp .eq. ifalse .or. & (tpp%nocomp_pft_label .eq. i_pftlabel .and. & @@ -2838,7 +2838,7 @@ subroutine fuse_patches( csite, bc_in ) endif fuseflagset_if endif different_patches_if endif nocomp_pft_labels_match_if - endif anthro_dist_labels_match_if + endif landuse_labels_match_if endif both_associated_if tpp => tpp%older @@ -2857,16 +2857,16 @@ subroutine fuse_patches( csite, bc_in ) !---------------------------------------------------------------------! ! Is the number of patches larger than the maximum? ! !---------------------------------------------------------------------! - nopatches(i_disttype) = 0 + nopatches(i_lulabel) = 0 currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - if (currentPatch%land_use_label .eq. i_disttype) then - nopatches(i_disttype) = nopatches(i_disttype) +1 + if (currentPatch%land_use_label .eq. i_lulabel) then + nopatches(i_lulabel) = nopatches(i_lulabel) +1 endif currentPatch => currentPatch%older enddo - if(nopatches(i_disttype) > maxpatches(i_disttype))then + if(nopatches(i_lulabel) > maxpatches(i_lulabel))then iterate = 1 profiletol = profiletol * patch_fusion_tolerance_relaxation_increment @@ -2891,7 +2891,7 @@ subroutine fuse_patches( csite, bc_in ) enddo iterate_eq_1_loop ! iterate .eq. 1 ==> nopatches>maxpatch_total - end do disttype_loop + end do lulabel_loop currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) From a35aec2301e84f40ec7e6e77bc2aba82eddaa134 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 25 Apr 2023 10:27:59 -0700 Subject: [PATCH 044/250] Correct type and reintroduce site variable Bring back primary to primary site level variable, but update to a 3d array. --- main/EDTypesMod.F90 | 1 + main/FatesHistoryInterfaceMod.F90 | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 84c1fb7a4b..2ce9554e91 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -899,6 +899,7 @@ module EDTypesMod real(r8) :: spread ! dynamic canopy allometric term [unitless] ! site-level variables to keep track of the disturbance rates, both actual and "potential" + real(r8) :: disturbance_rates_primary_to_primary(N_DIST_TYPES,n_landuse_cats,n_landuse_cats) real(r8) :: disturbance_rates(N_DIST_TYPES,n_landuse_cats, n_landuse_cats) ! actual disturbance rates for each disturbance type [m2/m2/day] real(r8) :: primary_land_patchfusion_error ! error term in total area of primary patches associated with patch fusion [m2/m2/day] real(r8) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) ! land use transition matrix as read in from HLM and aggregated to FATES land use types [m2/m2/year] diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index c61794b332..865556a1ee 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2682,7 +2682,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! roll up disturbance rates in land-use x land-use array into a single dimension do i_dist = 1, n_landuse_cats do j_dist = 1, n_landuse_cats - hio_disturbance_rate_si_lulu(io_si, i_dist+n_landuse_cats*(j_dist-1)) = sum(site%disturbance_rates(1:n_dist_types,i_dist, j_dist) * & + hio_disturbance_rate_si_lulu(io_si, i_dist+n_landuse_cats*(j_dist-1)) = sum(sites(s)%disturbance_rates(1:n_dist_types,i_dist, j_dist) * & days_per_year end do end do From 87362b4c5acce66bad57b04af569ddf9df84c760 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 25 Apr 2023 10:50:07 -0700 Subject: [PATCH 045/250] Correcting typos --- main/FatesHistoryInterfaceMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 865556a1ee..2ce12c04d5 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2175,6 +2175,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) use FatesLitterMod , only : ncwd use EDtypesMod , only : ican_upper use EDtypesMod , only : ican_ustory + use FatesConstantsMod , only : n_landuse_cats use FatesSizeAgeTypeIndicesMod, only : get_sizeage_class_index use FatesSizeAgeTypeIndicesMod, only : get_sizeagepft_class_index use FatesSizeAgeTypeIndicesMod, only : get_agepft_class_index @@ -2682,7 +2683,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! roll up disturbance rates in land-use x land-use array into a single dimension do i_dist = 1, n_landuse_cats do j_dist = 1, n_landuse_cats - hio_disturbance_rate_si_lulu(io_si, i_dist+n_landuse_cats*(j_dist-1)) = sum(sites(s)%disturbance_rates(1:n_dist_types,i_dist, j_dist) * & + hio_disturbance_rate_si_lulu(io_si, i_dist+n_landuse_cats*(j_dist-1)) = sum(sites(s)%disturbance_rates(1:n_dist_types,i_dist, j_dist)) * & days_per_year end do end do From f5bb2d062b5f1a134d0c20bb987cfbdf6a2cd305 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 25 Apr 2023 16:36:04 -0700 Subject: [PATCH 046/250] fix runtime issues --- main/FatesHistoryVariableType.F90 | 14 ++++++++++++++ main/FatesIODimensionsMod.F90 | 2 +- 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 index 5902496a2c..59e5da01de 100644 --- a/main/FatesHistoryVariableType.F90 +++ b/main/FatesHistoryVariableType.F90 @@ -16,6 +16,7 @@ module FatesHistoryVariableType use FatesIOVariableKindMod, only : site_elem_r8, site_elpft_r8 use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8 use FatesIOVariableKindMod, only : iotype_index, site_agefuel_r8, site_clscpf_r8 + use FatesIOVariableKindMod, only : site_landuse_r8, site_lulu_r8 use shr_log_mod , only : errMsg => shr_log_errMsg @@ -208,6 +209,14 @@ subroutine Init(this, vname, units, long, use_default, & allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval + case(site_landuse_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_lulu_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + case(site_clscpf_r8) allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval @@ -338,6 +347,11 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(site_clscpf_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_landuse_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_lulu_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case default write(fates_log(),*) 'fates history variable type undefined while flushing history variables' call endrun(msg=errMsg(sourcefile, __LINE__)) diff --git a/main/FatesIODimensionsMod.F90 b/main/FatesIODimensionsMod.F90 index 9bd8342544..4aa9b4cada 100644 --- a/main/FatesIODimensionsMod.F90 +++ b/main/FatesIODimensionsMod.F90 @@ -36,7 +36,7 @@ module FatesIODimensionsMod character(*), parameter, public :: levelcwd = 'fates_levelcwd' character(*), parameter, public :: levelage = 'fates_levelage' character(*), parameter, public :: levlanduse = 'fates_levlanduse' - character(*), parameter, public :: levlulu = 'fates_lulu' + character(*), parameter, public :: levlulu = 'fates_levlulu' ! column = This is a structure that records where FATES column boundaries ! on each thread point to in the host IO array, this structure From 6a935ad816774e5bb765a0af0d82358db33c93fc Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 26 Apr 2023 16:49:30 -0700 Subject: [PATCH 047/250] fix runtime issues to avoid NaN This also corrects a missed variable rename --- biogeochem/EDPatchDynamicsMod.F90 | 38 +++++++++++++++++++++---------- main/EDInitMod.F90 | 2 ++ 2 files changed, 28 insertions(+), 12 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index f795e083cf..7e10638027 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -50,6 +50,7 @@ module EDPatchDynamicsMod use FatesInterfaceTypesMod , only : hlm_use_nocomp use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog use FatesInterfaceTypesMod , only : hlm_num_lu_harvest_cats + use FatesInterfaceTypesMod , only : hlm_use_luh use FatesInterfaceTypesMod , only : hlm_num_luh2_states use FatesInterfaceTypesMod , only : hlm_num_luh2_transitions use FatesGlobals , only : endrun => fates_endrun @@ -302,10 +303,13 @@ subroutine disturbance_rates( site_in, bc_in) currentPatch%disturbance_rates(dtype_ifire) = 0.0_r8 dist_rate_ldist_notharvested = 0.0_r8 - - currentPatch%landuse_transition_rates(1:n_landuse_cats) = min(1._r8, & - landuse_transition_matrix(currentPatch%land_use_label,1:n_landuse_cats) / & - current_fates_landuse_state_vector(currentPatch%land_use_label)) + + ! Avoid this calculation to avoid NaN result if luh is not used + if (hlm_use_luh .eq. itrue) then + currentPatch%landuse_transition_rates(1:n_landuse_cats) = min(1._r8, & + landuse_transition_matrix(currentPatch%land_use_label,1:n_landuse_cats) / & + current_fates_landuse_state_vector(currentPatch%land_use_label)) + end if currentCohort => currentPatch%shortest do while(associated(currentCohort)) @@ -433,8 +437,8 @@ subroutine spawn_patches( currentSite, bc_in) ! ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: new_patch - type (ed_patch_type) , pointer :: new_patch_primary - type (ed_patch_type) , pointer :: new_patch_secondary + ! type (ed_patch_type) , pointer :: new_patch_primary + ! type (ed_patch_type) , pointer :: new_patch_secondary type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type), pointer :: currentCohort type (ed_cohort_type), pointer :: nc @@ -471,6 +475,8 @@ subroutine spawn_patches( currentSite, bc_in) !--------------------------------------------------------------------- + ! write(fates_log(),*) 'calling spawn patches' + storesmallcohort => null() ! storage of the smallest cohort for insertion routine storebigcohort => null() ! storage of the largest cohort for insertion routine @@ -484,6 +490,7 @@ subroutine spawn_patches( currentSite, bc_in) ! zero the diagnostic disturbance rate fields currentSite%disturbance_rates(:,:,:) = 0._r8 + ! disturbance_rate = 0._8 ! get rules for vegetation clearing during land use change call get_landusechange_rules(clearing_matrix) @@ -519,6 +526,9 @@ subroutine spawn_patches( currentSite, bc_in) patchloop_areadis: do while(associated(currentPatch)) + write(fates_log(),*) 'indices: ncpft, dt, dplt, lcrpl: ', i_nocomp_pft, i_disturbance_type, i_donorpatch_landuse_type, i_landusechange_receiverpatchlabel + write(fates_log(),*) 'labels: lul, ncpl', currentPatch%land_use_label, currentPatch%nocomp_pft_label + cp_nocomp_matches_1_if: if ( hlm_use_nocomp .eq. ifalse .or. & currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then @@ -530,6 +540,10 @@ subroutine spawn_patches( currentSite, bc_in) disturbance_rate = currentPatch%landuse_transition_rates(i_landusechange_receiverpatchlabel) endif + ! disturbance_rate = 0._8 + write(fates_log(),*) 'patch disturbance rate: ',currentPatch%disturbance_rates(i_disturbance_type) + write(fates_log(),*) 'disturbance type: ', i_disturbance_type + if(disturbance_rate > (1.0_r8 + rsnbl_math_prec)) then write(fates_log(),*) 'patch disturbance rate > 1 ?',disturbance_rate call dump_patch(currentPatch) @@ -1206,23 +1220,23 @@ subroutine spawn_patches( currentSite, bc_in) end do if (associated(currentPatch)) then ! the case where we've found a youngest primary patch - new_patch_primary%older => currentPatch - new_patch_primary%younger => currentPatch%younger + new_patch%older => currentPatch + new_patch%younger => currentPatch%younger currentPatch%younger%older => new_patch currentPatch%younger => new_patch else ! the case where we haven't, because the patches are all secondaary, ! and are putting a primary patch at the oldest end of the ! linked list (not sure how this could happen, but who knows...) - new_patch_primary%older => null() - new_patch_primary%younger => currentSite%oldest_patch + new_patch%older => null() + new_patch%younger => currentSite%oldest_patch currentSite%oldest_patch%older => new_patch currentSite%oldest_patch => new_patch endif else ! the case where there are no secondary patches at the start of the linked list (prior logic) - new_patch_primary%older => currentPatch - new_patch_primary%younger => null() + new_patch%older => currentPatch + new_patch%younger => null() currentPatch%younger => new_patch currentSite%youngest_patch => new_patch endif diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 3f22c09c14..d010becf27 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -567,6 +567,8 @@ subroutine init_patches( nsites, sites, bc_in) else + ! state_vector(:) = 0._r8 + sites_loop: do s = 1, nsites sites(s)%sp_tlai(:) = 0._r8 sites(s)%sp_tsai(:) = 0._r8 From b19cedf7896f0fe738380b46c33bb31ea74b167f Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 27 Apr 2023 09:30:44 -0700 Subject: [PATCH 048/250] add primary_to_primary accumulation --- biogeochem/EDPatchDynamicsMod.F90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 7e10638027..6f88e97f20 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -429,7 +429,6 @@ subroutine spawn_patches( currentSite, bc_in) use FatesConstantsMod , only : rsnbl_math_prec use FatesLandUseChangeMod, only : get_landuse_transition_rates use FatesLandUseChangeMod, only : get_landusechange_rules - ! ! !ARGUMENTS: type (ed_site_type), intent(inout) :: currentSite @@ -490,7 +489,7 @@ subroutine spawn_patches( currentSite, bc_in) ! zero the diagnostic disturbance rate fields currentSite%disturbance_rates(:,:,:) = 0._r8 - ! disturbance_rate = 0._8 + currentSite%disturbance_rates_primary_to_primary(:,:,:) = 0._r8 ! get rules for vegetation clearing during land use change call get_landusechange_rules(clearing_matrix) @@ -540,7 +539,6 @@ subroutine spawn_patches( currentSite, bc_in) disturbance_rate = currentPatch%landuse_transition_rates(i_landusechange_receiverpatchlabel) endif - ! disturbance_rate = 0._8 write(fates_log(),*) 'patch disturbance rate: ',currentPatch%disturbance_rates(i_disturbance_type) write(fates_log(),*) 'disturbance type: ', i_disturbance_type @@ -560,6 +558,12 @@ subroutine spawn_patches( currentSite, bc_in) currentSite%disturbance_rates(i_disturbance_type,i_donorpatch_landuse_type,i_landusechange_receiverpatchlabel) + & currentPatch%area * disturbance_rate * AREA_INV + ! track disturbance rates for primary to primary disturbance + if (currentPatch%land_use_label .eq. primaryland) then + currentSite%disturbance_rates_primary_to_primary(i_disturbance_type,i_donorpatch_landuse_type,i_landusechange_receiverpatchlabel) = & + currentSite%disturbance_rates_primary_to_primary(i_disturbance_type,i_donorpatch_landuse_type,i_landusechange_receiverpatchlabel) + & + currentPatch%area * disturbance_rate * AREA_INV + end if end if From 44696201f9dd9a3add7889f805d39ef82b7205ff Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Mon, 1 May 2023 16:06:59 -0700 Subject: [PATCH 049/250] removing site%disturbance_rates_primary_to_primary variable --- biogeochem/EDPatchDynamicsMod.F90 | 9 --------- main/EDTypesMod.F90 | 1 - main/FatesHistoryInterfaceMod.F90 | 6 +++--- 3 files changed, 3 insertions(+), 13 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 6f88e97f20..22f27e63a4 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -489,7 +489,6 @@ subroutine spawn_patches( currentSite, bc_in) ! zero the diagnostic disturbance rate fields currentSite%disturbance_rates(:,:,:) = 0._r8 - currentSite%disturbance_rates_primary_to_primary(:,:,:) = 0._r8 ! get rules for vegetation clearing during land use change call get_landusechange_rules(clearing_matrix) @@ -557,14 +556,6 @@ subroutine spawn_patches( currentSite, bc_in) currentSite%disturbance_rates(i_disturbance_type,i_donorpatch_landuse_type,i_landusechange_receiverpatchlabel) = & currentSite%disturbance_rates(i_disturbance_type,i_donorpatch_landuse_type,i_landusechange_receiverpatchlabel) + & currentPatch%area * disturbance_rate * AREA_INV - - ! track disturbance rates for primary to primary disturbance - if (currentPatch%land_use_label .eq. primaryland) then - currentSite%disturbance_rates_primary_to_primary(i_disturbance_type,i_donorpatch_landuse_type,i_landusechange_receiverpatchlabel) = & - currentSite%disturbance_rates_primary_to_primary(i_disturbance_type,i_donorpatch_landuse_type,i_landusechange_receiverpatchlabel) + & - currentPatch%area * disturbance_rate * AREA_INV - end if - end if end if patchlabel_matches_lutype_if_areadis diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 2ce9554e91..84c1fb7a4b 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -899,7 +899,6 @@ module EDTypesMod real(r8) :: spread ! dynamic canopy allometric term [unitless] ! site-level variables to keep track of the disturbance rates, both actual and "potential" - real(r8) :: disturbance_rates_primary_to_primary(N_DIST_TYPES,n_landuse_cats,n_landuse_cats) real(r8) :: disturbance_rates(N_DIST_TYPES,n_landuse_cats, n_landuse_cats) ! actual disturbance rates for each disturbance type [m2/m2/day] real(r8) :: primary_land_patchfusion_error ! error term in total area of primary patches associated with patch fusion [m2/m2/day] real(r8) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) ! land use transition matrix as read in from HLM and aggregated to FATES land use types [m2/m2/year] diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 2ce12c04d5..6964ee259b 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2690,13 +2690,13 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! output site-level disturbance rates [m2 m-2 day-1] -> [m2 m-2 yr-1] - TO DO rework this - hio_fire_disturbance_rate_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_primary(dtype_ifire,1:n_landuse_cats,1:n_landuse_cats)) * & + hio_fire_disturbance_rate_si(io_si) = sum(sites(s)%disturbance_rates(dtype_ifire,1:n_landuse_cats,1:n_landuse_cats)) * & days_per_year - hio_logging_disturbance_rate_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_primary(dtype_ilog,1:n_landuse_cats,1:n_landuse_cats)) * & + hio_logging_disturbance_rate_si(io_si) = sum(sites(s)%disturbance_rates(dtype_ilog,1:n_landuse_cats,1:n_landuse_cats)) * & days_per_year - hio_fall_disturbance_rate_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_primary(dtype_ifall,1:n_landuse_cats,1:n_landuse_cats)) * & + hio_fall_disturbance_rate_si(io_si) = sum(sites(s)%disturbance_rates(dtype_ifall,1:n_landuse_cats,1:n_landuse_cats)) * & days_per_year hio_harvest_carbonflux_si(io_si) = sites(s)%mass_balance(element_pos(carbon12_element))%wood_product * AREA_INV From ac181bc9bd605fdf1162da9ef96c23c8338757c2 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 4 May 2023 10:03:14 -0700 Subject: [PATCH 050/250] refactor land use mapping --- biogeochem/FatesLandUseChangeMod.F90 | 126 +++++++++++++-------------- 1 file changed, 59 insertions(+), 67 deletions(-) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index 268ea303cc..f267fbdc8e 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -9,6 +9,7 @@ module FatesLandUseChangeMod use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue, ifalse + use FatesConstantsMod , only : fates_unset_int use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_use_luh use FatesInterfaceTypesMod , only : hlm_num_luh2_states @@ -25,16 +26,32 @@ module FatesLandUseChangeMod character(len=*), parameter :: sourcefile = __FILE__ - ! public :: get_landuse_transition_rates - public :: init_luh2_fates_mapping public :: get_landusechange_rules public :: get_luh_statedata ! module data integer, parameter :: max_luh2_types_per_fates_lu_type = 5 - CHARACTER(len=5), protected, DIMENSION(n_landuse_cats,max_luh2_types_per_fates_lu_type) :: luh2_fates_luype_map + + ! Define the mapping from the luh2 state names to the aggregated fates land use categories + type :: luh2_fates_lutype_map + + character(len=5), dimension(12) :: state_names = & + [character(len=5) :: 'primf','primn','secdf','secdn', & + 'pastr','range', 'urban', & + 'c3ann','c4ann','c3per','c4per','c3nfx'] + integer, dimension(12) :: landuse_categories = & + [primaryland, primaryland, secondaryland, secondaryland, & + pastureland, rangeland, fates_unset_int, & + cropland, cropland, cropland, cropland, cropland] + + contains + + ! procedure :: Init => init_luh2_fates_mapping + procedure :: GetIndex => GetLUH2CategoryFromStateName + + end type luh2_fates_lutype_map ! 03/10/2023 Created By Charlie Koven @@ -55,6 +72,7 @@ subroutine get_landuse_transition_rates(bc_in, landuse_transition_matrix) real(r8), intent(inout) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) ! [m2/m2/year] ! !LOCAL VARIABLES: + type(luh2_fates_lutype_map) :: lumap integer :: i_donor, i_receiver, i_luh2_transitions, i_luh2_states character(5) :: donor_name, receiver_name character(14) :: transition_name @@ -67,70 +85,41 @@ subroutine get_landuse_transition_rates(bc_in, landuse_transition_matrix) !!may need some logic here to ask whether or not ot perform land use cahnge on this timestep. current code occurs every day. - ! identify urban fraction so that it can be removed. - urban_fraction = 0._r8 - do i_luh2_states = 1, hlm_num_luh2_states - if (bc_in%hlm_luh_state_names(i_luh2_states) .eq. 'urban') then - urban_fraction = bc_in%hlm_luh_states(i_luh2_states) - end if - end do - - ! loop over FATES donor and receiver land use types - donor_loop: do i_donor = 1,n_landuse_cats - receiver_loop: do i_receiver = 1,n_landuse_cats - - ! ignore diagonals of transition matrix - not_diagonal: if ( i_donor .ne. i_receiver ) then + ! identify urban fraction so that it can be accounted for in the fates land use aggregation + urban_fraction = bc_in%hlm_luh_states(findloc(bc_in%hlm_luh_state_names,'urban',dim=1)) - ! ignore special case of primary -> secondary, which is handled by harvest mechanism - not_primary_to_secondary: if ( .not. ((i_donor .eq. primaryland) .and. (i_receiver .eq. secondaryland)) ) then + transitions_loop: do i_luh2_transitions = 1, hlm_num_luh2_transitions - transitions_loop: do i_luh2_transitions = 1, hlm_num_luh2_transitions + ! transition names are written in form xxxxx_to_yyyyy where x and y are donor and receiver state names + transition_name = bc_in%hlm_luh_transition_names(i_luh2_transitions) + donor_name = transition_name(1:5) + receiver_name = transition_name(10:14) - ! transition names are written in form xxxxx_to_yyyyy where x and y are donor and receiver state names - transition_name = bc_in%hlm_luh_transition_names(i_luh2_transitions) - donor_name = transition_name(1:5) - receiver_name = transition_name(10:14) + ! Get the fates land use type index associated with the luh2 state types + i_donor= lumap%GetIndex(donor_name) + i_receiver = lumap%GetIndex(receiver_name) - if (any(luh2_fates_luype_map(:,i_donor) == donor_name) .and. & - any(luh2_fates_luype_map(:,i_receiver) == receiver_name)) then + ! Avoid transitions with 'urban' as those are handled seperately + if (i_donor .ne. fates_unset_int .or. i_receiver .ne. fates_unset_int) then + landuse_transition_matrix(i_donor,i_receiver) = & + landuse_transition_matrix(i_donor,i_receiver) + bc_in%hlm_luh_transitions(i_luh2_transitions) / (1._r8 - urban_fraction) - landuse_transition_matrix(i_donor,i_receiver) = & - landuse_transition_matrix(i_donor,i_receiver) + bc_in%hlm_luh_transitions(i_luh2_transitions) / (1._r8 - urban_fraction) - - end if - end do transitions_loop - end if not_primary_to_secondary - end if not_diagonal - end do receiver_loop - end do donor_loop + end if + end do transitions_loop end if use_luh_if end subroutine get_landuse_transition_rates !---------------------------------------------------------------------------------------------------- - subroutine init_luh2_fates_mapping + function GetLUH2CategoryFromStateName(this, state_name) result(landuse_category) - ! initialize the character mapping of the LUH2 : FATES correspondance - luh2_fates_luype_map(:,:) = '' - - luh2_fates_luype_map(1,primaryland) = 'primf' - luh2_fates_luype_map(2,primaryland) = 'primn' + class(luh2_fates_lutype_map) :: this + character(len=5), intent(in) :: state_name + integer :: landuse_category - luh2_fates_luype_map(1, secondaryland) = 'secdf' - luh2_fates_luype_map(2, secondaryland) = 'secdn' + landuse_category = this%landuse_categories(findloc(this%state_names,state_name,dim=1)) - luh2_fates_luype_map(1,cropland) = 'c3ann' - luh2_fates_luype_map(2,cropland) = 'c4ann' - luh2_fates_luype_map(3,cropland) = 'c3per' - luh2_fates_luype_map(4,cropland) = 'c4per' - luh2_fates_luype_map(5,cropland) = 'c3nfx' - - luh2_fates_luype_map(1,pastureland) = 'pastr' - - luh2_fates_luype_map(1,rangeland) = 'range' - - end subroutine init_luh2_fates_mapping + end function GetLUH2CategoryFromStateName !---------------------------------------------------------------------------------------------------- @@ -221,6 +210,9 @@ subroutine get_luh_statedata(bc_in, state_vector) type(bc_in_type) , intent(in) :: bc_in real(r8), intent(out) :: state_vector(n_landuse_cats) ! [m2/m2] + + ! LOCALS + type(luh2_fates_lutype_map) :: lumap real(r8) :: urban_fraction integer :: i_luh2_states integer :: ii @@ -229,23 +221,23 @@ subroutine get_luh_statedata(bc_in, state_vector) ! zero state vector state_vector(:) = 0._r8 - ! identify urban fraction so that it can be removed. - urban_fraction = 0._r8 - do i_luh2_states = 1, hlm_num_luh2_states - if (bc_in%hlm_luh_state_names(i_luh2_states) .eq. 'urban') then - urban_fraction = bc_in%hlm_luh_states(i_luh2_states) - end if - end do + ! identify urban fraction so that it can be factored into the land use state output + urban_fraction = bc_in%hlm_luh_states(findloc(bc_in%hlm_luh_state_names,'urban',dim=1)) ! loop over all states and add up the ones that correspond to a given fates land use type do i_luh2_states = 1, hlm_num_luh2_states + + ! Get the luh2 state name and determine fates aggregated land use + ! type index from the state to lutype map state_name = bc_in%hlm_luh_state_names(i_luh2_states) - do ii = 1, max_luh2_types_per_fates_lu_type - if (state_name .eq. luh2_fates_luype_map(i_luh2_states, ii)) then - state_vector(i_luh2_states) = state_vector(i_luh2_states) + & - bc_in%hlm_luh_states(i_luh2_states) / (1._r8 - urban_fraction) - end if - end do + ii = lumap%GetIndex(state_name) + + ! Avoid 'urban' states whose indices have been given unset values + if (ii .ne. fates_unset_int) then + state_vector(ii) = state_vector(ii) + & + bc_in%hlm_luh_states(i_luh2_states) / (1._r8 - urban_fraction) + end if + ! end do end do ! check to ensure total area == 1, and correct if not From 7bc6e4cb0c5ff19a0c2230ccea2c2b9431754dfb Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 4 May 2023 10:06:12 -0700 Subject: [PATCH 051/250] remove comment and update getindex fullname --- biogeochem/FatesLandUseChangeMod.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index f267fbdc8e..1b6d114722 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -48,8 +48,7 @@ module FatesLandUseChangeMod contains - ! procedure :: Init => init_luh2_fates_mapping - procedure :: GetIndex => GetLUH2CategoryFromStateName + procedure :: GetIndex => GetLUCategoryFromStateName end type luh2_fates_lutype_map From e69d6e3fa25fde3e8993902eee2bbf0ec4cba9ca Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 4 May 2023 10:27:26 -0700 Subject: [PATCH 052/250] align procedure names --- biogeochem/FatesLandUseChangeMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index 1b6d114722..fb90f2fa6f 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -110,7 +110,7 @@ end subroutine get_landuse_transition_rates !---------------------------------------------------------------------------------------------------- - function GetLUH2CategoryFromStateName(this, state_name) result(landuse_category) + function GetLUCategoryFromStateName(this, state_name) result(landuse_category) class(luh2_fates_lutype_map) :: this character(len=5), intent(in) :: state_name @@ -118,7 +118,7 @@ function GetLUH2CategoryFromStateName(this, state_name) result(landuse_category) landuse_category = this%landuse_categories(findloc(this%state_names,state_name,dim=1)) - end function GetLUH2CategoryFromStateName + end function GetLUCategoryFromStateName !---------------------------------------------------------------------------------------------------- From 1a7fdb1f7db78c917d3aef24cc023f246b86a4e0 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 15 May 2023 10:28:47 -0400 Subject: [PATCH 053/250] Added two-stream code and common globals --- radiation/FatesRadiationMemMod.F90 | 64 + radiation/FatesTwoStreamInterfaceMod.F90 | 522 +++++++ radiation/TwoStreamMLPEMod.F90 | 1569 ++++++++++++++++++++++ 3 files changed, 2155 insertions(+) create mode 100644 radiation/FatesRadiationMemMod.F90 create mode 100644 radiation/FatesTwoStreamInterfaceMod.F90 create mode 100644 radiation/TwoStreamMLPEMod.F90 diff --git a/radiation/FatesRadiationMemMod.F90 b/radiation/FatesRadiationMemMod.F90 new file mode 100644 index 0000000000..b0c208e5a6 --- /dev/null +++ b/radiation/FatesRadiationMemMod.F90 @@ -0,0 +1,64 @@ +Module FatesRadiationMemMod + + ! --------------------------------------------------------------------------- + ! This module is a space that holds data that defines how + ! FATES in particular uses its radiation schemes. + ! + ! Alternatively, the TwoStreamMLPEMod is more agnostic. + ! For instance, TwoStreamMLPEMod makes no assumptions about + ! which or how many broad bands are used + ! + ! For now, this module also holds relevant data for Norman radiation + ! --------------------------------------------------------------------------- + + integer, parameter :: r8 = selected_real_kind(12) + + + integer, parameter, public :: norman_solver = 1 + integer, parameter, public :: twostr_solver = 2 + integer, parameter, public :: rad_solver = norman_solver + + + integer, parameter, public :: num_rad_stream_types = 2 ! The number of radiation streams used (direct/diffuse) + + integer, parameter, public :: idirect = 1 ! This is the array index for direct radiation + integer, parameter, public :: idiffuse = 2 ! This is the array index for diffuse radiation + + + ! TODO: we use this cp_maxSWb only because we have a static array q(size=2) of + ! land-ice abledo for vis and nir. This should be a parameter, which would + ! get us on track to start using multi-spectral or hyper-spectral (RGK 02-2017) + + integer, parameter, public :: num_swb = 2 ! Number of shortwave bands we use + ! This needs to match what is used in the host model + ! This is visible (1) and near-infrared (2) + + integer, parameter, public :: ivis = 1 ! This is the array index for short-wave + ! radiation in the visible spectrum, as expected + ! in boundary condition files and parameter + ! files. This will be compared with + ! the HLM's expectation in FatesInterfaceMod + + integer, parameter, public :: inir = 2 ! This is the array index for short-wave + ! radiation in the near-infrared spectrum, as expected + ! in boundary condition files and parameter + ! files. This will be compared with + ! the HLM's expectation in FatesInterfaceMod + + integer, parameter, public :: ipar = ivis ! The photosynthetically active band + ! can be approximated to be equal to the visible band + + ! albedo land ice by waveband (1=vis, 2=nir) + real(r8), public :: alb_ice(num_swb) = (/ 0.80_r8, 0.55_r8 /) + + ! albedo land ice by waveband (1=vis, 2=nir) + real(r8), public :: rho_snow(num_swb) = (/ 0.80_r8, 0.55_r8 /) + + ! albedo land ice by waveband (1=vis, 2=nir) + real(r8), public :: tau_snow(num_swb) = (/ 0.01_r8, 0.01_r8 /) + + + + + +end Module FatesRadiationMemMod diff --git a/radiation/FatesTwoStreamInterfaceMod.F90 b/radiation/FatesTwoStreamInterfaceMod.F90 new file mode 100644 index 0000000000..53c1f18cc6 --- /dev/null +++ b/radiation/FatesTwoStreamInterfaceMod.F90 @@ -0,0 +1,522 @@ +Module FatesTwoStreamInterfaceMod + + ! This module holds routines that are specific to connecting FATES with + ! the two-stream radiation module. These routines are used to + ! describe the scattering elements from cohort and patch data, and are + ! used to decompose the scattering elements to return values + ! at the cohort, or patch-pft scale. + use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : ifalse + use FatesConstantsMod , only : itrue + use FatesConstantsMod , only : nearzero + use shr_log_mod , only : errMsg => shr_log_errMsg + use FatesGlobals , only : fates_log + use FatesGlobals , only : endrun => fates_endrun + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use FatesInterfaceTypesMod, only : numpft,hlm_numSWb + use FatesRadiationMemMod , only : ivis, inir + use FatesRadiationMemMod , only : rho_snow,tau_snow + use TwoStreamMLPEMod , only : air_ft, AllocateRadParams, rad_params + use EDTypesMod , only : ed_patch_type, ed_cohort_type, ed_site_type + use EDTypesMod , only : nclmax + use TwoStreamMLPEMod , only : twostream_type + use TwoStreamMLPEMod , only : ParamPrep + use TwoStreamMLPEMod , only : AllocateRadParams + use TwoStreamMLPEMod , only : rel_err_thresh,area_err_thresh + use EDPftvarcon , only : EDPftvarcon_inst + use FatesRadiationMemMod , only : rad_solver,twostr_solver + use FatesAllometryMod , only : VegAreaLayer + + + implicit none + + logical, parameter :: debug = .false. ! local debug flag + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + + public :: FatesConstructRadElements + public :: FatesGetCohortAbsRad + public :: FatesPatchFsun + public :: CheckPatchRadiationBalance + +contains + + + subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) + + type(ed_site_type) :: site + type(ed_patch_type),pointer :: patch + real(r8) :: fcansno_pa(:) + real(r8) :: coszen_pa(:) + + type(ed_cohort_type), pointer :: cohort + integer :: n_col(nclmax) ! Number of parallel column elements per layer + integer :: ican,ft,icol + type(twostream_type), pointer :: twostr + + + ! DO NOT MAKE CANOPY_OPEN_FRAC >0 UNTIL LAI COMPRESSION + ! HAS BEEN THOUGHT THROUGH. WE CANT JUST DECREASE THE + ! AREA WITHOUT CONSERVING TOTAL LEAF AND STEM AREA + real(r8), parameter :: canopy_open_frac = 0.00_r8 + + integer :: maxcol + real(r8) :: canopy_frac(5) + integer :: ifp + ! Area indices for the cohort [m2 media / m2 crown footprint] + real(r8) :: elai_cohort,tlai_cohort,esai_cohort,tsai_cohort + real(r8) :: vai_top,vai_bot ! veg area index at top and bottom of cohort (dummy vars) + + real(r8) :: area_ratio ! If elements are over 100% of available + ! canopy area, this is how much we squeeze + ! the area down by, as a ratio. This is also + ! applied to increase LAI and SAI in the cohorts + ! and elements as well (to preserve mass and volume). + + + ! These parameters are not used yet + !real(r8) :: max_vai_diff_per_elem ! The maximum vai difference in any element + ! ! between the least and most vai of constituting + ! ! cohorts. THe objective is to reduce this. + !integer, parameter :: max_el_per_layer = 10 + !real(r8), parameter :: init_max_vai_diff_per_elem = 0.2_r8 + !type(ed_cohort_type), pointer :: elem_co_ptrs(ncl*max_el_per_layer,100) + + + if(rad_solver.ne.twostr_solver)return + + ifp=0 + patch => site%oldest_patch + do while (associated(patch)) + ifp=ifp+1 + associate(twostr => patch%twostr) + + ! Identify how many elements we need, and possibly consolidate + ! cohorts into elements where they are very similar (LAI and PFT) + ! ------------------------------------------------------------------------------------------- + + !max_vai_diff_per_elem = init_max_vai_diff_per_elem + !iterate_count_do: do while(iterate_element_count)then + + ! Identify how many elements we need + n_col(1:nclmax) = 0 + cohort => patch%tallest + do while (associated(cohort)) + ft = cohort%pft + ican = cohort%canopy_layer + n_col(ican) = n_col(ican) + 1 + cohort => cohort%shorter + enddo + + ! If there is only one layer, then we don't + ! need to add an air element to the only + ! layer. This is because all non-veg + ! area will be attributed to a ground patch + ! But if there is more than one layer, then + ! an air element is needed for all the non + ! occupied space, even if the canopy_open_frac + ! is zero. + + if(patch%total_canopy_area>nearzero)then + canopy_frac(:) = 0._r8 + cohort => patch%tallest + do while (associated(cohort)) + ican = cohort%canopy_layer + canopy_frac(ican) = canopy_frac(ican) + cohort%c_area/patch%total_canopy_area + cohort => cohort%shorter + enddo + else + canopy_frac(:) = 0._r8 + end if + + do ican = 1,patch%ncl_p + if( (1._r8-canopy_frac(ican))>area_err_thresh ) then + n_col(ican) = n_col(ican) + 1 + end if + end do + + + ! Handle memory + ! If the two-stream object is not large enough + ! or if it is way larger than what is needed + ! re-allocate the object + ! ------------------------------------------------------------------------------------------- + + maxcol = 0 + do ican = 1,patch%ncl_p + if (n_col(ican)>maxcol) maxcol=n_col(ican) + end do + + if(.not.associated(twostr%scelg)) then + + call twostr%AllocInitTwoStream((/ivis,inir/),patch%ncl_p,maxcol+2) + + else + + if(ubound(twostr%scelg,2) < maxcol .or. & + ubound(twostr%scelg,2) > (maxcol+4) .or. & + ubound(twostr%scelg,1) < patch%ncl_p ) then + + call twostr%DeallocTwoStream() + + ! Add a little more space than necessary so + ! we don't have to keep allocating/deallocating + call twostr%AllocInitTwoStream((/ivis,inir/),patch%ncl_p,maxcol+2) + + end if + + end if + + + ! Fill the elements with their basic data and + ! reference the cohort to the elements + ! ------------------------------------------------------------------------------------------- + + n_col(1:nclmax) = 0 + cohort => patch%tallest + do while (associated(cohort)) + + ft = cohort%pft + ican = cohort%canopy_layer + + patch%canopy_mask(ican,ft) = 1 + + ! Every cohort gets its own element right now + n_col(ican) = n_col(ican)+1 + + ! If we pass layer index 0 to this routine + ! it will return the total plant LAIs and SAIs + call VegAreaLayer(cohort%treelai, & + cohort%treesai, & + cohort%hite, & + 0, & + cohort%nv, & + cohort%pft, & + site%snow_depth, & + vai_top, vai_bot, & + elai_cohort,esai_cohort) + + twostr%scelg(ican,n_col(ican))%pft = ft + twostr%scelg(ican,n_col(ican))%area = cohort%c_area/patch%total_canopy_area + twostr%scelg(ican,n_col(ican))%lai = elai_cohort + twostr%scelg(ican,n_col(ican))%sai = esai_cohort + + ! Cohort needs to know which column its in + cohort%twostr_col = n_col(ican) + + cohort => cohort%shorter + enddo + + + do ican = 1,patch%ncl_p + + ! If the canopy is not full, add an air element + if( (1._r8-canopy_frac(ican))>area_err_thresh ) then + n_col(ican) = n_col(ican) + 1 + twostr%scelg(ican,n_col(ican))%pft = air_ft + twostr%scelg(ican,n_col(ican))%area = 1._r8-canopy_frac(ican) + twostr%scelg(ican,n_col(ican))%lai = 0._r8 + twostr%scelg(ican,n_col(ican))%sai = 0._r8 + end if + + ! If the layer is overfull, remove some from area from + ! the first element + ! THIS DOES HELP IMPROVE ENERGY CONSERVATION ON THE + ! ELEMENT VERSUS TOTAL AREA CHECK, BUT JUST PASSES + ! ERROR TO THE CHECK OF ENERGY CONSERVATION WITH + ! FATES COHORTS... THE SOLUTION IS TO HAVE + ! HIGHER PRECISION ON + if( (1._r8-canopy_frac(ican))<-area_err_thresh ) then + + !twostr%scelg(ican,1)%area = & + ! twostr%scelg(ican,1)%area + (1._r8-canopy_frac(ican)) + !new_area = twostr%scelg(ican,1)%area + (1._r8-canopy_frac(ican)) + area_ratio = (twostr%scelg(ican,1)%area + (1._r8-canopy_frac(ican)))/twostr%scelg(ican,1)%area + + twostr%scelg(ican,1)%area = twostr%scelg(ican,1)%area * area_ratio + twostr%scelg(ican,1)%lai = twostr%scelg(ican,1)%lai / area_ratio + twostr%scelg(ican,1)%sai = twostr%scelg(ican,1)%sai / area_ratio + + + + end if + + end do + + ! Go ahead an temporarily squeeze crown areas + + cohort => patch%tallest + do while (associated(cohort)) + ican = cohort%canopy_layer + icol = cohort%twostr_col + if( (cohort%c_area/patch%total_canopy_area - twostr%scelg(ican,icol)%area) > nearzero) then + + !v_ratio = twostr%scelg(ican,icol)%area / (cohort%c_area/patch%total_canopy_area) + !c_area_new = patch%total_canopy_area*twostr%scelg(ican,icol)%area + + area_ratio = (patch%total_canopy_area*twostr%scelg(ican,icol)%area) / cohort%c_area + + cohort%c_area = cohort%c_area * area_ratio + cohort%treelai = cohort%treelai / area_ratio + cohort%treesai = cohort%treesai / area_ratio + + end if + + cohort => cohort%shorter + enddo + + + twostr%n_col(1:patch%ncl_p) = n_col(1:patch%ncl_p) + + ! Set up some non-element parameters + ! ------------------------------------------------------------------------------------------- + + twostr%n_lyr = patch%ncl_p ! Number of layers + + call twostr%GetNSCel() ! Total number of elements + + twostr%force_prep = .true. ! This signals that two-stream scattering coefficients + + ! that are dependent on geometry need to be updated + call twostr%CanopyPrep(fcansno_pa(ifp)) + call twostr%ZenithPrep(coszen_pa(ifp)) + + end associate + + + + + patch => patch%younger + end do + + return + end subroutine FatesConstructRadElements + + ! ============================================================================================= + + subroutine FatesPatchFSun(patch,fsun,laisun,laisha) + + type(ed_patch_type) :: patch + real(r8) :: fsun ! Patch average sunlit fraction + real(r8) :: laisun ! Patch average LAI of leaves in sun + real(r8) :: laisha ! Patch average LAI of leaves in shade + + integer :: ican, icol ! Canopy vertical and horizontal element index + + ! Dummy variables + real(r8) :: Rb_abs,Rd_abs,Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow + + real(r8) :: leaf_sun_frac ! Element specific sunlit fraction of leaf + real(r8) :: in_fab + + laisun = 0._r8 + laisha = 0._r8 + + associate(twostr => patch%twostr) + + + do ican = 1,twostr%n_lyr + do icol = 1,twostr%n_col(ican) + + associate(scelg => patch%twostr%scelg(ican,icol)) + + call twostr%GetAbsRad(ican,icol,ivis,0._r8,scelg%lai+scelg%sai, & + Rb_abs,Rd_abs,Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow,leaf_sun_frac) + + laisun = laisun + scelg%area*scelg%lai*leaf_sun_frac + laisha = laisha + scelg%area*scelg%lai*(1._r8-leaf_sun_frac) + end associate + end do + end do + + if((laisun+laisha)>nearzero)then + fsun = laisun / (laisun+laisha) + else + fsun = 0.5_r8 ! Nominal value, should not affect results if no leaves or light! + end if + + end associate + return + end subroutine FatesPatchFSun + + ! ============================================================================================ + + subroutine CheckPatchRadiationBalance(patch, snow_depth, ib, fabd, fabi) + + ! Loop through the cohorts in the patch, get the + ! absorbed radiation, then compare the amount absorbed + ! to the fraction the solver calculated + + + type(ed_patch_type) :: patch + integer :: ib ! broadband index + real(r8) :: snow_depth + real(r8) :: fabd ! Fraction of absorbed direct radiation by vegetation + real(r8) :: fabi ! Fraction of absorbed indirect radiation by vegetation + + type(ed_cohort_type), pointer :: cohort + integer :: iv,ican,icol + real(r8),dimension(50) :: cohort_vaitop + real(r8),dimension(50) :: cohort_vaibot + real(r8),dimension(50) :: cohort_layer_elai + real(r8),dimension(50) :: cohort_layer_esai + real(r8) :: cohort_elai + real(r8) :: cohort_esai + real(r8) :: rb_abs,rd_abs,rb_abs_leaf,rd_abs_leaf,leaf_sun_frac,check_fab,in_fab + + associate(twostr => patch%twostr) + + check_fab = 0._r8 + + cohort => patch%tallest + do while (associated(cohort)) + + do iv = 1,cohort%nv + call VegAreaLayer(cohort%treelai, & + cohort%treesai, & + cohort%hite, & + iv, & + cohort%nv, & + cohort%pft, & + snow_depth, & + cohort_vaitop(iv), & + cohort_vaibot(iv), & + cohort_layer_elai(iv), & + cohort_layer_esai(iv)) + end do + + cohort_elai = sum(cohort_layer_elai(1:cohort%nv)) + cohort_esai = sum(cohort_layer_esai(1:cohort%nv)) + + do iv = 1,cohort%nv + + ican = cohort%canopy_layer + icol = cohort%twostr_col + + call FatesGetCohortAbsRad(patch,cohort,ib,cohort_vaitop(iv),cohort_vaibot(iv), & + cohort_elai,cohort_esai,rb_abs,rd_abs,rb_abs_leaf,rd_abs_leaf,leaf_sun_frac ) + + check_fab = check_fab + (Rb_abs+Rd_abs) * cohort%c_area/patch%total_canopy_area + + end do + cohort => cohort%shorter + enddo + + in_fab = fabd*twostr%band(ib)%Rbeam_atm + fabi*twostr%band(ib)%Rdiff_atm + + if( abs(check_fab-in_fab) > in_fab*10._r8*rel_err_thresh ) then + write(fates_log(),*)'Absorbed radiation didnt balance after cohort sum' + write(fates_log(),*) ib,in_fab,check_fab + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + end associate + + return + end subroutine CheckPatchRadiationBalance + + ! ============================================================================================= + + subroutine FatesGetCohortAbsRad(patch,cohort,ib,vaitop,vaibot,cohort_elai,cohort_esai, & + rb_abs,rd_abs,rb_abs_leaf,rd_abs_leaf,leaf_sun_frac ) + + ! This subroutine retrieves the absorbed radiation on + ! leaves and stems, as well as the leaf sunlit fraction + ! over a specified interval of VAI (vegetation area index) + ! VAI is exposed leaf + stem area index + + type(ed_patch_type) :: patch + type(ed_cohort_type) :: cohort + integer,intent(in) :: ib + real(r8),intent(in) :: vaitop + real(r8),intent(in) :: vaibot + real(r8),intent(in) :: cohort_elai + real(r8),intent(in) :: cohort_esai + real(r8),intent(out) :: rb_abs + real(r8),intent(out) :: rd_abs + real(r8),intent(out) :: rb_abs_leaf + real(r8),intent(out) :: rd_abs_leaf + real(r8),intent(out) :: leaf_sun_frac + + real(r8) :: rd_abs_el,rb_abs_el + real(r8) :: vai_top_el + real(r8) :: vai_bot_el + real(r8) :: rd_abs_leaf_el + real(r8) :: rb_abs_leaf_el + real(r8) :: r_abs_stem_el + real(r8) :: r_abs_snow_el + real(r8) :: diff_wt_leaf,diff_wt_elem + real(r8) :: beam_wt_leaf,beam_wt_elem + real(r8) :: evai_cvai ! element VAI / cohort VAI + + associate(scelg => patch%twostr%scelg(cohort%canopy_layer,cohort%twostr_col), & + scelb => patch%twostr%band(ib)%scelb(cohort%canopy_layer,cohort%twostr_col) ) + + evai_cvai = (scelg%lai+scelg%sai)/(cohort_elai+cohort_esai) + + if(abs(evai_cvai-1._r8)>1.e-8_r8)then + print*,"EVAI_CVAI: ",evai_cvai + stop + end if + + ! Convert the vai coordinate from the cohort to the element + vai_top_el = vaitop * evai_cvai + vai_bot_el = vaibot * evai_cvai + + ! Return the absorbed radiation for the element over that band + call patch%twostr%GetAbsRad(cohort%canopy_layer,cohort%twostr_col,ib,vai_top_el,vai_bot_el, & + Rb_abs_el,Rd_abs_el,rd_abs_leaf_el,rb_abs_leaf_el,r_abs_stem_el,r_abs_snow_el,leaf_sun_frac) + + rd_abs = rd_abs_el / evai_cvai + rb_abs = rb_abs_el / evai_cvai + + diff_wt_leaf = (1._r8-patch%twostr%frac_snow)*cohort_elai*(1._r8-rad_params%om_leaf(ib,cohort%pft))*rad_params%Kd_leaf(cohort%pft) + diff_wt_elem = (cohort_elai+cohort_esai)*(1._r8-scelb%om)*scelg%Kd + + beam_wt_leaf = (1._r8-patch%twostr%frac_snow)*cohort_elai*(1._r8-rad_params%om_leaf(ib,cohort%pft))*scelg%Kb_leaf + beam_wt_elem = (cohort_elai+cohort_esai)*(1._r8-scelb%om)*scelg%Kb + + !print*,"---" + !print*,diff_wt_leaf,diff_wt_elem + !print*,cohort_elai,cohort_esai + !print*,rad_params%om_leaf(ib,cohort%pft),rad_params%Kd_leaf(cohort%pft) + !print*,scelb%om,scelg%Kd + + + rd_abs_leaf = rd_abs * min(1.0_r8,diff_wt_leaf / diff_wt_elem) + rb_abs_leaf = rb_abs * min(1.0_r8,beam_wt_leaf / beam_wt_elem) + + + end associate + end subroutine FatesGetCohortAbsRad + + ! ============================================================================================= + + subroutine TransferRadParams() + + integer :: ft,ib ! loop indices + + call AllocateRadParams(numpft,hlm_numSWb) + + do ft = 1,numpft + do ib = 1,hlm_numSWb + + rad_params%rhol(ib,ft) = EDPftvarcon_inst%rhol(ft,ib) + rad_params%rhos(ib,ft) = EDPftvarcon_inst%rhos(ft,ib) + rad_params%taul(ib,ft) = EDPftvarcon_inst%taul(ft,ib) + rad_params%taus(ib,ft) = EDPftvarcon_inst%taus(ft,ib) + + end do + rad_params%xl(ft) = EDPftvarcon_inst%xl(ft) + rad_params%clumping_index(ft) = EDPftvarcon_inst%clumping_index(ft) + end do + + call ParamPrep() + + return + end subroutine TransferRadParams + + +end Module FatesTwoStreamInterfaceMod diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 new file mode 100644 index 0000000000..000136108b --- /dev/null +++ b/radiation/TwoStreamMLPEMod.F90 @@ -0,0 +1,1569 @@ +Module TwoStreamMLPEMod + + ! This module holds the routines to calculate two-tream + ! radiation scattering of vegetation in + ! "M"ultiple "L"ayers with "P"arellel "E"lements "MLPE" + ! + ! In summary, + ! there may numerous canopy layers. In each canopy layer, + ! plant media for different functional types are grouped + ! so that they inhabit their own exclusive footprint + ! within the layer. Within these exclusive functional + ! columns, there are further sub-layer discretizations, + ! which are organized by top-down integrated vegetation + ! area index. + ! + ! Note that there is a separate allocation and call + ! sequence for each broad band. In other words, the + ! two_stream_type is instantiated for each broad band. + ! + ! + ! + ! Assumptions: band index 1 = visible (vis) + ! 2 = near infrared (nir) + ! 3 = thermal (not used at the moment) + ! + + implicit none + private + + integer, parameter :: r8 = selected_real_kind(12) + real(r8),parameter :: nearzero = 1.e-20_r8 + logical, parameter :: debug=.true. + logical, parameter :: use_derivation1 = .true. + real(r8), parameter :: unset_r8 = 1.e-36_r8 + real(r8), parameter :: unset_int = -999 + integer, parameter :: twostr_vis = 1 ! Named index of visible shortwave radiation + integer, parameter :: twostr_nir = 2 ! Named index for near infrared shortwave radiation + + + ! Allowable error, as a fraction of total incident for total canopy + ! radiation balance checks + + real(r8), public, parameter :: rel_err_thresh = 1.e-8_r8 + real(r8), public, parameter :: area_err_thresh = rel_err_thresh*0.1_r8 + + ! These are the codes for how the upper boundary is specified, normalized or absolute + integer,public, parameter :: normalized_upper_boundary = 1 + integer,public, parameter :: absolute_upper_boundary = 2 + + + + ! These are parameter constants, ie things that are specific to the plant material + ! and radiation band. Not all of these need to be used. 2-stream ultimately wants + ! optical depth, scattering coefficient and backscatter fractions for diffuse and + ! direct light. So there are various ways to get to these parameters, depending + ! on the host model's available parameters. The rho,tau,xl and clumping parameters + ! are standard elm/clm parameters, and provided as a convenience. + + + ! Snow optical parameter constants for visible (index=1) and NIR (index=2) + + real(r8), parameter :: betad_snow(1:2) = (/0.5, 0.5/) ! Diffuse backscatter fraction (CLM50 Tech Man) + real(r8), parameter :: betab_snow(1:2) = (/0.5, 0.5/) ! Beam backscatter fraction (CLM50 Tech Man) + real(r8), parameter :: om_snow(1:2) = (/0.8, 0.4/) ! Scattering coefficient for snow (CLM50 Tech Man) + !real(r8), parameter :: om_snow(1:2) = (/0.85, 0.75/) ! Tarboton 95 + + ! Cap the maximum optical depth. After 30 or so, its + ! so close to zero, if the values get too large, then + ! it will blow up the exponents and cause math problems + + real(r8), parameter :: kb_max = 30._r8 + + + ! For air, use a nominal values to prevent div0s + ! the key is that vai = 0 + + real(r8), parameter :: k_air = 0.5_r8 + real(r8), parameter :: om_air = 0.5_r8 + real(r8), parameter :: beta_air = 0.5_r8 + integer, public, parameter :: air_ft = 0 + + type, public :: rad_params_type + + ! From the parameter file + real(r8), allocatable :: rhol(:,:) ! leaf material reflectance: (band x pft) + real(r8), allocatable :: rhos(:,:) ! stem material reflectance: (band x pft) + real(r8), allocatable :: taul(:,:) ! leaf material transmittance: (band x pft) + real(r8), allocatable :: taus(:,:) ! stem material transmittance: (band x pft) + real(r8), allocatable :: xl(:) ! leaf/stem orientation (pft) + real(r8), allocatable :: clumping_index(:) ! clumping index 0-1, when + ! leaves stick together (pft) + + ! Derived parameters + real(r8), allocatable :: phi1(:) ! intermediate term for kd and kb + real(r8), allocatable :: phi2(:) ! intermediate term for kd and kb + real(r8), allocatable :: kd_leaf(:) ! Mean optical depth per unit area leaves in diffuse + real(r8), allocatable :: kd_stem(:) ! Mean optical depth per unit area stems in diffuse + real(r8), allocatable :: om_leaf(:,:) ! Leaf scattering coefficient (band x pft) + real(r8), allocatable :: om_stem(:,:) ! Stem scattering coefficient (band x pft) + + end type rad_params_type + + type(rad_params_type),public :: rad_params + + + ! Information describing the scattering elements + ! that is based on "g"eometry, and independent of wavelength + + type scelg_type + integer :: pft ! pft index + real(r8) :: area ! m2 col/m2 ground + real(r8) :: lai ! m2 of leaf area / m2 col + real(r8) :: sai ! m2 of stem area / m2 col + real(r8) :: Kb ! Optical depth of beam radiation + real(r8) :: Kb_leaf ! Optical depth of just leaves in beam radiation + real(r8) :: Kd ! Optical depth of diffuse radiation + real(r8) :: area_squeeze ! This is the ratio of the element area to the + ! the area of its constituents. Ideally this + ! should be 1.0, but if the host model does not + ! do a good job of filling up a canopy with 100% space, + ! and instead is fractionally more than 100%, we must + ! squeeze the area of 1 or more elements to get an exact + ! space usage. + end type scelg_type + + + ! Information describing the scattering elemnets that + ! is dependent on wavelengths, ie "b"ands (this is allocated for each broad band) + + type scelb_type + + ! Terms used in the final solution, also used for decomposing solution + real(r8) :: Au ! Compound intercept term + real(r8) :: Ad ! Compound intercept term + real(r8) :: B1u ! Compound term w/ lambdas + real(r8) :: B2u ! Compound term w/ lambdas + real(r8) :: B1d ! Compound term w/ lambdas + real(r8) :: B2d ! Compound term w/ lambdas + real(r8) :: lambda1_diff ! Compount term w/ B1d and B1u for diffuse forcing + real(r8) :: lambda2_diff ! Compound term w/ B2d and B2u for diffuse forcing + real(r8) :: lambda1_beam ! Compount term w/ B1d and B1u for beam forcing + real(r8) :: lambda2_beam ! Compound term w/ B2d and B2u for beam forcing + + real(r8) :: a ! Complex term operating on veg area index + real(r8) :: om ! scattering coefficient for media as a whole + real(r8) :: betad ! backscatter fraction of diffuse radiation for media as a whole + real(r8) :: betab ! backscatter fraction of beam radiation for media as a whole + real(r8) :: Rbeam0 ! Normalized downwelling beam radiation at + ! top of the element (relative to downwelling atmospheric beam) [-] + + end type scelb_type + + + type band_type + + type(scelb_type), pointer :: scelb(:,:) ! array of scattering coefficients (layer, column) + ! can be sparse, will only solve indices up to + integer :: ib ! band index, should be consistent with rad_params + real(r8) :: Rbeam_atm ! Downwelling beam radiation from atmosphere [W/m2 ground] + real(r8) :: Rdiff_atm ! Downwelling diffuse radiation from atmosphere [W/m2 ground] + real(r8) :: albedo_grnd_diff ! Ground albedo diffuse + real(r8) :: albedo_grnd_beam ! Ground albedo direct + + end type band_type + + + ! This type contains the pre-processed scattering coefficients + ! and routines. This is the parent type that holds almost everything + ! in the two-stream solver. + ! The scelg structure describes the scattering elements, these are values + ! that need to be defined by the ecosystem model, somewhat of + ! an input to the solver. Since this is a Perfect Plasticity Approximation + ! enabled system, we partition the scattering media into "columns" and "layers" + ! Layers are canopy layers, think understory, mid-story and upper canopy. Columns + ! are divisions of horizontal space, ie literal columns of space. The current + ! implementation limits this space to media that has uniform scattering coefficients. + ! So there could not be different PFTs in the same column, because they would undoubtedly + ! have different joint scattering coefficients at different height levels in + ! the column. Therefore, every column is connected with a PFT. + + + type, public :: twostream_type + + type(scelg_type), pointer :: scelg(:,:) ! array of scattering elements (layer, column) + ! can be sparse, will only solve indices up to + ! n_lyr,n_col(n_lyr) + + type(band_type), pointer :: band(:) ! Holds scattering coefficients for each band + ! vis,nir,etc (nothing that emits though, no thermal) + + integer :: n_bands ! number of bands (allocation size of band(:)) + integer :: n_lyr ! number of (vertical) scattering element layers + integer, allocatable :: n_col(:) ! number of (horizontal) scattering element columns per layer + integer :: n_scel ! total number of scattering elements + logical :: force_prep ! Some coefficients are only updated + ! when the canopy composition changes, ie + ! changes in leaf, stem or snow structure. + ! If so, this sets to true, signalling that diffuse + ! scattering coefficients should be updated. + ! Otherwise, we only updated zenith dependent + ! parameters on short sub-daily timesteps + real(r8) :: frac_snow ! Current mean snow-fraction of the canopy + real(r8) :: frac_snow_old ! Previous mean snow-fraction of the canopy + + contains + + procedure :: ZenithPrep ! Update coefficients as zenith changes + procedure :: CanopyPrep ! Update coefficients as canopy changes + procedure :: Solve ! Perform the scattering solution + procedure :: GetNSCel + procedure :: AllocInitTwoStream + procedure :: DeallocTwoStream + + procedure :: GetRdUp + procedure :: GetRdDn + procedure :: GetRb + procedure :: GetAbsRad + + end type twostream_type + + public :: ParamPrep + public :: AllocateRadParams + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + +contains + + subroutine AllocInitTwoStream(this,band_indices,ncan,ncol) + + class(twostream_type) :: this + integer :: band_indices(:) + integer :: ncan + integer :: ncol + + integer :: nbands + integer :: ib + + nbands = ubound(band_indices,1) + + allocate(this%n_col(ncan)) + allocate(this%scelg(ncan,ncol)) + allocate(this%band(nbands)) + + this%n_col(1:ncan) = unset_int + this%n_bands = nbands + this%n_lyr = ncan + this%frac_snow = unset_r8 + this%frac_snow_old = unset_r8 + + do ib = 1,nbands + + allocate(this%band(ib)%scelb(ncan,ncol)) + this%band(ib)%albedo_grnd_diff = unset_r8 + this%band(ib)%albedo_grnd_beam = unset_r8 + this%band(ib)%ib = band_indices(ib) + + end do + + + + return + end subroutine AllocInitTwoStream + + ! =============================================================================================== + + subroutine DeallocTwoStream(this) + + class(twostream_type) :: this + + integer :: nbands + integer :: ib + + nbands = ubound(this%band,1) + + deallocate(this%scelg) + deallocate(this%n_col) + do ib = 1,nbands + deallocate(this%band(ib)%scelb) + end do + deallocate(this%band) + + return + end subroutine DeallocTwoStream + + ! =============================================================================================== + + subroutine AllocateRadParams(n_pft,n_bands) + + integer,intent(in) :: n_pft + integer,intent(in) :: n_bands + + ! Include the zeroth pft index for air + + allocate(rad_params%rhol(n_bands,n_pft)) + allocate(rad_params%rhos(n_bands,n_pft)) + allocate(rad_params%taul(n_bands,n_pft)) + allocate(rad_params%taus(n_bands,n_pft)) + allocate(rad_params%xl(n_pft)) + allocate(rad_params%clumping_index(n_pft)) + + allocate(rad_params%phi1(n_pft)) + allocate(rad_params%phi2(n_pft)) + allocate(rad_params%kd_leaf(n_pft)) + allocate(rad_params%kd_stem(n_pft)) + allocate(rad_params%om_leaf(n_bands,n_pft)) + allocate(rad_params%om_stem(n_bands,n_pft)) + + end subroutine AllocateRadParams + + ! ================================================================================================ + + function GetRdDn(this,ican,icol,ib,vai) result(r_diff_dn) + + class(twostream_type) :: this + real(r8),intent(in) :: vai + integer,intent(in) :: ican + integer,intent(in) :: icol + integer,intent(in) :: ib + real(r8) :: r_diff_dn + + ! Rdn = Ad e−(Kbv) + Re + λ1 B1d e^(av) + λ2 B2d e^(−av) + + associate(scelb => this%band(ib)%scelb(ican,icol), & + scelg => this%scelg(ican,icol) ) + + !print*,'-----' + !print*,this%band(ib)%Rbeam_atm,this%band(ib)%Rdiff_atm + !print*,scelb%Ad,scelg%Kb,vai + !print*,scelb%B1d,scelb%lambda1_beam,scelb%a + !print*,scelb%B2d,scelb%lambda2_beam + !print*,scelb%lambda1_diff,scelb%lambda2_diff + !print*,exp(-scelg%Kb*vai) + !print*,exp(scelb%a*vai) + !print*,exp(-scelb%a*vai) + + r_diff_dn = this%band(ib)%Rbeam_atm*( & + scelb%Ad*exp(-scelg%Kb*vai) + & + scelb%B1d*scelb%lambda1_beam*exp(scelb%a*vai) + & + scelb%B2d*scelb%lambda2_beam*exp(-scelb%a*vai)) + & + this%band(ib)%Rdiff_atm*( & + scelb%B1d*scelb%lambda1_diff*exp(scelb%a*vai) + & + scelb%B2d*scelb%lambda2_diff*exp(-scelb%a*vai)) + + if(r_diff_dn.ne.r_diff_dn)then + print*,scelg%Kb + print*,scelb%a + print*,vai + print*,scelb%Ad + print*,scelb%B1d,scelb%B2d + print*,scelb%lambda1_beam,scelb%lambda2_beam + print*,scelb%lambda1_diff,scelb%lambda2_diff + print*,this%band(ib)%Rbeam_atm + print*,this%band(ib)%Rdiff_atm + print*,exp(-scelg%Kb*vai) + print*,exp(scelb%a*vai) + stop + end if + + + end associate + end function GetRdDn + + function GetRdUp(this,ican,icol,ib,vai) result(r_diff_up) + + class(twostream_type) :: this + real(r8),intent(in) :: vai + integer,intent(in) :: ican + integer,intent(in) :: icol + integer,intent(in) :: ib + real(r8) :: r_diff_up + + ! Rup = Au e−(Kbv) + Re + λ1 B1u e^(av) + λ2 B2u e^(−av) + + associate(scelb => this%band(ib)%scelb(ican,icol), & + scelg => this%scelg(ican,icol) ) + + r_diff_up = this%band(ib)%Rbeam_atm*( & + scelb%Au*exp(-scelg%Kb*vai) + & + scelb%B1u*scelb%lambda1_beam*exp(scelb%a*vai) + & + scelb%B2u*scelb%lambda2_beam*exp(-scelb%a*vai)) + & + this%band(ib)%Rdiff_atm*( & + scelb%B1u*scelb%lambda1_diff*exp(scelb%a*vai) + & + scelb%B2u*scelb%lambda2_diff*exp(-scelb%a*vai)) + + end associate + end function GetRdUp + + function GetRb(this,ican,icol,ib,vai) result(r_beam_dn) + + class(twostream_type) :: this + real(r8),intent(in) :: vai + integer,intent(in) :: ican + integer,intent(in) :: icol + integer,intent(in) :: ib + real(r8) :: r_beam_dn + + r_beam_dn = this%band(ib)%Rbeam_atm * & + this%band(ib)%scelb(ican,icol)%Rbeam0*exp(-this%scelg(ican,icol)%Kb*vai) + + end function GetRb + + subroutine GetAbsRad(this,ican,icol,ib,vai_top,vai_bot, & + Rb_abs,Rd_abs,Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow,leaf_sun_frac) + + ! This routine is used to help decompose radiation scattering + ! and return the amount of absorbed radiation. The canopy layer and column + ! index identify the element of interest. The other arguments are the upper and + ! lower bounds within the element over which to evaluate absorbed radiation. + ! The assumption is that the vegetation area index is zero at the top of the + ! element, and increases going downwards. As with all assumptions in this + ! module, the scattering parameters are uniform within the element itself, + ! which includes an assumption of the leaf/stem proportionality. + ! --------------------------------------------------------------------------- + ! Solution for radiative intensity of diffuse up and down at tai=v + ! Rup = Au e−(Kbv) + Re + λ1 B1u e^(av) + λ2 B2u e^(−av) + ! Rdn = Ad e−(Kbv) + Re + λ1 B1d e^(av) + λ2 B2d e^(−av) + ! --------------------------------------------------------------------------- + + ! Arguments + class(twostream_type) :: this + integer,intent(in) :: ican + integer,intent(in) :: icol + integer, intent(in) :: ib ! broad band index + real(r8), intent(in) :: vai_top ! veg area index (from the top of element) to start + real(r8), intent(in) :: vai_bot ! veg area index (from the top of element) to finish + real(r8), intent(out) :: Rb_abs ! total absorbed beam radiation [W/m2 ground] + real(r8), intent(out) :: Rd_abs ! total absorbed diffuse radiation [W/m2 ground] + real(r8), intent(out) :: Rb_abs_leaf ! Absorbed beam radiation from leaves [W/m2 ground] + real(r8), intent(out) :: Rd_abs_leaf ! Absorbed diff radiation from leaves [W/m2 ground] + real(r8), intent(out) :: R_abs_stem ! Absorbed beam+diff radiation stems [W/m2 ground] + real(r8), intent(out) :: R_abs_snow ! Absorbed beam+diff radiation snow [W/m2 ground] + real(r8), intent(out) :: leaf_sun_frac ! Fraction of leaves in the interval exposed + ! to sunlight + + real(r8) :: dvai,dlai ! Amount of VAI and LAI in this interval [m2/m2] + real(r8) :: Rd_net ! Difference in diffuse radiation at upper and lower boundaries [W/m2] + real(r8) :: Rb_net ! Difference in beam radiation at upper and lower boundaries [W/m2] + real(r8) :: vai_max ! total integrated (leaf+stem) area index of the current element + real(r8) :: frac_abs_snow ! fraction of radiation absorbed by snow + real(r8) :: diff_wt_leaf ! diffuse absorption weighting for leaves + real(r8) :: diff_wt_stem ! diffuse absorption weighting for stems + real(r8) :: beam_wt_leaf ! beam absorption weighting for leaves + real(r8) :: beam_wt_stem ! beam absorption weighting for stems + + + associate(scelb => this%band(ib)%scelb(ican,icol), & + scelg => this%scelg(ican,icol), & + ft => this%scelg(ican,icol)%pft ) + + ! If this is air, trivial solutions + if(ft==air_ft) then + Rb_abs = 0._r8 + Rd_abs = 0._r8 + Rb_abs_leaf = 0._r8 + Rd_abs_leaf = 0._r8 + R_abs_stem = 0._r8 + R_abs_snow = 0._r8 + leaf_sun_frac = 0._r8 + return + end if + + ! The total vegetation area index of the element + vai_max = scelg%lai + scelg%sai + + dvai = vai_bot - vai_top + dlai = dvai * scelg%lai/( scelg%lai+ scelg%sai) + + leaf_sun_frac = max(0.001_r8,min(0.999_r8,scelb%Rbeam0/ & + (dvai*scelg%Kb/rad_params%clumping_index(ft)) * (exp(-scelg%Kb*vai_top) - exp(-scelg%Kb*vai_bot)) )) + + if(debug) then + if(leaf_sun_frac>1.0_r8 .or. leaf_sun_frac<0._r8) then + print*,"impossible leaf sun fraction" + stop + end if + end if + + ! We have to disentangle the absorption between leaves and stems, we give them both + ! a weighting fraction of total absorption of area*K*(1-om) + + frac_abs_snow = this%frac_snow*(1._r8-om_snow(ib)) / (1._r8-scelb%om) + + diff_wt_leaf = scelg%lai*(1._r8-rad_params%om_leaf(ib,ft))*rad_params%Kd_leaf(ft) + diff_wt_stem = scelg%sai*(1._r8-rad_params%om_stem(ib,ft))*rad_params%Kd_stem(ft) + + beam_wt_leaf = scelg%lai*(1._r8-rad_params%om_leaf(ib,ft))*scelg%Kb_leaf + beam_wt_stem = scelg%sai*(1._r8-rad_params%om_stem(ib,ft))*1._r8 + + ! Mean element transmission coefficients adding snow scattering + + if(debug) then + if( (vai_bot-vai_max)>rel_err_thresh)then + print*,"During decomposition of the 2-stream radiation solution" + print*,"A vegetation area index (VAI) was requested in GetAbsRad()" + print*,"that is larger than the total integrated VAI of the " + print*,"computation element of interest." + print*,"vai_max: ",vai_max + print*,"vai_bot: ",vai_bot + stop + end if + if( (vai_bot-vai_top)<-rel_err_thresh ) then + print*,"During decomposition of the 2-stream radiation solution" + print*,"the vegetation area index at the lower position was set" + print*,"as greater than the value at the upper position." + print*,"vai_max: ",vai_max + print*,"vai_bot: ",vai_bot + stop + end if + end if + + ! Amount of absorbed radiation is retrieved by doing an energy + ! balance on this boundaries over the depth of interest (ie net) + ! Result is Watts / m2 of the element's area footprint NOT + ! per m2 of tissue (at least not in this step) + + Rb_net = this%GetRb(ican,icol,ib,vai_top)-this%GetRb(ican,icol,ib,vai_bot) + + Rd_net = (this%GetRdDn(ican,icol,ib,vai_top) - this%GetRdDn(ican,icol,ib,vai_bot)) + & + (this%GetRdUp(ican,icol,ib,vai_bot) - this%GetRdUp(ican,icol,ib,vai_top)) + + ! The net beam radiation includes that which is absorbed, but also, + ! that which is re-scattered, the re-scattered acts as a source + ! to the net diffuse balance and adds to the absorbed, and a sink + ! on the beam absorbed term. + + Rb_abs = Rb_net * (1._r8-this%band(ib)%scelb(ican,icol)%om) + Rd_abs = Rd_net + Rb_net * this%band(ib)%scelb(ican,icol)%om + + + Rb_abs_leaf = (1._r8-frac_abs_snow)*Rb_abs * beam_wt_leaf / (beam_wt_leaf+beam_wt_stem) + Rd_abs_leaf = (1._r8-frac_abs_snow)*Rd_abs * diff_wt_leaf / (diff_wt_leaf+diff_wt_stem) + + R_abs_snow = (Rb_abs+Rd_abs)*frac_abs_snow + + R_abs_stem = (1._r8-frac_abs_snow)* & + (Rb_abs*beam_wt_stem / (beam_wt_leaf+beam_wt_stem) + & + Rd_abs*diff_wt_stem / (diff_wt_leaf+diff_wt_stem)) + + + + + end associate + return + end subroutine GetAbsRad + + ! ================================================================================================ + + subroutine ParamPrep() + + real(r8) :: avmu ! average inverse optical depth (see Eq 3.4 CLM50 tech man) + integer :: ft + integer :: nbands + integer :: numpft + integer :: ib + + numpft = ubound(rad_params%om_leaf,2) + nbands = ubound(rad_params%om_leaf,1) + + do ft = 1,numpft + + ! The non-band specific parameters here will be re-derived for each + ! band, which is inefficient, however this is an incredibly cheap + ! routine to begin with, its only called during initialization, so + ! just let it go, dont worry about it. + + if(rad_params%xl(ft)<-0.4_r8 .or. rad_params%xl(ft)>0.6_r8) then + print*,"Leaf orientation factors (xl) should be between -0.4 and 0.6" + print*,"ft: ",ft,"xl: ",rad_params%xl(ft) + stop + end if + + ! There is a singularity of leaf orientation is exactly 0 + ! phi1 = 0.5 + ! phi2 = 0.0 + ! avmu = 1/0 (1 - 0.5/0 * ln(0.5/0.5) ) but the limit approaches 1 + ! a value of 0.0001 does not break numerics and generates an avmu of nearly 1 + + if( abs(rad_params%xl(ft)) <0.0001) rad_params%xl(ft)=0.0001_r8 + + ! There must be protections on xl to prevent div0 and other weirdness + rad_params%phi1(ft) = 0.5_r8 - 0.633_r8*rad_params%xl(ft) - 0.330_r8*rad_params%xl(ft)*rad_params%xl(ft) + rad_params%phi2(ft) = 0.877_r8 * (1._r8 - 2._r8*rad_params%phi1(ft)) !0 = horiz leaves, 1 - vert leaves. + + avmu = (1._r8/rad_params%phi2(ft))* & + (1._r8-(rad_params%phi1(ft)/rad_params%phi2(ft))* & + log((rad_params%phi2(ft)+rad_params%phi1(ft))/rad_params%phi1(ft))) + + do ib = 1, nbands + rad_params%Kd_leaf(ft) = rad_params%clumping_index(ft)/avmu + rad_params%Kd_stem(ft) = 1._r8 ! Isotropic assumption + + rad_params%om_leaf(ib,ft) = rad_params%rhol(ib,ft) + rad_params%taul(ib,ft) + rad_params%om_stem(ib,ft) = rad_params%rhos(ib,ft) + rad_params%taus(ib,ft) + end do + + end do + + return + end subroutine ParamPrep + + ! ================================================================================================ + + + ! ================================================================================================ + + subroutine CanopyPrep(this,frac_snow) + + ! Pre-process things that change with canopy-geometry or snow cover + ! We try to only run this when necessary. For instance we only + ! run this when the canopy vegetation composition changes, or + ! when the amount of snow-cover changes. + + class(twostream_type) :: this + + real(r8) :: frac_snow ! The fraction (in terms of vegetation area index) + ! of vegetation covered with snow + + ! But we check if the snow conditions + ! change during the high frequency calls + ! as well. + integer :: ib ! The band of interest + integer :: ican ! scattering element canopy layer index (top down) + integer :: icol ! scattering element column + real(r8) :: rho ! element mean material reflectance + real(r8) :: tau ! element mean material transmittance + real(r8) :: vai ! vegetation area index lai+sai + real(r8) :: om_veg ! scattering coefficient for vegetation (no snow) + real(r8) :: betad_veg ! diffuse backscatter for vegetation (no snow) + real(r8) :: betad_om ! multiplication of diffuse backscatter and reflectance + real(r8) :: area_check ! Checks to make sure each layer has 100% coverage + + this%frac_snow = frac_snow + + if(.not.this%force_prep) then + if(abs(this%frac_snow-this%frac_snow_old) this%scelg(ican,icol)%lai, & + sai => this%scelg(ican,icol)%sai, & + ft => this%scelg(ican,icol)%pft, & + scelg => this%scelg(ican,icol)) + + vai = lai + sai + + ! Mean element transmission coefficients w/o snow effects + + if(ft==0) then + scelg%Kd = k_air + else + scelg%Kd = (lai * rad_params%Kd_leaf(ft) + & + sai * rad_params%Kd_stem(ft))/vai + end if + + area_check = area_check + scelg%area + + do_bands: do ib = 1, this%n_bands + + associate(scelb => this%band(ib)%scelb(ican,icol)) + + if (ft==0) then + + scelb%om = om_air + scelb%betad = beta_air + + else + + ! Material reflectance (weighted average of leaf stem and snow) + + ! Eq. 3.11 and 3.12 ClM5.0 Tech Man + om_veg = (lai*rad_params%om_leaf(ib,ft) + & + sai*rad_params%om_stem(ib,ft))/vai + + ! Eq. 3.5 ClM5.0 Tech Man + scelb%om = this%frac_snow*om_snow(ib) + (1._r8-this%frac_snow)*om_veg + + ! Diffuse backscatter, taken from G. Bonan's code + + rho = (lai * rad_params%rhol(ib,ft) + & + sai * rad_params%rhos(ib,ft))/vai + tau = (lai * rad_params%taul(ib,ft) + & + sai * rad_params%taus(ib,ft))/vai + + ! Eq 3.13 from CLM5.0 Tech Man + betad_veg = 0.5_r8 / scelb%om * & + ( scelb%om + (rho-tau) * ((1._r8+rad_params%xl(ft))/2._r8)**2._r8 ) + + ! Eq. 3.6 from CLM5.0 Tech Man + betad_om = betad_veg*om_veg*(1._r8-this%frac_snow) + & + om_snow(ib)*betad_snow(ib)*this%frac_snow + + scelb%betad = betad_om / scelb%om + + end if + end associate + end do do_bands + end associate + end do do_col + + ! RE-ENABLE THIS CHECK WHEN FATES IS BETTER AT CONSERVING AREA!! + if(.false.)then + !if( abs(area_check-1._r8) > 10._r8*area_err_thresh )then + print*,"Only a partial canopy was specified" + print*,"Scattering elements must constitute 100% of the ground cover." + print*,"for open spaces, create an air element with the respective area." + print*,"total area (out of 1): ",area_check,ican + print*,"layer: ",ican," of: ",this%n_lyr + do icol = 1,this%n_col(ican) + print*,this%scelg(ican,icol)%area,this%scelg(ican,icol)%pft + end do + print*,"TwoStreamMLPEMod.F90:CanopyPrep" + stop + end if + + end do do_can + + return + end subroutine CanopyPrep + + ! ================================================================================================ + + subroutine ZenithPrep(this,cosz) + + ! Pre-process things that change with the zenith angle + ! i.e. the beam optical properties + + ! Important !!!! + ! This should always be called after CanopyPrep() has been + ! called. This routine relies on the results of that routine + ! notably the scattering coefficient "om". + + class(twostream_type) :: this + integer :: ib ! band index, matches indexing of rad_params + real(r8) :: cosz ! Cosine of the zenith angle + + integer :: ican ! scattering element canopy layer index (top down) + integer :: icol ! scattering element column + real(r8) :: asu ! single scattering albedo + real(r8) :: avmu ! Average inverse diffuse optical depth per unit leaf area + real(r8) :: gdir + real(r8) :: tmp0,tmp1,tmp2 + real(r8) :: betab_veg ! beam backscatter for vegetation (no snow) + real(r8) :: betab_om ! multiplication of beam backscatter and reflectance + real(r8) :: om_veg ! scattering coefficient for vegetation (no snow) + + if( (cosz-1.0) > nearzero ) then + print*,"The cosine of the zenith angle cannot exceed 1" + print*,"cosz: ",cosz + print*,"TwoStreamMLPEMod.F90:ZenithPrep" + stop + elseif(cosz<0._r8)then + print*,"The cosine of the zenith angle should not be less than zero" + print*,"It can be exactly zero, but not less than" + print*,"cosz: ",cosz + print*,"TwoStreamMLPEMod.F90:ZenithPrep" + stop + end if + + cosz = max(nearzero,cosz) + + do_ican: do ican = 1,this%n_lyr + do_ical: do icol = 1,this%n_col(ican) + + associate(ft => this%scelg(ican,icol)%pft, & + scelg => this%scelg(ican,icol)) + + if(ft==0)then + ! Simple provisions for a ghost element (air) + scelg%Kb_leaf = k_air + scelg%Kb = k_air + else + gdir = rad_params%phi1(ft) + rad_params%phi2(ft) * cosz + + !how much direct light penetrates a singleunit of lai? + scelg%Kb_leaf = min(kb_max,rad_params%clumping_index(ft) * gdir / cosz) + + !print*,"Kb_leaf: ",scelg%Kb_leaf,gdir , cosz + + + ! RGK: My sense is that snow should be adding optical depth + ! but we don't have any precedent for that in the FATES + ! code or old CLM. Re-view this. + !!scelbp%Kb = this%frac_snow*k_snow + scelbp%Kb + + scelg%Kb = min(kb_max,(scelg%lai*scelg%Kb_leaf + scelg%sai*1.0)/(scelg%lai+scelg%sai)) + + ! Eq. 3.4 CLM50 Tech Man + ! avmu is the average "av" inverse optical depth "mu" per unit leaf and stem area + + avmu = (1._r8 - rad_params%phi1(ft)/rad_params%phi2(ft) * & + log((rad_params%phi1(ft)+rad_params%phi2(ft))/rad_params%phi1(ft))) / rad_params%phi2(ft) + + ! Component terms for asu (single scatering albedo) + tmp0 = gdir + rad_params%phi2(ft) * cosz + tmp1 = rad_params%phi1(ft) * cosz + tmp2 = 1._r8 - tmp1/tmp0 * log((tmp1+tmp0)/tmp1) + + end if + + do_ib: do ib = 1,this%n_bands + + associate( scelb => this%band(ib)%scelb(ican,icol) ) + + if(ft==0)then + + ! Simple provisions for a ghost element (air) + scelb%betab = beta_air + + else + + ! betab - upscatter parameter for direct beam radiation, from G. Bonan + ! Eq. 3.16 CLM50 Tech Man + ! asu is the single scattering albedo per om_veg (material reflectance) + + asu = 0.5_r8 * gdir / tmp0 * tmp2 + + betab_veg = (1._r8 + avmu*scelg%Kb) / (avmu*scelg%Kb) * asu + + om_veg = (scelg%lai*rad_params%om_leaf(ib,ft) + & + scelg%sai*rad_params%om_stem(ib,ft))/(scelg%lai+scelg%sai) + + ! Eq. 3.7 CLM50 Tech Man + betab_om = betab_veg*om_veg*(1._r8-this%frac_snow) + & + om_snow(ib)*betab_snow(ib)*this%frac_snow + + scelb%betab = betab_om / scelb%om + + if( .not.(scelb%betab==scelb%betab))then + print*,"Beam backscatter fraction is NaN" + print*, betab_om,scelb%om,om_veg,this%frac_snow,betab_veg,asu,avmu,scelg%Kb + stop + end if + + + end if + + end associate + end do do_ib + end associate + end do do_ical + end do do_ican + + !this%band(ib)%albedo_grnd_beam = 1.e-36 ! Must fill this in + + return + end subroutine ZenithPrep + + ! ================================================================================================ + + subroutine GetNSCel(this) + + ! Simply return the total number + ! of scattering elements from the + ! multi-layer scattering element array + + class(twostream_type) :: this + integer :: ican + + this%n_scel = 0 + do ican = 1,this%n_lyr + this%n_scel = this%n_scel + this%n_col(ican) + end do + return + end subroutine GetNSCel + + ! =============================================================== + + subroutine Solve(this, ib, & + upper_boundary_type, & + Rbeam_atm, & + Rdiff_atm, & + albedo_beam, & + albedo_diff, & + frac_abs_can_beam, & + frac_abs_can_diff, & + frac_beam_grnd_beam, & + frac_diff_grnd_beam, & + frac_diff_grnd_diff) + + ! Find the scattering coefficients for two-stream radiation in the canopy. + + ! Note that these scattering coefficients are separated for scattering + ! generated by a beam radiation boundary condition, and a diffuse radiation + ! boundary conditions. Thus, we need not provide the magnitude of the forcing + ! for this step. If the user provides values of 1 for the Rbeam_atm and Rdiff_atm + ! boundary condition. It is assumed this is a normalized solution. If values + ! other than 1 are passed, we assume that it is not a normalized solution, + ! and we update the data structure values this%band(ib)%Rbeam_atm and + ! this%band(ib)%Rdiff_atm. In a normalized solution, we will leave this + ! as unset. + ! In ELM and CLM, the land-model requests an albedo and other + ! normalized output from from this algorithm for the NEXT STEP. This is + ! due to the atmospheric model needing an albedo to calculate the downwelling + ! radiation on the next step. THus, the asynchronous nature of things. That is + ! why we allow a normalized solution here. When actual absorption or flux values are + ! desired, the scattering coefficients that were determined during the normalized + ! solution are still valid when the magnitude of the downwelling beam and diffuse + ! radiation boundary conditions to the vegetation canopy are known. + + + class(twostream_type) :: this + integer :: ib ! Band of interest, matches indexing of rad_params + integer :: upper_boundary_type ! Is this a normalized(1) or absolute(2) solution? + + real(r8) :: Rbeam_atm ! Intensity of beam radiation at top of canopy [W/m2 ground] + real(r8) :: Rdiff_atm ! Intensity of diffuse radiation at top of canopy [W/m2 ground] + ! + + + + real(r8) :: albedo_beam ! Mean albedo at canopy top generated from beam radiation [-] + real(r8) :: albedo_diff ! Mean albedo at canopy top generated from downwelling diffuse [-] + real(r8) :: frac_abs_can_beam ! Fraction of incident beam radiation absorbed by the vegetation [-] + real(r8) :: frac_abs_can_diff ! Fraction of incident diffuse radiation absorbed by the vegetation [-] + real(r8) :: frac_beam_grnd_beam ! fraction of beam radiation at ground resulting from of beam at canopy top [-] + real(r8) :: frac_diff_grnd_beam ! fraction of down diffuse radiation at ground resulting from beam at canopy top + real(r8) :: frac_diff_grnd_diff ! fraction of down diffuse radiation at ground resulting from down diffuse at canopy top [-] + + ! Two stream solution arrays + ! Each of these are given generic names, because + ! they are assemblages of many terms. But generally + ! they fit the linear algebra formulation: + ! + ! TAU(:) = OMEGA(:,:) * LAMBDA(:) + ! + ! Where, we invert to solve for the coefficients LAMBDA + + !real(r8),allocatable :: OMEGA(:,:) + !real(r8),allocatable :: TAU(:) + !real(r8),allocatable :: LAMBDA(:) + + real(r8) :: OMEGA(100,100) + real(r8) :: TAU(100) + real(r8) :: LAMBDA(100) + + integer :: isol ! Solution index loop (beam, beam+diff) + integer :: ican ! Loop index for canopy layers + integer :: ibot ! layer index for top side of layer divide + integer :: itop ! layer index for bottom side of layer divide + integer :: icol ! Loop index for canopy columns + integer :: jcol ! Another loop index for canopy columns + integer :: ilem ! Index for scattering elements + integer :: k1,k2 ! Indices for the lambda terms in the OMEGA and LAMBDA array + integer :: qp ! Equation position index + integer :: n_eq ! Total number of equations + + integer :: ilem_off ! Offset, or total number of elements above layer of interest + real(r8) :: b1,b2,a2,nu_sqrd,nu ! intermediate terms, see documentation + real(r8) :: Rbeam_top ! Mean beam radiation at top of layer [W/m2] + real(r8) :: Rbeam_bot ! Mean beam radiation at bottom of layer [W/m2] + real(r8) :: vai ! Vegetation area index [m2 vegetation / m2 ground] + real(r8) :: rb_abs ! beam absorbed over an element [W/m2 ground] + real(r8) :: rd_abs ! diffuse absorbed over an element [W/m2 ground] + real(r8) :: rd_abs_leaf ! diffuse absorbed over leaves (dummy) + real(r8) :: rb_abs_leaf ! beam absorbed by leaves (dummy) + real(r8) :: r_abs_stem ! total absorbed by stems (dummy) + real(r8) :: r_abs_snow ! total absorbed by snow (dummy) + real(r8) :: leaf_sun_frac ! sunlit fraction of leaves (dummy) + real(r8) :: rel_err ! radiation canopy balance conservation + ! error, fraction of incident + + real(r8) :: beam_err,diff_err ! error partitioned by beam and diffuse + type(scelg_type),pointer :: scelgp ! Pointer to the scelg data structure + type(scelb_type),pointer :: scelbp ! Pointer to the scelb data structure + + ! Parameters for solving via LAPACK DGELS() + character(1),parameter :: trans = 'N' ! Input matrix is not transposed + integer, parameter :: workmax = 100 ! Maximum iterations to minimize work + real(r8) :: work(workmax) ! Work array + integer :: lwork ! Dimension of work array + integer :: info ! Procedure diagnostic ouput + integer :: alloc_err ! Allocation error code + ! Testing switch + ! If true, then allow elements + ! of different layers, but same row, to have priority + ! flux into the other element, instead of a mix + logical, parameter :: continuity_on = .true. + + + + ! ------------------------------------------------------------------------------------ + ! Example system of equations for 2 parallel columns in each of two canopy + ! layers. Each line is one of the balanc equations. And the x's are + ! the unknown coefficients used in those equations. 2 coefficients + ! map to each element, and read left to right. + ! EL1 is the element in top layer left column. + ! EL2 is the element in the top layer, right column + ! EL3 is the element in the bottom layer, left column + ! EL4 is the element in the bottom layer, right column + ! + ! EL1 EL2 EL3 EL4 + ! EQ: Idn balance with upper BC can1, col 1: x x + ! EQ: Idn balance with upper BC can1, col 2: x x + ! EQ: Idn balance between upper & lower x x x x x x + ! EQ: Idn balance between upper & lower x x x x x x + ! EQ: Iup balance between lower & upper x x x x x x x x + ! EQ: Iup balance between lower & upper x x x x x x x x + ! EQ: Iup/Idn balance with ground, 1st col: x x + ! EQ: Iup/Idn Balance with ground, 2nd lower col: x x + ! + ! Note: The Iup balance between layers requires ALL + ! terms, because light comes out of both + ! upper canopy elements and reflects off soil + ! AND, light upwells from both lower elements. + ! + ! -------------------------------------------------------------------------- + + ! -------------------------------------------------------------------------- + ! Beam Scattering + ! First do the direct beam stuff. It is a trivial solution + ! and is required as a boundary condition to the diffuse solver + ! All parallel layers recieve downwelling form the + ! atmosphere. + ! Rbeam0 is the upper boundary condition provided by data or another + ! model. + ! Rbeam() is the incident beam radiation at the top of each layer + ! upper canopy. + ! -------------------------------------------------------------------------- + + if((Rbeam_atm+Rdiff_atm) this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + scelbp%Rbeam0 = Rbeam_top + Rbeam_bot = Rbeam_bot + & + Rbeam_top*scelgp%area*exp(-scelgp%Kb*(scelgp%lai+scelgp%sai)) + end do + Rbeam_top = Rbeam_bot + end do + + ! Calculate element-level intermediate terms to the solve + ! These are dependent on leaf level scattering and beam scattering + ! These values will be used to populate the matrix solve + ! ===================================================================== + + do ican = 1,this%n_lyr + do icol = 1,this%n_col(ican) + + scelgp => this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + + a2 = scelgp%Kd*scelgp%Kd*(scelbp%om-1._r8)*(scelbp%om-1._r8-2._r8*scelbp%om*scelbp%betad) + + if(a2<0._r8) then + print*,'a^2 is less than zero' + stop + end if + + scelbp%a = sqrt(a2) + + b1 = (scelgp%Kd*(1._r8-scelbp%om)*(1._r8-2._r8*scelbp%betab)+scelgp%Kb) * & + scelbp%om*scelgp%Kb*scelbp%Rbeam0 + b2 = (scelgp%Kd*(scelbp%om-1._r8-2._r8*scelbp%om*scelbp%betad) - & + (1._r8-2._r8*scelbp%betab)*scelgp%Kb) * & + scelbp%om*scelgp%Kb*scelbp%Rbeam0 + + if(use_derivation1) then + + nu_sqrd = (1._r8-scelbp%om+2._r8*scelbp%om*scelbp%betad)/(1._r8-scelbp%om) + + if(nu_sqrd<0._r8)then + print*,'nu_sqrd is less than zero' + stop + end if + + ! B_1 up term from documentation: + scelbp%B1u = 0.5_r8*(1._r8+sqrt(nu_sqrd)) + + ! B_2 up term from documentation + scelbp%B2u = 0.5_r8*(1._r8-sqrt(nu_sqrd)) + + ! B_1 down term from documentation: + scelbp%B1d = -0.5_r8*(1._r8-sqrt(nu_sqrd)) + + ! B_2 down term from documentation + scelbp%B2d = -0.5_r8*(1._r8+sqrt(nu_sqrd)) + + ! A_2 term from documentation + scelbp%Ad = -0.5_r8*(b2-b1)/(scelbp%a*scelbp%a-scelgp%Kb*scelgp%Kb) ! aka half b2 minus b1 + + ! A_1 term from documentation + scelbp%Au = -0.5_r8*(b2+b1)/(scelbp%a*scelbp%a-scelgp%Kb*scelgp%Kb) ! aka half b1 plus b2 + + else + + nu_sqrd = (scelbp%om-1._r8)/(scelbp%om - 1._r8-2._r8*scelbp%om*scelbp%betad) + + nu = (scelgp%Kd*(scelbp%om-1._r8))/scelbp%a + + b1 = -b1 + + ! B 1 up term from documentation + !scelbp%B1u = 0.5_r8*(1._r8-nu) + scelbp%B1u = 0.5_r8*(1._r8-sqrt(nu_sqrd)) + + ! B_2 term from documentation + !scelbp%B2u = 0.5_r8*(1._r8+nu) + scelbp%B2u = 0.5_r8*(1._r8+sqrt(nu_sqrd)) + + ! B 1 up term from documentation + !scelbp%B1d = 0.5_r8*(1._r8+nu) + scelbp%B1d = 0.5_r8*(1._r8+sqrt(nu_sqrd)) + + ! B_2 term from documentation + !scelbp%B2d = 0.5_r8*(1._r8-nu) + scelbp%B2d = 0.5_r8*(1._r8-sqrt(nu_sqrd)) + + ! A_2 term from documentation + scelbp%Ad = -0.5_r8*(b2+b1)/(scelbp%a*scelbp%a-scelgp%Kb*scelgp%Kb) ! aka half b2 minus b1 + + ! A_1 term from documentation + scelbp%Au = -0.5_r8*(b2-b1)/(scelbp%a*scelbp%a-scelgp%Kb*scelgp%Kb) ! aka half b1 plus b2 + + + end if + end do + end do + + ! ===================================================================== + ! Set up the linear systems solver + ! + ! [TAU] = [OMEGA]*[LAMBDA] + ! OMEGA(n_equations,n_coefficients) + ! TAU(n_equations) + ! LAMBDA (n_coefficients) (the solution) + ! + ! Indexing Variables + ! ilem : element position + ! k1 : coefficient 1 position + ! k2 : coefficient 2 position + ! qp : equation position, this continues to increment + ! ===================================================================== + + n_eq = 2*this%n_scel + + ! TO-DO: MAKE THIS SCRATCH SPACE AT THE SITE LEVEL? + !!allocate(OMEGA(2*this%n_scel,2*this%n_scel),stat=alloc_err) + !!allocate(TAU(2*this%n_scel),stat=alloc_err) + !!allocate(LAMBDA(2*this%n_scel),stat=alloc_err) + + ! We come up with two solutions: + ! First: we run with now diffuse downwelling + ! radiation, this allows us to calculate + ! the canopy top albedo for beam radiation only + ! which is useful for coupling with the atmosphere + ! Second: we run with bot simultaneously, and + ! use that solution to understand everything + ! else, including the absorbed radiation + + do_isol: do isol = 1,2 + + + ! This is temporary (these need to be set + ! because this routine makes a call to get normalized + ! absorbtions to get total noramalized canopy absorbtion) + ! We will set it back to unknown following that call + + if(isol==1)then + this%band(ib)%Rbeam_atm = 1.0_r8 + this%band(ib)%Rdiff_atm = 0.0_r8 + else + this%band(ib)%Rbeam_atm = 0.0_r8 + this%band(ib)%Rdiff_atm = 1.0_r8 + end if + + if(n_eq>100)then + print*,"NEED A BIGGER MATRIX" + stop + end if + + OMEGA(1:n_eq,1:n_eq) = 0._r8 + TAU(1:n_eq) = 0._r8 + + ! -------------------------------------------------------------------- + ! I. Flux equations with the atmospheric boundary + ! These balance with all elements in the upper + ! canopy, only. The upper canopy is layer 1. + ! -------------------------------------------------------------------- + + qp = 0 ! e"Q"uation "P"osition + do icol = 1,this%n_col(1) + scelgp => this%scelg(1,icol) + scelbp => this%band(ib)%scelb(1,icol) + ilem = icol + qp = qp + 1 + k1 = 2*(ilem-1)+1 + k2 = k1+1 + TAU(qp) = this%band(ib)%Rdiff_atm - this%band(ib)%Rbeam_atm*scelbp%Ad + OMEGA(qp,k1) = scelbp%B1d + OMEGA(qp,k2) = scelbp%B2d + end do + + + if_understory: if(this%n_lyr>1) then + + + ! ------------------------------------------------------------------- + ! II. Flux equations between canopy layers, DOWNWELLING + ! We only perform flux balancing between layers + ! if we have any understory, this is true if ican>1 + ! ------------------------------------------------------------------- + ! Refer to Equation X in technical document + ! ------------------------------------------------------------ + + ! This is the index offset for the layer above the + ! current layer of interest. We start by evaluating + ! Layer 2, so the offset refers to layer 1, and a + ! value of 0 + + ilem_off = 0 + do_dn_ican: do ican = 2,this%n_lyr + + itop = ican-1 ! Top layer of the balance + ibot = ican ! Bottom layer of the balance + + ! Downwelling, includes all members from top for + ! each independant member below + + do jcol = 1,this%n_col(ibot) + + qp = qp + 1 + ilem = ilem_off + this%n_col(itop) + jcol + k1 = 2*(ilem-1)+1 + k2 = k1 + 1 + + ! Include the self terms for the current element + ! This term is at v=0 + + TAU(qp) = this%band(ib)%Rbeam_atm*this%band(ib)%scelb(ibot,jcol)%Ad + OMEGA(qp,k1) = OMEGA(qp,k1) - this%band(ib)%scelb(ibot,jcol)%B1d + OMEGA(qp,k2) = OMEGA(qp,k2) - this%band(ib)%scelb(ibot,jcol)%B2d + + ! We need to include the terms from + ! all elements above the current element of interest + ! (this can be moved out of jcol loop for efficiency) + do icol = 1,this%n_col(itop) + + ilem = ilem_off + icol + k1 = 2*(ilem-1)+1 + k2 = k1 + 1 + + scelgp => this%scelg(itop,icol) + scelbp => this%band(ib)%scelb(itop,icol) + + vai = scelgp%lai + scelgp%sai + + TAU(qp) = TAU(qp) - scelgp%area * this%band(ib)%Rbeam_atm*scelbp%Ad *exp(-scelgp%Kb*vai) + OMEGA(qp,k1) = OMEGA(qp,k1) + scelgp%area * scelbp%B1d*exp(scelbp%a*vai) + OMEGA(qp,k2) = OMEGA(qp,k2) + scelgp%area * scelbp%B2d*exp(-scelbp%a*vai) + + end do + + end do + + ilem_off = ilem_off + this%n_col(itop) + + end do do_dn_ican + + + ! ------------------------------------------------------------------- + ! III. Flux equations between canopy layers, UPWELLING + ! ------------------------------------------------------------------- + ! Refer to equation X in the technical documentation. + ! Note the upwelling balance is performed on the upper layer, + ! one equation for each element in the upper layer. + ! Note that since we use "ghost elements" or air elements + ! we don't have to factor in reflections from exposed ground. + ! These effects will be mediated through the ghost elements + ! ------------------------------------------------------------------- + + ilem_off = 0 + + do_up_ican: do ican = 2,this%n_lyr + + itop = ican-1 + ibot = ican + + do icol = 1,this%n_col(itop) + + qp = qp + 1 + + ! Self terms (ie the upwelling evaluated at the bottom edge of each top element) + ilem = ilem_off + icol + k1 = 2*(ilem-1)+1 + k2 = k1 + 1 + scelgp => this%scelg(itop,icol) + scelbp => this%band(ib)%scelb(itop,icol) + + vai = scelgp%lai + scelgp%sai + TAU(qp) = this%band(ib)%Rbeam_atm*scelbp%Au*exp(-scelgp%Kb*vai) + OMEGA(qp,k1) = OMEGA(qp,k1) - scelbp%B1u*exp(scelbp%a*vai) + OMEGA(qp,k2) = OMEGA(qp,k2) - scelbp%B2u*exp(-scelbp%a*vai) + + ! Terms for mean diffuse exiting lower elements (move out of this loop for efficiency) + do jcol = 1,this%n_col(ibot) + ilem = ilem_off + this%n_col(itop) + jcol + k1 = 2*(ilem-1)+1 + k2 = k1 + 1 + scelgp => this%scelg(ibot,jcol) + scelbp => this%band(ib)%scelb(ibot,jcol) + + TAU(qp) = TAU(qp) - this%band(ib)%Rbeam_atm*scelgp%area*scelbp%Au + OMEGA(qp,k1) = OMEGA(qp,k1) + scelgp%area*scelbp%B1u + OMEGA(qp,k2) = OMEGA(qp,k2) + scelgp%area*scelbp%B2u + end do + + end do + + ilem_off = ilem_off + this%n_col(itop) + end do do_up_ican + + + end if if_understory + + + ! Flux balance equations between the understory elements, and + ! the ground below them + ilem_off = 0 + do ican=1,this%n_lyr-1 + ilem_off = ilem_off + this%n_col(ican) + end do + + do jcol = 1,this%n_col(this%n_lyr) + + ilem = ilem_off + jcol + qp = qp + 1 + k1 = 2*(ilem-1)+1 + k2 = k1 + 1 + + scelgp => this%scelg(this%n_lyr,jcol) + scelbp => this%band(ib)%scelb(this%n_lyr,jcol) + + vai = scelgp%lai + scelgp%sai + + TAU(qp) = this%band(ib)%Rbeam_atm*(scelbp%Au*exp(-scelgp%Kb*vai) & + - this%band(ib)%albedo_grnd_diff*scelbp%Ad*exp(-scelgp%Kb*vai) & + - this%band(ib)%albedo_grnd_beam*scelbp%Rbeam0*exp(-scelgp%Kb*vai)) + + OMEGA(qp,k1) = OMEGA(qp,k1) - scelbp%B1u*exp(scelbp%a*vai) + OMEGA(qp,k2) = OMEGA(qp,k2) - scelbp%B2u*exp(-scelbp%a*vai) + + OMEGA(qp,k1) = OMEGA(qp,k1) + this%band(ib)%albedo_grnd_diff*scelbp%B1d*exp(scelbp%a*vai) + OMEGA(qp,k2) = OMEGA(qp,k2) + this%band(ib)%albedo_grnd_diff*scelbp%B2d*exp(-scelbp%a*vai) + + end do + + !print*,"TAU: ",TAU(:) + + + LAMBDA(1:n_eq) = TAU(1:n_eq) + ! Solution borrowed from Greg Lemieux's usage during FATES canopy trimming: + ! Compute the optimum size of the work array + + lwork = -1 ! Ask dgels to compute optimal number of entries for work + call dgels(trans, n_eq, n_eq, 1, OMEGA(1:n_eq,1:n_eq), n_eq, LAMBDA(1:n_eq), n_eq, work, lwork, info) + lwork = int(work(1)) ! Pick the optimum. TBD, can work(1) come back with greater than work size? + + ! Compute the minimum of 2-norm of of the least squares fit to solve for X + ! Note that dgels returns the solution by overwriting the LAMBDA array. + ! The result has the form: X = [b; m] + call dgels(trans, n_eq, n_eq, 1, OMEGA(1:n_eq,1:n_eq), n_eq, LAMBDA(1:n_eq), n_eq, work, lwork, info) + + ! Save the solution terms + + ilem_off = 0 + if(isol==1)then !Beam + do ican = 1,this%n_lyr + do icol = 1,this%n_col(ican) + ilem = ilem_off + icol + k1 = 2*(ilem-1)+1 + k2 = k1 + 1 + scelgp => this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + scelbp%lambda1_beam = LAMBDA(k1) + scelbp%lambda2_beam = LAMBDA(k2) + ! The lambda diff terms will be + ! multiplied by zero before we use them + ! but, we dont want things like nan's + ! or weird math, so we set them to zero too + scelbp%lambda1_diff = 0._r8 + scelbp%lambda2_diff = 0._r8 + end do + ilem_off = ilem_off + this%n_col(ican) + end do + else + do ican = 1,this%n_lyr + do icol = 1,this%n_col(ican) + ilem = ilem_off + icol + k1 = 2*(ilem-1)+1 + k2 = k1 + 1 + scelgp => this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + scelbp%lambda1_diff = LAMBDA(k1) + scelbp%lambda2_diff = LAMBDA(k2) + end do + ilem_off = ilem_off + this%n_col(ican) + end do + end if + + ! Process the total canopy absorbed radiation in the + ! two types of radiation, as well as the downwelling + ! flux at the ground interface + ! -------------------------------------------------------------------------------- + + if_beam: if(isol==1)then + + ican = 1 + albedo_beam = 0._r8 + do icol = 1,this%n_col(ican) + scelgp => this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + albedo_beam = albedo_beam + & + scelgp%area * this%GetRdUp(ican,icol,ib,0._r8) + end do + + frac_diff_grnd_beam = 0._r8 + frac_beam_grnd_beam = 0._r8 + ican = this%n_lyr + do icol = 1,this%n_col(ican) + scelgp => this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + frac_diff_grnd_beam = frac_diff_grnd_beam + & + scelgp%area*this%GetRdDn(ican,icol,ib,scelgp%lai+scelgp%sai) + frac_beam_grnd_beam = frac_beam_grnd_beam + & + scelgp%area*scelbp%Rbeam0*exp(-scelgp%Kb*(scelgp%lai+scelgp%sai)) + end do + + + frac_abs_can_beam = 0._r8 + do ican = 1,this%n_lyr + do icol = 1,this%n_col(ican) + scelgp => this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + call this%GetAbsRad(ican,icol,ib, 0._r8,scelgp%lai+scelgp%sai, & + rb_abs,rd_abs,rd_abs_leaf,rb_abs_leaf,r_abs_stem,r_abs_snow,leaf_sun_frac) + frac_abs_can_beam = frac_abs_can_beam + scelgp%area*(rb_abs+rd_abs) + end do + end do + + else ! Diffuse + + albedo_diff = 0._r8 + do icol = 1,this%n_col(1) + scelgp => this%scelg(1,icol) + scelbp => this%band(ib)%scelb(1,icol) + albedo_diff = albedo_diff + & + scelgp%area * this%GetRdUp(1,icol,ib,0._r8) + end do + + frac_abs_can_diff = 0._r8 + + do ican = 1,this%n_lyr + do icol = 1,this%n_col(ican) + scelgp => this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + call this%GetAbsRad(ican,icol,ib,0._r8,scelgp%lai+scelgp%sai, & + rb_abs,rd_abs,rd_abs_leaf,rb_abs_leaf,r_abs_stem,r_abs_snow,leaf_sun_frac) + frac_abs_can_diff = frac_abs_can_diff + scelgp%area*rd_abs + end do + end do + + frac_diff_grnd_diff = 0._r8 + ican = this%n_lyr + do icol = 1,this%n_col(ican) + scelgp => this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + frac_diff_grnd_diff = frac_diff_grnd_diff + & + scelgp%area*this%GetRdDn(ican,icol,ib,scelgp%lai+scelgp%sai) + end do + + end if if_beam + + end do do_isol + + !deallocate(OMEGA) + !deallocate(TAU) + !deallocate(LAMBDA) + + + ! Check the error balance + ! --------------------------------------------------------------------------------------------- + + ! Source = upwelling + canopy absorbed + ground absorbed + + rel_err = ((Rbeam_atm + Rdiff_atm) - & + (albedo_diff + albedo_beam ) - & + (frac_abs_can_diff + frac_abs_can_beam) - & + ((frac_diff_grnd_diff+frac_diff_grnd_beam)*(1._r8-this%band(ib)%albedo_grnd_diff)) - & + (frac_beam_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_beam)) ) / (Rbeam_atm + Rdiff_atm) + + beam_err = Rbeam_atm - (albedo_beam + frac_abs_can_beam + & + frac_diff_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_diff) + & + frac_beam_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_beam)) + + diff_err = Rdiff_atm - (albedo_diff + frac_abs_can_diff + & + frac_diff_grnd_diff*(1._r8-this%band(ib)%albedo_grnd_diff)) + + !if( abs(rel_err) > rel_err_thresh ) then + if( rel_err.ne.rel_err) then + print*,"Total canopy flux balance not closing in TwoStrteamMLPEMod:Solve" + print*,"Relative Error, delta/(Rbeam_atm+Rdiff_atm) :",rel_err + print*,"Max Error: ",rel_err_thresh + print*,"ib: ",ib + print*, beam_err,diff_err + print*,this%band(ib)%albedo_grnd_diff + print*, frac_diff_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_diff) + & + frac_beam_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_beam) + print*, frac_diff_grnd_diff*(1._r8-this%band(ib)%albedo_grnd_diff) + print*, albedo_beam,albedo_diff + print*, frac_abs_can_beam,frac_abs_can_diff + print*, frac_diff_grnd_beam,frac_beam_grnd_beam,frac_diff_grnd_diff + print*, "scattering coeff: ",(2*rad_params%om_leaf(ib,1)+0.5*rad_params%om_stem(ib,1))/2.5 + print*, "Breakdown:",this%n_lyr + do ican = 1,this%n_lyr + do icol = 1,this%n_col(ican) + scelgp => this%scelg(ican,icol) + scelbp => this%band(ib)%scelb(ican,icol) + print*," ",ican,icol + print*," ",scelgp%lai+scelgp%sai,scelgp%pft,scelgp%area + print*," ",scelbp%om,scelgp%Kb,scelgp%Kd,scelbp%betab,scelbp%betad + print*," ",scelbp%om*(1.0-scelbp%betad) + print*," ",scelbp%lambda1_beam,scelbp%lambda2_beam + print*," ",scelbp%lambda1_diff,scelbp%lambda2_diff + print*,"AB TERMS: ",scelbp%Ad,scelbp%Au,scelbp%B1d,scelbp%B2d,scelbp%B2d,scelbp%B2u,scelbp%a + print*,"LAMBDA TERMS: ",scelbp%lambda1_diff,scelbp%lambda2_diff,scelbp%lambda1_beam,scelbp%lambda2_beam + end do + end do + stop + end if + + + ! Set the boundary conditions back to unknown for a normalized solution + ! This prevents us from calling the absorption and flux query routines incorrectly. + ! For non-normalized, set it to the actual input boundary conditions + + if(upper_boundary_type.eq.normalized_upper_boundary) then + this%band(ib)%Rbeam_atm = unset_r8 + this%band(ib)%Rdiff_atm = unset_r8 + else + this%band(ib)%Rbeam_atm = Rbeam_atm + this%band(ib)%Rdiff_atm = Rdiff_atm + end if + + + return + end subroutine Solve + + +end Module TwoStreamMLPEMod From 282d8caf4e5083a18f93c665edc8ee17a2b5045b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 15 May 2023 11:33:00 -0400 Subject: [PATCH 054/250] Refactor some fates radiation code. New shared memory, and renamed driver code and module names. --- biogeochem/FatesAllometryMod.F90 | 112 +++++++++++++++++- main/EDPftvarcon.F90 | 4 +- main/EDTypesMod.F90 | 53 +++------ main/FatesInterfaceMod.F90 | 17 ++- main/FatesRestartInterfaceMod.F90 | 18 ++- .../FatesRadiationDriveMod.F90 | 73 +++++------- 6 files changed, 176 insertions(+), 101 deletions(-) rename biogeophys/EDSurfaceAlbedoMod.F90 => radiation/FatesRadiationDriveMod.F90 (96%) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index a1a8b41137..2e7374b7ab 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -98,6 +98,8 @@ module FatesAllometryMod use FatesGlobals , only : FatesWarn,N2S,A2S,I2S use EDTypesMod , only : nlevleaf, dinc_vai use EDTypesMod , only : nclmax + use EDTypesMod , only : dinc_vai + use EDTypesMod , only : dlower_vai use DamageMainMod , only : GetCrownReduction implicit none @@ -125,7 +127,8 @@ module FatesAllometryMod public :: set_root_fraction ! Generic wrapper to calculate normalized ! root profiles public :: leafc_from_treelai ! Calculate target leaf carbon for a given treelai for SP mode - + public :: VegAreaLayer + logical , parameter :: verbose_logging = .false. character(len=*), parameter :: sourcefile = __FILE__ @@ -2390,7 +2393,8 @@ real(r8) function decay_coeff_kn(pft,vcmax25top) end function decay_coeff_kn ! ===================================================================================== -subroutine ForceDBH( ipft, crowndamage, canopy_trim, d, h, bdead, bl ) + + subroutine ForceDBH( ipft, crowndamage, canopy_trim, d, h, bdead, bl ) ! ========================================================================= ! This subroutine estimates the diameter based on either the structural biomass @@ -2537,6 +2541,110 @@ subroutine ForceDBH( ipft, crowndamage, canopy_trim, d, h, bdead, bl ) return end subroutine ForceDBH + ! ========================================================================= + + subroutine VegAreaLayer(tree_lai,tree_sai,tree_height,iv,nv,pft,snow_depth, & + vai_top,vai_bot, & + elai_layer,esai_layer,tlai_layer,tsai_layer) + + ! ----------------------------------------------------------------------------------- + ! This routine returns the exposed leaf area (m2 of leaf) per m2 of + ! ground inside the crown, for the leaf-layer specified. + ! ----------------------------------------------------------------------------------- + + real(r8),intent(in) :: tree_lai ! the in-crown leaf area index for the plant + ! [m2 leaf/m2 crown footprint] + real(r8),intent(in) :: tree_sai ! the in-crown stem area index for the plant + ! [m2 stem/m2 crown footprint] + real(r8),intent(in) :: tree_height ! the height of the plant [m] + integer,intent(in) :: iv ! vegetation layer index + integer,intent(in) :: nv ! this plants total number of veg layers + integer,intent(in) :: pft ! plant functional type index + real(r8),intent(in) :: snow_depth ! the depth of snow on the ground [m] + real(r8),intent(out) :: vai_top + real(r8),intent(out) :: vai_bot ! the VAI of the bin top and bottom + real(r8),intent(out) :: elai_layer ! exposed leaf area index of the layer + real(r8),intent(out) :: esai_layer ! exposed stem area index of the layer + real(r8),optional,intent(out) :: tlai_layer ! total leaf area index of the layer + real(r8),optional,intent(out) :: tsai_layer ! total stem area index of the layer + + ! [m2 of leaf in bin / m2 crown footprint] + real(r8) :: tree_vai ! the in-crown veg area index for the plant + real(r8) :: fraction_exposed ! fraction of the veg media that is above snow + real(r8) :: layer_top_height ! Physical height of the layer top relative to ground [m] + real(r8) :: layer_bot_height ! Physical height of the layer bottom relative to ground [m] + real(r8) :: tlai,tsai ! temporary total area indices [m2/m2] + integer, parameter :: layer_height_const_depth = 1 ! constant physical depth assumption + integer, parameter :: layer_height_const_lad = 2 ! constant leaf area depth assumption + integer, parameter :: layer_height_method = layer_height_const_depth + + tree_vai = tree_lai + tree_sai + + if(tree_vai>0._r8)then + + if(iv==0)then + vai_top = 0.0 + vai_bot = tree_vai + else + + if(iv>1)then + vai_top = dlower_vai(iv) - dinc_vai(iv) + else + vai_top = 0._r8 + end if + + if(iv fates_r8 use FatesConstantsMod, only : nearzero @@ -1140,7 +1140,7 @@ subroutine Receive_PFT_numrad(this, fates_params) lower_bound_1 = lower_bound_pft upper_bound_1 = lower_bound_pft + dimension_sizes(1) - 1 lower_bound_2 = lower_bound_general - upper_bound_2 = maxSWb ! When we have radiation parameters read in as a vector + upper_bound_2 = num_swb ! When we have radiation parameters read in as a vector ! We will compare the vector dimension size that we ! read-in to the parameterized size that fates expects diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 9bd01ef5e7..07bfef42be 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -22,6 +22,9 @@ module EDTypesMod use FatesRunningMeanMod, only : rmean_type use FatesInterfaceTypesMod,only : bc_in_type use FatesInterfaceTypesMod,only : bc_out_type + use TwoStreamMLPEMod, only : twostream_type + use FatesRadiationMemMod, only : num_swb + use FatesRadiationMemMod, only : num_rad_stream_types implicit none private ! By default everything is private @@ -48,40 +51,11 @@ module EDTypesMod ! ------------------------------------------------------------------------------------- - integer, parameter, public :: n_rad_stream_types = 2 ! The number of radiation streams used (direct/diffuse) - - integer, parameter, public :: idirect = 1 ! This is the array index for direct radiation - integer, parameter, public :: idiffuse = 2 ! This is the array index for diffuse radiation - ! parameters that govern the VAI (LAI+SAI) bins used in radiative transfer code integer, parameter, public :: nlevleaf = 30 ! number of leaf+stem layers in canopy layer real(r8), public :: dinc_vai(nlevleaf) = fates_unset_r8 ! VAI bin widths array real(r8), public :: dlower_vai(nlevleaf) = fates_unset_r8 ! lower edges of VAI bins - ! TODO: we use this cp_maxSWb only because we have a static array q(size=2) of - ! land-ice abledo for vis and nir. This should be a parameter, which would - ! get us on track to start using multi-spectral or hyper-spectral (RGK 02-2017) - - integer, parameter, public :: maxSWb = 2 ! maximum number of broad-bands in the - ! shortwave spectrum cp_numSWb <= cp_maxSWb - ! this is just for scratch-array purposes - ! if cp_numSWb is larger than this value - ! simply bump this number up as needed - - integer, parameter, public :: ivis = 1 ! This is the array index for short-wave - ! radiation in the visible spectrum, as expected - ! in boundary condition files and parameter - ! files. This will be compared with - ! the HLM's expectation in FatesInterfaceMod - integer, parameter, public :: inir = 2 ! This is the array index for short-wave - ! radiation in the near-infrared spectrum, as expected - ! in boundary condition files and parameter - ! files. This will be compared with - ! the HLM's expectation in FatesInterfaceMod - - integer, parameter, public :: ipar = ivis ! The photosynthetically active band - ! can be approximated to be equal to the visible band - integer, parameter, public :: leaves_on = 2 ! Flag specifying that a deciduous plant has leaves ! and should be allocating to them as well @@ -253,6 +227,12 @@ module EDTypesMod integer :: coage_by_pft_class ! An index that indicates the cohorts position of the join cohort age class x PFT integer :: size_class_lasttimestep ! size class of the cohort at the last time step + + ! Two-stream radiation + + integer :: twostr_col ! The column index in the two-stream solution that this cohort is part of + + ! CARBON FLUXES ! ---------------------------------------------------------------------------------- @@ -451,7 +431,8 @@ module EDTypesMod ! This is set in create_patch as an argument ! to that procedure. - + type(twostream_type) :: twostr ! This holds all two-stream data for the patch + ! LEAF ORGANIZATION real(r8) :: pft_agb_profile(maxpft,n_dbh_bins) ! binned above ground biomass, for patch fusion: KgC/m2 real(r8) :: canopy_layer_tlai(nclmax) ! total leaf area index of each canopy layer @@ -489,8 +470,8 @@ module EDTypesMod logical :: solar_zenith_flag ! integer flag specifying daylight (based on zenith angle) real(r8) :: solar_zenith_angle ! solar zenith angle (radians) - real(r8) :: gnd_alb_dif(maxSWb) ! ground albedo for diffuse rad, both bands (fraction) - real(r8) :: gnd_alb_dir(maxSWb) ! ground albedo for direct rad, both bands (fraction) + real(r8) :: gnd_alb_dif(num_swb) ! ground albedo for diffuse rad, both bands (fraction) + real(r8) :: gnd_alb_dir(num_swb) ! ground albedo for direct rad, both bands (fraction) real(r8) :: fabd_sun_z(nclmax,maxpft,nlevleaf) ! sun fraction of direct light absorbed by each canopy ! layer, pft, and leaf layer:- @@ -512,19 +493,19 @@ module EDTypesMod ! normalized direct photosynthetically active radiation profiles by ! incident type (direct/diffuse at top of canopy),leaf,pft,leaf (unitless) - real(r8) :: nrmlzd_parprof_pft_dir_z(n_rad_stream_types,nclmax,maxpft,nlevleaf) + real(r8) :: nrmlzd_parprof_pft_dir_z(num_rad_stream_types,nclmax,maxpft,nlevleaf) ! normalized diffuse photosynthetically active radiation profiles by ! incident type (direct/diffuse at top of canopy),leaf,pft,leaf (unitless) - real(r8) :: nrmlzd_parprof_pft_dif_z(n_rad_stream_types,nclmax,maxpft,nlevleaf) + real(r8) :: nrmlzd_parprof_pft_dif_z(num_rad_stream_types,nclmax,maxpft,nlevleaf) ! normalized direct photosynthetically active radiation profiles by ! incident type (direct/diffuse at top of canopy),leaf,leaf (unitless) - real(r8) :: nrmlzd_parprof_dir_z(n_rad_stream_types,nclmax,nlevleaf) + real(r8) :: nrmlzd_parprof_dir_z(num_rad_stream_types,nclmax,nlevleaf) ! normalized diffuse photosynthetically active radiation profiles by ! incident type (direct/diffuse at top of canopy),leaf,leaf (unitless) - real(r8) :: nrmlzd_parprof_dif_z(n_rad_stream_types,nclmax,nlevleaf) + real(r8) :: nrmlzd_parprof_dif_z(num_rad_stream_types,nclmax,nlevleaf) real(r8) :: parprof_pft_dir_z(nclmax,maxpft,nlevleaf) ! direct-beam PAR profile through canopy, by canopy,PFT,leaf level (w/m2) real(r8) :: parprof_pft_dif_z(nclmax,maxpft,nlevleaf) ! diffuse PAR profile through canopy, by canopy,PFT,leaf level (w/m2) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index f8bbf0da33..9f3e3cc986 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -19,9 +19,7 @@ module FatesInterfaceMod use EDParamsMod , only : maxpatch_primary use EDParamsMod , only : maxpatch_secondary use EDParamsMod , only : max_cohort_per_patch - use EDTypesMod , only : maxSWb - use EDTypesMod , only : ivis - use EDTypesMod , only : inir + use FatesRadiationMemMod , only : num_swb,ivis,inir use EDTypesMod , only : nclmax use EDTypesMod , only : nlevleaf use EDTypesMod , only : maxpft @@ -94,6 +92,7 @@ module FatesInterfaceMod use FatesHistoryInterfaceMod , only : fates_hist use FatesHydraulicsMemMod , only : nshell use FatesHydraulicsMemMod , only : nlevsoi_hyd_max + use FatesTwoStreamInterfaceMod, only : TransferRadParams ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -826,9 +825,9 @@ subroutine SetFatesGlobalElements2(use_fates) ! These values are used to define the restart file allocations and general structure ! of memory for the cohort arrays if(hlm_use_sp.eq.itrue) then - fates_maxElementsPerPatch = maxSWb + fates_maxElementsPerPatch = num_swb else - fates_maxElementsPerPatch = max(maxSWb,max_cohort_per_patch, ndcmpy*hlm_maxlevsoil ,ncwd*hlm_maxlevsoil) + fates_maxElementsPerPatch = max(num_swb,max_cohort_per_patch, ndcmpy*hlm_maxlevsoil ,ncwd*hlm_maxlevsoil) end if fates_maxElementsPerSite = max(fates_maxPatchesPerSite * fates_maxElementsPerPatch, & @@ -1408,13 +1407,13 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(hlm_numSWb > maxSWb) then + if(hlm_numSWb > num_swb) then write(fates_log(), *) 'FATES sets a maximum number of shortwave bands' - write(fates_log(), *) 'for some scratch-space, maxSWb' + write(fates_log(), *) 'for some scratch-space, num_swb' write(fates_log(), *) 'it defaults to 2, but can be increased as needed' write(fates_log(), *) 'your driver or host model is intending to drive' write(fates_log(), *) 'FATES with:',hlm_numSWb,' bands.' - write(fates_log(), *) 'please increase maxSWb in EDTypes to match' + write(fates_log(), *) 'please increase num_swb in FatesRadiationMemMod to match' write(fates_log(), *) 'or exceed this value' call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1913,7 +1912,7 @@ subroutine FatesReportParameters(masterproc) call PRTDerivedParams() ! Update PARTEH derived constants call PRTCheckParams(masterproc) ! Check PARTEH parameters call SpitFireCheckParams(masterproc) - + call TransferRadParams() return diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 35ae60ca50..7125bb0a69 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -47,7 +47,8 @@ module FatesRestartInterfaceMod use PRTGenericMod, only : num_elements use FatesRunningMeanMod, only : rmean_type use FatesRunningMeanMod, only : ema_lpa - + use FatesRadiationMemMod, only : num_swb + ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg @@ -1818,7 +1819,6 @@ subroutine set_restart_vectors(this,nc,nsites,sites) use EDTypesMod, only : ed_site_type use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type - use EDTypesMod, only : maxSWb use EDTypesMod, only : nclmax use EDTypesMod, only : numWaterMem use EDTypesMod, only : num_vegtemp_mem @@ -2323,7 +2323,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end do end if - do i = 1,maxSWb + do i = 1,num_swb rio_gnd_alb_dif_pasb(io_idx_pa_ib) = cpatch%gnd_alb_dif(i) rio_gnd_alb_dir_pasb(io_idx_pa_ib) = cpatch%gnd_alb_dir(i) io_idx_pa_ib = io_idx_pa_ib + 1 @@ -2519,7 +2519,6 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in, bc_out) use EDTypesMod, only : ed_site_type use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type - use EDTypesMod, only : maxSWb use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch use EDTypesMod, only : maxpft @@ -2719,7 +2718,6 @@ subroutine get_restart_vectors(this, nc, nsites, sites) use EDTypesMod, only : ed_site_type use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type - use EDTypesMod, only : maxSWb use EDTypesMod, only : nclmax use FatesInterfaceTypesMod, only : numpft use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch @@ -3213,7 +3211,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) end if - do i = 1,maxSWb + do i = 1,num_swb cpatch%gnd_alb_dif(i) = rio_gnd_alb_dif_pasb(io_idx_pa_ib) cpatch%gnd_alb_dir(i) = rio_gnd_alb_dir_pasb(io_idx_pa_ib) io_idx_pa_ib = io_idx_pa_ib + 1 @@ -3405,10 +3403,10 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) ! called upon restart reads. ! ------------------------------------------------------------------------- - use EDTypesMod, only : ed_site_type - use EDTypesMod, only : ed_patch_type - use EDSurfaceRadiationMod, only : PatchNormanRadiation - use FatesInterfaceTypesMod, only : hlm_numSWb + use EDTypesMod, only : ed_site_type + use EDTypesMod, only : ed_patch_type + use FatesRadiationDriveMod, only : PatchNormanRadiation + use FatesInterfaceTypesMod, only : hlm_numSWb ! !ARGUMENTS: class(fates_restart_interface_type) , intent(inout) :: this diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/radiation/FatesRadiationDriveMod.F90 similarity index 96% rename from biogeophys/EDSurfaceAlbedoMod.F90 rename to radiation/FatesRadiationDriveMod.F90 index 18d29c0109..5c7bf7a0e8 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -1,4 +1,4 @@ -module EDSurfaceRadiationMod +module FatesRadiationDriveMod !------------------------------------------------------------------------------------- ! EDSurfaceRadiation @@ -20,51 +20,40 @@ module EDSurfaceRadiationMod use FatesInterfaceTypesMod , only : bc_out_type use FatesInterfaceTypesMod , only : hlm_numSWb use FatesInterfaceTypesMod , only : numpft - use EDTypesMod , only : maxSWb use EDTypesMod , only : nclmax use EDTypesMod , only : nlevleaf - use EDTypesMod , only : n_rad_stream_types - use EDTypesMod , only : idiffuse - use EDTypesMod , only : idirect - use EDTypesMod , only : ivis - use EDTypesMod , only : inir - use EDTypesMod , only : ipar use EDCanopyStructureMod, only: calc_areaindex use FatesGlobals , only : fates_log use FatesGlobals, only : endrun => fates_endrun - + use FatesRadiationMemMod, only : num_rad_stream_types + use FatesRadiationMemMod, only : idirect, idiffuse + use FatesRadiationMemMod, only : num_swb, ivis, inir, ipar + use FatesRadiationMemMod, only : alb_ice, rho_snow, tau_snow + use FatesRadiationMemMod, only : norman_solver + use FatesRadiationMemMod, only : twostr_solver + use FatesRadiationMemMod, only : rad_solver + use TwoStreamMLPEMod, only : normalized_upper_boundary + use FatesTwoStreamInterfaceMod, only : FatesPatchFSun + use FatesTwoStreamInterfaceMod, only : CheckPatchRadiationBalance + ! CIME globals use shr_log_mod , only : errMsg => shr_log_errMsg implicit none private - public :: ED_Norman_Radiation ! Surface albedo and two-stream fluxes + public :: FatesNormalizedCanopyRadiation ! Surface albedo and two-stream fluxes public :: PatchNormanRadiation - public :: ED_SunShadeFracs + public :: FatesSunShadeFracs logical :: debug = .false. ! for debugging this module character(len=*), parameter, private :: sourcefile = & __FILE__ - ! real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) - ! (/ 0.80_r8, 0.55_r8 /) - - !parameters of canopy snow reflectance model. - ! the parameters in the 2-stream model are not directly analagous to those here - ! and so they are stored here for now in common with the ice parameters above. - ! in principle these could be moved to the parameter file. - real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) - (/ 0.80_r8, 0.55_r8 /) - real(r8), public :: rho_snow(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) - (/ 0.80_r8, 0.55_r8 /) - real(r8), public :: tau_snow(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) - (/ 0.01_r8, 0.01_r8 /) contains - subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) - ! + subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) ! ! !USES: @@ -174,7 +163,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) enddo ! Loop Sites return - end subroutine ED_Norman_Radiation + end subroutine FatesNormalizedCanopyRadiation ! ====================================================================================== @@ -227,25 +216,25 @@ subroutine PatchNormanRadiation (currentPatch, & real(r8) :: tr_dif_z(nclmax,maxpft,nlevleaf) ! Exponential transmittance of diffuse radiation through a single layer real(r8) :: weighted_dir_tr(nclmax) real(r8) :: weighted_fsun(nclmax) - real(r8) :: weighted_dif_ratio(nclmax,maxSWb) + real(r8) :: weighted_dif_ratio(nclmax,num_swb) real(r8) :: weighted_dif_down(nclmax) real(r8) :: weighted_dif_up(nclmax) - real(r8) :: refl_dif(nclmax,maxpft,nlevleaf,maxSWb) ! Term for diffuse radiation reflected by laye - real(r8) :: tran_dif(nclmax,maxpft,nlevleaf,maxSWb) ! Term for diffuse radiation transmitted by layer - real(r8) :: dif_ratio(nclmax,maxpft,nlevleaf,maxSWb) ! Ratio of upward to forward diffuse fluxes + real(r8) :: refl_dif(nclmax,maxpft,nlevleaf,num_swb) ! Term for diffuse radiation reflected by laye + real(r8) :: tran_dif(nclmax,maxpft,nlevleaf,num_swb) ! Term for diffuse radiation transmitted by layer + real(r8) :: dif_ratio(nclmax,maxpft,nlevleaf,num_swb) ! Ratio of upward to forward diffuse fluxes real(r8) :: Dif_dn(nclmax,maxpft,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) real(r8) :: Dif_up(nclmax,maxpft,nlevleaf) ! Upward diffuse flux above canopy layer J (W/m**2 ground area) real(r8) :: lai_change(nclmax,maxpft,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) real(r8) :: frac_lai ! Fraction of lai in each layer real(r8) :: frac_sai ! Fraction of sai in each layer - real(r8) :: f_abs(nclmax,maxpft,nlevleaf,maxSWb) ! Fraction of light absorbed by surfaces. - real(r8) :: rho_layer(nclmax,maxpft,nlevleaf,maxSWb)! Weighted verage reflectance of layer - real(r8) :: tau_layer(nclmax,maxpft,nlevleaf,maxSWb)! Weighted average transmittance of layer - real(r8) :: f_abs_leaf(nclmax,maxpft,nlevleaf,maxSWb) + real(r8) :: f_abs(nclmax,maxpft,nlevleaf,num_swb) ! Fraction of light absorbed by surfaces. + real(r8) :: rho_layer(nclmax,maxpft,nlevleaf,num_swb)! Weighted verage reflectance of layer + real(r8) :: tau_layer(nclmax,maxpft,nlevleaf,num_swb)! Weighted average transmittance of layer + real(r8) :: f_abs_leaf(nclmax,maxpft,nlevleaf,num_swb) real(r8) :: Abs_dir_z(maxpft,nlevleaf) real(r8) :: Abs_dif_z(maxpft,nlevleaf) - real(r8) :: abs_rad(maxSWb) !radiation absorbed by soil + real(r8) :: abs_rad(num_swb) !radiation absorbed by soil real(r8) :: tr_soili ! Radiation transmitted to the soil surface. real(r8) :: tr_soild ! Radiation transmitted to the soil surface. real(r8) :: phi1b(maxpft) ! Radiation transmitted to the soil surface. @@ -268,8 +257,8 @@ subroutine PatchNormanRadiation (currentPatch, & real(r8) :: gdir - real(r8), parameter :: forc_dir(n_rad_stream_types) = (/ 1.0_r8, 0.0_r8 /) ! These are binary switches used - real(r8), parameter :: forc_dif(n_rad_stream_types) = (/ 0.0_r8, 1.0_r8 /) ! to turn off and on radiation streams + real(r8), parameter :: forc_dir(num_rad_stream_types) = (/ 1.0_r8, 0.0_r8 /) ! These are binary switches used + real(r8), parameter :: forc_dif(num_rad_stream_types) = (/ 0.0_r8, 1.0_r8 /) ! to turn off and on radiation streams @@ -373,7 +362,7 @@ subroutine PatchNormanRadiation (currentPatch, & !do this once for one unit of diffuse, and once for one unit of direct radiation - do radtype = 1, n_rad_stream_types + do radtype = 1, num_rad_stream_types ! Extract information that needs to be provided by ED into local array. ! RGK: NOT SURE WHY WE NEED FTWEIGHT ... @@ -1114,7 +1103,7 @@ end subroutine PatchNormanRadiation ! ====================================================================================== -subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) +subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) implicit none @@ -1297,7 +1286,7 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) enddo return -end subroutine ED_SunShadeFracs +end subroutine FatesSunShadeFracs ! ! MOVE TO THE INTERFACE @@ -1330,4 +1319,4 @@ end subroutine ED_SunShadeFracs ! end subroutine ED_CheckSolarBalance -end module EDSurfaceRadiationMod +end module FatesRadiationDriveMod From 013e07f5da2b96f6fa371814dbbcd93b09c83d76 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 16 May 2023 10:20:02 -0400 Subject: [PATCH 055/250] two-stream changes, updated photosynthesis calls to protect against negative absorption --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 952 +++++++++++---------- 1 file changed, 517 insertions(+), 435 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index fa1228b733..8733a35b97 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -64,7 +64,12 @@ module FATESPlantRespPhotosynthMod use PRTParametersMod, only : prt_params use EDPftvarcon , only : EDPftvarcon_inst use TemperatureType, only : temperature_type - + use FatesRadiationMemMod, only : norman_solver,twostr_solver + use FatesRadiationMemMod, only : rad_solver + use FatesRadiationMemMod, only : ipar + use FatesTwoStreamInterfaceMod, only : FatesGetCohortAbsRad + use FatesAllometryMod , only : VegAreaLayer + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -214,7 +219,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: tcsoi ! Temperature response function for root respiration. real(r8) :: tcwood ! Temperature response function for wood - real(r8) :: elai ! exposed LAI (patch scale) + real(r8) :: patch_la ! exposed leaf area (patch scale) real(r8) :: live_stem_n ! Live stem (above-ground sapwood) ! nitrogen content (kgN/plant) real(r8) :: live_croot_n ! Live coarse root (below-ground sapwood) @@ -239,7 +244,6 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! respiration when storage pools are low real(r8) :: b_leaf ! leaf biomass kgC real(r8) :: frac ! storage pool as a fraction of target leaf biomass - real(r8) :: check_elai ! This is a check on the effective LAI that is calculated ! over each cohort x layer. real(r8) :: cohort_eleaf_area ! This is the effective leaf area [m2] reported by each cohort real(r8) :: lnc_top ! Leaf nitrogen content per unit area at canopy top [gN/m2] @@ -268,7 +272,17 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: sapw_n_bgw ! nitrogen in belowground portion of sapwood real(r8) :: sapw_n_agw ! nitrogen in aboveground portion of sapwood real(r8) :: sapw_n_undamaged ! nitrogen in sapwood of undamaged tree - + real(r8) :: rd_abs_leaf, rb_abs_leaf, r_abs_stem, r_abs_snow, rb_abs, rd_abs + real(r8) :: fsun + real(r8) :: par_per_sunla, par_per_shala ! PAR per sunlit and shaded leaf area [W/m2 leaf] + real(r8),dimension(50) :: cohort_vaitop + real(r8),dimension(50) :: cohort_vaibot + real(r8),dimension(50) :: cohort_layer_elai + real(r8),dimension(50) :: cohort_layer_esai + real(r8) :: cohort_elai + real(r8) :: cohort_esai + real(r8) :: elai_layer + ! ----------------------------------------------------------------------------------- ! Keeping these two definitions in case they need to be added later ! @@ -337,7 +351,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) bc_out(s)%rssha_pa(ifp) = 0._r8 g_sb_leaves = 0._r8 - check_elai = 0._r8 + patch_la = 0._r8 ! Part II. Filter out patches ! Patch level filter flag for photosynthesis calculations @@ -346,7 +360,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! 2 = patch is currently marked for photosynthesis ! 3 = patch has been called for photosynthesis already ! --------------------------------------------------------------------------- - if(bc_in(s)%filter_photo_pa(ifp)==2)then + if_filter2: if(bc_in(s)%filter_photo_pa(ifp)==2)then ! Part III. Calculate the number of sublayers for each pft and layer. @@ -379,9 +393,6 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) gb_mol, & ! out ceair) ! out - - - ! ------------------------------------------------------------------------ ! Part VI: Loop over all leaf layers. ! The concept of leaf layers is a result of the radiative transfer scheme. @@ -403,501 +414,594 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! ------------------------------------------------------------------------ rate_mask_z(:,1:numpft,:) = .false. - if(currentPatch%countcohorts > 0.0)then ! Ignore empty patches - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) ! Cohort loop - - ! Identify the canopy layer (cl), functional type (ft) - ! and the leaf layer (IV) for this cohort - ft = currentCohort%pft - cl = currentCohort%canopy_layer - - call bleaf(currentCohort%dbh,currentCohort%pft,& - currentCohort%crowndamage,currentCohort%canopy_trim,store_c_target) - ! call bstore_allom(currentCohort%dbh,currentCohort%pft, & - ! currentCohort%canopy_trim,store_c_target) - - call storage_fraction_of_target(store_c_target, & - currentCohort%prt%GetState(store_organ, carbon12_element), & - frac) - call lowstorage_maintresp_reduction(frac,currentCohort%pft, & - maintresp_reduction_factor) - - ! are there any leaves of this pft in this layer? - canopy_mask_if: if(currentPatch%canopy_mask(cl,ft) == 1)then - - ! Loop over leaf-layers - leaf_layer_loop : do iv = 1,currentCohort%nv - - ! ------------------------------------------------------------ - ! If we are doing plant hydro-dynamics (or any run-type - ! where cohorts may generate different photosynthetic rates - ! of other cohorts in the same canopy-pft-layer combo), - ! we re-calculate the leaf biophysical rates for the - ! cohort-layer combo of interest. - ! but in the vanilla case, we only re-calculate if it has - ! not been done yet. - ! Other cases where we need to solve for every cohort - ! in every leaf layer: nutrient dynamic mode, multiple leaf - ! age classes - ! ------------------------------------------------------------ - - rate_mask_if: if ( .not.rate_mask_z(iv,ft,cl) .or. & - (hlm_use_planthydro.eq.itrue) .or. & - (nleafage > 1) .or. & - (hlm_parteh_mode .ne. prt_carbon_allom_hyp ) ) then - - if (hlm_use_planthydro.eq.itrue ) then - - stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentCohort%co_hydr%btran ) - btran_eff = currentCohort%co_hydr%btran + currentCohort => currentPatch%tallest + do_cohort_drive: do while (associated(currentCohort)) ! Cohort loop + + ! Identify the canopy layer (cl), functional type (ft) + ! and the leaf layer (IV) for this cohort + ft = currentCohort%pft + cl = currentCohort%canopy_layer + + ! Calculate the cohort specific elai profile + ! And the top and bottom edges of the veg area index + ! of each layer bin are. Note, if the layers + ! sink below the ground snow line, then the effective + ! LAI and SAI start to shrink to zero, as well as + ! the difference between vaitop and vaibot. + if(currentCohort%treesai>0._r8)then + do iv = 1,currentCohort%nv + call VegAreaLayer(currentCohort%treelai, & + currentCohort%treesai, & + currentCohort%hite, & + iv, & + currentCohort%nv, & + currentCohort%pft, & + sites(s)%snow_depth, & + cohort_vaitop(iv), & + cohort_vaibot(iv), & + cohort_layer_elai(iv), & + cohort_layer_esai(iv)) + end do + + cohort_elai = sum(cohort_layer_elai(1:currentCohort%nv)) + cohort_esai = sum(cohort_layer_esai(1:currentCohort%nv)) - ! dinc_vai(:) is the total vegetation area index of each "leaf" layer - ! we convert to the leaf only portion of the increment - ! ------------------------------------------------------ - leaf_inc = dinc_vai(iv) * & - currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) + else + cohort_layer_elai(1:nv) = 0._r8 + cohort_layer_esai(1:nv) = 0._r8 + cohort_vaitop(1:nv) = 0._r8 + cohort_vaibot(1:nv) = 0._r8 + cohort_elai = 0._r8 + cohort_esai = 0._r8 + end if - ! Now calculate the cumulative top-down lai of the current layer's midpoint - lai_canopy_above = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + + call bleaf(currentCohort%dbh,currentCohort%pft,& + currentCohort%crowndamage,currentCohort%canopy_trim,store_c_target) + ! call bstore_allom(currentCohort%dbh,currentCohort%pft, & + ! currentCohort%canopy_trim,store_c_target) - lai_layers_above = (dlower_vai(iv) - dinc_vai(iv)) * & - currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) - lai_current = min(leaf_inc, currentCohort%treelai - lai_layers_above) - cumulative_lai = lai_canopy_above + lai_layers_above + 0.5*lai_current + call storage_fraction_of_target(store_c_target, & + currentCohort%prt%GetState(store_organ, carbon12_element), & + frac) + call lowstorage_maintresp_reduction(frac,currentCohort%pft, & + maintresp_reduction_factor) - leaf_psi = currentCohort%co_hydr%psi_ag(1) - - else + ! are there any leaves of this pft in this layer? + canopy_mask_if: if(currentPatch%canopy_mask(cl,ft) == 1)then - stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentPatch%btran_ft(ft) ) + ! Loop over leaf-layers + leaf_layer_loop : do iv = 1,currentCohort%nv - btran_eff = currentPatch%btran_ft(ft) - ! For consistency sake, we use total LAI here, and not exposed - ! if the plant is under-snow, it will be effectively dormant for - ! the purposes of nscaler + ! ------------------------------------------------------------ + ! If we are doing plant hydro-dynamics (or any run-type + ! where cohorts may generate different photosynthetic rates + ! of other cohorts in the same canopy-pft-layer combo), + ! we re-calculate the leaf biophysical rates for the + ! cohort-layer combo of interest. + ! but in the vanilla case, we only re-calculate if it has + ! not been done yet. + ! Other cases where we need to solve for every cohort + ! in every leaf layer: nutrient dynamic mode, multiple leaf + ! age classes + ! ------------------------------------------------------------ - cumulative_lai = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + & - sum(currentPatch%tlai_profile(cl,ft,1:iv-1)) + & - 0.5*currentPatch%tlai_profile(cl,ft,iv) + rate_mask_if: if ( .not.rate_mask_z(iv,ft,cl) .or. & + (hlm_use_planthydro.eq.itrue) .or. & + (rad_solver .eq. twostr_solver ) .or. & + (nleafage > 1) .or. & + (hlm_parteh_mode .ne. prt_carbon_allom_hyp ) ) then - leaf_psi = fates_unset_r8 + if (hlm_use_planthydro.eq.itrue ) then - end if + stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentCohort%co_hydr%btran ) + btran_eff = currentCohort%co_hydr%btran - if(do_fates_salinity)then - btran_eff = btran_eff*currentPatch%bstress_sal_ft(ft) - endif + ! dinc_vai(:) is the total vegetation area index of each "leaf" layer + ! we convert to the leaf only portion of the increment + ! ------------------------------------------------------ + leaf_inc = dinc_vai(iv) * & + currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) + ! Now calculate the cumulative top-down lai of the current layer's midpoint + lai_canopy_above = sum(currentPatch%canopy_layer_tlai(1:cl-1)) - ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 used - ! kn = 0.11. Here, derive kn from vcmax25 as in Lloyd et al - ! (2010) Biogeosciences, 7, 1833-1859 + lai_layers_above = (dlower_vai(iv) - dinc_vai(iv)) * & + currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) + lai_current = min(leaf_inc, currentCohort%treelai - lai_layers_above) + cumulative_lai = lai_canopy_above + lai_layers_above + 0.5*lai_current - kn = decay_coeff_kn(ft,currentCohort%vcmax25top) + leaf_psi = currentCohort%co_hydr%psi_ag(1) - ! Scale for leaf nitrogen profile - nscaler = exp(-kn * cumulative_lai) + else - ! Leaf maintenance respiration to match the base rate used in CN - ! but with the new temperature functions for C3 and C4 plants. + stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentPatch%btran_ft(ft) ) - ! CN respiration has units: g C / g N [leaf] / s. This needs to be - ! converted from g C / g N [leaf] / s to umol CO2 / m**2 [leaf] / s + btran_eff = currentPatch%btran_ft(ft) + ! For consistency sake, we use total LAI here, and not exposed + ! if the plant is under-snow, it will be effectively dormant for + ! the purposes of nscaler - ! Then scale this value at the top of the canopy for canopy depth - ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) - select case(hlm_parteh_mode) - case (prt_carbon_allom_hyp) + cumulative_lai = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + & + sum(currentPatch%tlai_profile(cl,ft,1:iv-1)) + & + 0.5*currentPatch%tlai_profile(cl,ft,iv) - lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) + leaf_psi = fates_unset_r8 - case (prt_cnp_flex_allom_hyp) + end if - leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element) - if( (leaf_c*slatop(ft)) > nearzero) then - leaf_n = currentCohort%prt%GetState(leaf_organ, nitrogen_element) - lnc_top = leaf_n / (slatop(ft) * leaf_c ) - else - lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) - end if + if(do_fates_salinity)then + btran_eff = btran_eff*currentPatch%bstress_sal_ft(ft) + endif - ! If one wants to break coupling with dynamic N conentrations, - ! use the stoichiometry parameter - ! lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) - end select + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 used + ! kn = 0.11. Here, derive kn from vcmax25 as in Lloyd et al + ! (2010) Biogeosciences, 7, 1833-1859 - ! Part VII: Calculate dark respiration (leaf maintenance) for this layer + kn = decay_coeff_kn(ft,currentCohort%vcmax25top) - select case (maintresp_leaf_model) + ! Scale for leaf nitrogen profile + nscaler = exp(-kn * cumulative_lai) - case (lmrmodel_ryan_1991) + ! Leaf maintenance respiration to match the base rate used in CN + ! but with the new temperature functions for C3 and C4 plants. - call LeafLayerMaintenanceRespiration_Ryan_1991( lnc_top, & ! in - nscaler, & ! in - ft, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - lmr_z(iv,ft,cl)) ! out + ! CN respiration has units: g C / g N [leaf] / s. This needs to be + ! converted from g C / g N [leaf] / s to umol CO2 / m**2 [leaf] / s - case (lmrmodel_atkin_etal_2017) + ! Then scale this value at the top of the canopy for canopy depth + ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp) - call LeafLayerMaintenanceRespiration_Atkin_etal_2017(lnc_top, & ! in - nscaler, & ! in - ft, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - currentPatch%tveg_lpa%GetMean(), & ! in - lmr_z(iv,ft,cl)) ! out + lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) - case default + case (prt_cnp_flex_allom_hyp) - write (fates_log(),*)'error, incorrect leaf respiration model specified' - call endrun(msg=errMsg(sourcefile, __LINE__)) + leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element) + if( (leaf_c*slatop(ft)) > nearzero) then + leaf_n = currentCohort%prt%GetState(leaf_organ, nitrogen_element) + lnc_top = leaf_n / (slatop(ft) * leaf_c ) + else + lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) + end if - end select + ! If one wants to break coupling with dynamic N conentrations, + ! use the stoichiometry parameter + ! lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) - ! Part VII: Calculate (1) maximum rate of carboxylation (vcmax), - ! (2) maximum electron transport rate, (3) triose phosphate - ! utilization rate and (4) the initial slope of CO2 response curve - ! (C4 plants). Earlier we calculated their base rates as dictated - ! by their plant functional type and some simple scaling rules for - ! nitrogen limitation baesd on canopy position (not prognostic). - ! These rates are the specific rates used in the actual photosynthesis - ! calculations that take localized environmental effects (temperature) - ! into consideration. + end select + ! Part VII: Calculate dark respiration (leaf maintenance) for this layer + select case (maintresp_leaf_model) - call LeafLayerBiophysicalRates(currentPatch%ed_parsun_z(cl,ft,iv), & ! in - ft, & ! in - currentCohort%vcmax25top, & ! in - currentCohort%jmax25top, & ! in - currentCohort%kp25top, & ! in + case (lmrmodel_ryan_1991) + + call LeafLayerMaintenanceRespiration_Ryan_1991( lnc_top, & ! in + nscaler, & ! in + ft, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + lmr_z(iv,ft,cl)) ! out + + case (lmrmodel_atkin_etal_2017) + + call LeafLayerMaintenanceRespiration_Atkin_etal_2017(lnc_top, & ! in nscaler, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - currentPatch%tveg_lpa%GetMean(), & ! in - currentPatch%tveg_longterm%GetMean(),& ! in - btran_eff, & ! in - vcmax_z, & ! out - jmax_z, & ! out - kp_z ) ! out - - ! Part IX: This call calculates the actual photosynthesis for the - ! leaf layer, as well as the stomatal resistance and the net assimilated carbon. - - call LeafLayerPhotosynthesis(currentPatch%f_sun(cl,ft,iv), & ! in - currentPatch%ed_parsun_z(cl,ft,iv), & ! in - currentPatch%ed_parsha_z(cl,ft,iv), & ! in - currentPatch%ed_laisun_z(cl,ft,iv), & ! in - currentPatch%ed_laisha_z(cl,ft,iv), & ! in - currentPatch%canopy_area_profile(cl,ft,iv), & ! in ft, & ! in - vcmax_z, & ! in - jmax_z, & ! in - kp_z, & ! in bc_in(s)%t_veg_pa(ifp), & ! in - bc_in(s)%esat_tv_pa(ifp), & ! in - bc_in(s)%forc_pbot, & ! in - bc_in(s)%cair_pa(ifp), & ! in - bc_in(s)%oair_pa(ifp), & ! in - btran_eff, & ! in - stomatal_intercept_btran, & ! in - cf, & ! in - gb_mol, & ! in - ceair, & ! in - mm_kco2, & ! in - mm_ko2, & ! in - co2_cpoint, & ! in - lmr_z(iv,ft,cl), & ! in - leaf_psi, & ! in - bc_in(s)%rb_pa(ifp), & ! in - currentPatch%psn_z(cl,ft,iv), & ! out - rs_z(iv,ft,cl), & ! out - anet_av_z(iv,ft,cl), & ! out - c13disc_z(cl,ft,iv)) ! out - - rate_mask_z(iv,ft,cl) = .true. - - end if rate_mask_if - end do leaf_layer_loop - - ! Zero cohort flux accumulators. - currentCohort%npp_tstep = 0.0_r8 - currentCohort%resp_tstep = 0.0_r8 - currentCohort%gpp_tstep = 0.0_r8 - currentCohort%rdark = 0.0_r8 - currentCohort%resp_m = 0.0_r8 - currentCohort%ts_net_uptake = 0.0_r8 - currentCohort%c13disc_clm = 0.0_r8 - - ! --------------------------------------------------------------- - ! Part VII: Transfer leaf flux rates (like maintenance respiration, - ! carbon assimilation and conductance) that are defined by the - ! leaf layer (which is area independent, ie /m2) onto each cohort - ! (where the rates become per cohort, ie /individual). Most likely - ! a sum over layers. - ! --------------------------------------------------------------- - nv = currentCohort%nv - call ScaleLeafLayerFluxToCohort(nv, & !in - currentPatch%psn_z(cl,ft,1:nv), & !in - lmr_z(1:nv,ft,cl), & !in - rs_z(1:nv,ft,cl), & !in - currentPatch%elai_profile(cl,ft,1:nv), & !in - c13disc_z(cl, ft, 1:nv), & !in - currentCohort%c_area, & !in - currentCohort%n, & !in - bc_in(s)%rb_pa(ifp), & !in - maintresp_reduction_factor, & !in - currentCohort%g_sb_laweight, & !out - currentCohort%gpp_tstep, & !out - currentCohort%rdark, & !out - currentCohort%c13disc_clm, & !out - cohort_eleaf_area) !out - - ! Net Uptake does not need to be scaled, just transfer directly - currentCohort%ts_net_uptake(1:nv) = anet_av_z(1:nv,ft,cl) * umolC_to_kgC - - else - - ! In this case, the cohort had no leaves, - ! so no productivity,conductance, transpiration uptake - ! or dark respiration - cohort_eleaf_area = 0.0_r8 - currentCohort%gpp_tstep = 0.0_r8 - currentCohort%rdark = 0.0_r8 - currentCohort%g_sb_laweight = 0.0_r8 - currentCohort%ts_net_uptake(:) = 0.0_r8 - - end if canopy_mask_if - - - ! ------------------------------------------------------------------ - ! Part VIII: Calculate maintenance respiration in the sapwood and - ! fine root pools. - ! ------------------------------------------------------------------ - - ! Calculate the amount of nitrogen in the above and below ground - ! stem and root pools, used for maint resp - ! We are using the fine-root C:N ratio as an approximation for - ! the sapwood pools. - ! Units are in (kgN/plant) - ! ------------------------------------------------------------------ - - sapw_c = currentCohort%prt%GetState(sapw_organ, carbon12_element) - fnrt_c = currentCohort%prt%GetState(fnrt_organ, carbon12_element) + currentPatch%tveg_lpa%GetMean(), & ! in + lmr_z(iv,ft,cl)) ! out - if (hlm_use_tree_damage .eq. itrue) then - - ! Crown damage currenly only reduces the aboveground portion of - ! sapwood. Therefore we calculate the aboveground and the belowground portion - ! sapwood for use in stem respiration. - call GetCrownReduction(currentCohort%crowndamage, crown_reduction) - - else - crown_reduction = 0.0_r8 - end if - - ! If crown reduction is zero, undamaged sapwood target will equal sapwood carbon - agb_frac = prt_params%allom_agb_frac(currentCohort%pft) - branch_frac = param_derived%branch_frac(currentCohort%pft) - sapw_c_undamaged = sapw_c / (1.0_r8 - (agb_frac * branch_frac * crown_reduction)) - - ! Undamaged below ground portion - sapw_c_bgw = sapw_c_undamaged * (1.0_r8 - agb_frac) + case default - ! Damaged aboveground portion - sapw_c_agw = sapw_c - sapw_c_bgw - - - select case(hlm_parteh_mode) - case (prt_carbon_allom_hyp) + write (fates_log(),*)'error, incorrect leaf respiration model specified' + call endrun(msg=errMsg(sourcefile, __LINE__)) - live_stem_n = sapw_c_agw * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) + end select - live_croot_n = sapw_c_bgw * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) + ! Pre-process PAR absorbed per unit leaf area for different schemes + ! par_per_sunla = [W absorbed beam+diffuse radiation / m2 of sunlit leaves] + ! par_per_shala = [W absorbed diffuse radiation / m2 of shaded leaves] + ! fsun = [m2 of sunlit leaves / m2 of total leaves] + ! ------------------------------------------------------------------ + + if_radsolver: if(rad_solver.eq.norman_solver) then + + if(((currentPatch%ed_laisun_z(cl,ft,iv)*currentPatch%canopy_area_profile(cl,ft,iv)) >nearzero) .and. & + (currentPatch%ed_parsun_z(cl,ft,iv)>nearzero)) then + par_per_sunla = currentPatch%ed_parsun_z(cl,ft,iv) / & + (currentPatch%ed_laisun_z(cl,ft,iv)*currentPatch%canopy_area_profile(cl,ft,iv)) + else + par_per_sunla = 0._r8 + end if + + if(((currentPatch%ed_laisha_z(cl,ft,iv)*currentPatch%canopy_area_profile(cl,ft,iv)) >nearzero) .and. & + (currentPatch%ed_parsha_z(cl,ft,iv)>nearzero)) then + par_per_shala = currentPatch%ed_parsha_z(cl,ft,iv) / & + (currentPatch%ed_laisha_z(cl,ft,iv)*currentPatch%canopy_area_profile(cl,ft,iv)) + else + par_per_shala = 0._r8 + end if + + fsun = currentPatch%f_sun(cl,ft,iv) + elai_layer = currentPatch%ed_laisha_z(cl,ft,iv) + currentPatch%ed_laisun_z(cl,ft,iv) + + else + + if(cohort_layer_elai(iv) > nearzero .and. currentPatch%solar_zenith_flag) then + + call FatesGetCohortAbsRad(currentPatch, currentCohort, ipar, & + cohort_vaitop(iv), cohort_vaibot(iv), cohort_elai, cohort_esai, & + rb_abs, rd_abs, rb_abs_leaf, rd_abs_leaf, fsun) + + ! rd_abs_leaf: Watts of diffuse light absorbed by leaves over this + ! depth interval and ground footprint (m2) + ! rd_abs_leaf*fsun Watts of diffuse light absorbed by sunlit leaves + ! over this depth interval and ground footprint (m2) + ! rb_abs_leaf Watts of beam absorbed by sunlit leaves over this + ! depth interval and ground footprint (m2) + ! cohort_layer_elai*fsun Leaf area in sunlight within this interval and ground footprint + ! cohort_layer_elai*(1-fsun) Leaf area in shade within this interval and ground footprint + + if(fsun>nearzero) then + par_per_sunla = (rd_abs_leaf*fsun + rb_abs_leaf) / (fsun*cohort_layer_elai(iv)) + else + par_per_sunla = 0._r8 + end if + par_per_shala = rd_abs_leaf*(1._r8-fsun) / ((1._r8 - fsun)*cohort_layer_elai(iv)) + + else + par_per_sunla = 0._r8 + par_per_shala = 0._r8 + fsun = 0.5_r8 !avoid div0, should have no impact + end if + + elai_layer = cohort_layer_elai(iv) + + end if if_radsolver + - fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(fnrt_organ)) - case(prt_cnp_flex_allom_hyp) + + ! Part VII: Calculate (1) maximum rate of carboxylation (vcmax), + ! (2) maximum electron transport rate, (3) triose phosphate + ! utilization rate and (4) the initial slope of CO2 response curve + ! (C4 plants). Earlier we calculated their base rates as dictated + ! by their plant functional type and some simple scaling rules for + ! nitrogen limitation baesd on canopy position (not prognostic). + ! These rates are the specific rates used in the actual photosynthesis + ! calculations that take localized environmental effects (temperature) + ! into consideration. + + + + call LeafLayerBiophysicalRates(par_per_sunla, & ! in + ft, & ! in + currentCohort%vcmax25top, & ! in + currentCohort%jmax25top, & ! in + currentCohort%kp25top, & ! in + nscaler, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + currentPatch%tveg_lpa%GetMean(), & ! in + currentPatch%tveg_longterm%GetMean(),& ! in + btran_eff, & ! in + vcmax_z, & ! out + jmax_z, & ! out + kp_z ) ! out + + ! Part IX: This call calculates the actual photosynthesis for the + ! leaf layer, as well as the stomatal resistance and the net assimilated carbon. + + call LeafLayerPhotosynthesis(fsun, & ! in + par_per_sunla, & ! in + par_per_shala, & ! in + elai_layer, & ! in + ft, & ! in + vcmax_z, & ! in + jmax_z, & ! in + kp_z, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + bc_in(s)%esat_tv_pa(ifp), & ! in + bc_in(s)%forc_pbot, & ! in + bc_in(s)%cair_pa(ifp), & ! in + bc_in(s)%oair_pa(ifp), & ! in + btran_eff, & ! in + stomatal_intercept_btran, & ! in + cf, & ! in + gb_mol, & ! in + ceair, & ! in + mm_kco2, & ! in + mm_ko2, & ! in + co2_cpoint, & ! in + lmr_z(iv,ft,cl), & ! in + leaf_psi, & ! in + bc_in(s)%rb_pa(ifp), & ! in + currentPatch%psn_z(cl,ft,iv), & ! out + rs_z(iv,ft,cl), & ! out + anet_av_z(iv,ft,cl), & ! out + c13disc_z(cl,ft,iv)) ! out + + rate_mask_z(iv,ft,cl) = .true. + + end if rate_mask_if + end do leaf_layer_loop + + ! Zero cohort flux accumulators. + currentCohort%npp_tstep = 0.0_r8 + currentCohort%resp_tstep = 0.0_r8 + currentCohort%gpp_tstep = 0.0_r8 + currentCohort%rdark = 0.0_r8 + currentCohort%resp_m = 0.0_r8 + currentCohort%ts_net_uptake = 0.0_r8 + currentCohort%c13disc_clm = 0.0_r8 + + ! --------------------------------------------------------------- + ! Part VII: Transfer leaf flux rates (like maintenance respiration, + ! carbon assimilation and conductance) that are defined by the + ! leaf layer (which is area independent, ie /m2) onto each cohort + ! (where the rates become per cohort, ie /individual). Most likely + ! a sum over layers. + ! --------------------------------------------------------------- + nv = currentCohort%nv + call ScaleLeafLayerFluxToCohort(nv, & !in + currentPatch%psn_z(cl,ft,1:nv), & !in + lmr_z(1:nv,ft,cl), & !in + rs_z(1:nv,ft,cl), & !in + !currentPatch%elai_profile(cl,ft,1:nv), & !in + cohort_layer_elai(1:nv), & !in + c13disc_z(cl, ft, 1:nv), & !in + currentCohort%c_area, & !in + currentCohort%n, & !in + bc_in(s)%rb_pa(ifp), & !in + maintresp_reduction_factor, & !in + currentCohort%g_sb_laweight, & !out + currentCohort%gpp_tstep, & !out + currentCohort%rdark, & !out + currentCohort%c13disc_clm, & !out + cohort_eleaf_area) !out + + ! Net Uptake does not need to be scaled, just transfer directly + currentCohort%ts_net_uptake(1:nv) = anet_av_z(1:nv,ft,cl) * umolC_to_kgC - live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & - currentCohort%prt%GetState(sapw_organ, nitrogen_element) + else - live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & - currentCohort%prt%GetState(sapw_organ, nitrogen_element) + ! In this case, the cohort had no leaves, + ! so no productivity,conductance, transpiration uptake + ! or dark respiration + cohort_eleaf_area = 0.0_r8 + currentCohort%gpp_tstep = 0.0_r8 + currentCohort%rdark = 0.0_r8 + currentCohort%g_sb_laweight = 0.0_r8 + currentCohort%ts_net_uptake(:) = 0.0_r8 + end if canopy_mask_if - fnrt_n = currentCohort%prt%GetState(fnrt_organ, nitrogen_element) - if (hlm_use_tree_damage .eq. itrue) then + ! ------------------------------------------------------------------ + ! Part VIII: Calculate maintenance respiration in the sapwood and + ! fine root pools. + ! ------------------------------------------------------------------ - sapw_n = currentCohort%prt%GetState(sapw_organ, nitrogen_element) + ! Calculate the amount of nitrogen in the above and below ground + ! stem and root pools, used for maint resp + ! We are using the fine-root C:N ratio as an approximation for + ! the sapwood pools. + ! Units are in (kgN/plant) + ! ------------------------------------------------------------------ - sapw_n_undamaged = sapw_n / & - (1.0_r8 - (agb_frac * branch_frac * crown_reduction)) - - sapw_n_bgw = sapw_n_undamaged * (1.0_r8 - agb_frac) - sapw_n_agw = sapw_n - sapw_n_bgw + sapw_c = currentCohort%prt%GetState(sapw_organ, carbon12_element) + fnrt_c = currentCohort%prt%GetState(fnrt_organ, carbon12_element) - live_croot_n = sapw_n_bgw + if (hlm_use_tree_damage .eq. itrue) then - live_stem_n = sapw_n_agw + ! Crown damage currenly only reduces the aboveground portion of + ! sapwood. Therefore we calculate the aboveground and the belowground portion + ! sapwood for use in stem respiration. + call GetCrownReduction(currentCohort%crowndamage, crown_reduction) - end if + else + crown_reduction = 0.0_r8 + end if - ! If one wants to break coupling with dynamic N conentrations, - ! use the stoichiometry parameter - ! - ! live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & - ! sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) - ! live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & - ! sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) - ! fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(fnrt_organ)) + ! If crown reduction is zero, undamaged sapwood target will equal sapwood carbon + agb_frac = prt_params%allom_agb_frac(currentCohort%pft) + branch_frac = param_derived%branch_frac(currentCohort%pft) + sapw_c_undamaged = sapw_c / (1.0_r8 - (agb_frac * branch_frac * crown_reduction)) + ! Undamaged below ground portion + sapw_c_bgw = sapw_c_undamaged * (1.0_r8 - agb_frac) - case default + ! Damaged aboveground portion + sapw_c_agw = sapw_c - sapw_c_bgw - end select + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp) - !------------------------------------------------------------------------------ - ! Calculate Whole Plant Respiration - ! (this doesn't really need to be in this iteration at all, surely?) - ! Response: (RGK 12-2016): I think the positioning of these calls is - ! appropriate as of now. Maintenance calculations in sapwood and roots - ! vary by cohort and with changing temperature at the minimum, and there are - ! no sub-pools chopping up those pools any finer that need to be dealt with. - !------------------------------------------------------------------------------ + live_stem_n = sapw_c_agw * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) - ! Live stem MR (kgC/plant/s) (above ground sapwood) - ! ------------------------------------------------------------------ - if ( int(woody(ft)) == itrue) then - tcwood = q10_mr**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) - ! kgC/s = kgN * kgC/kgN/s - currentCohort%livestem_mr = live_stem_n * maintresp_nonleaf_baserate * tcwood * maintresp_reduction_factor - else - currentCohort%livestem_mr = 0._r8 - end if + live_croot_n = sapw_c_bgw * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) + fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(fnrt_organ)) - ! Fine Root MR (kgC/plant/s) - ! and calculate the N fixation rate as a function of the fixation-specific root respiration - ! for now use dev_arbitrary_pft as scaling term between 0 and 1 as additional increment of root respiration used for N fixation - ! ------------------------------------------------------------------ - currentCohort%froot_mr = 0._r8 - currentCohort%sym_nfix_tstep = 0._r8 - - ! n_fixation is integrated over the course of the day - ! this variable is zeroed at the end of the FATES dynamics sequence + case(prt_cnp_flex_allom_hyp) - do j = 1,bc_in(s)%nlevsoil - tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) - - fnrt_mr_layer = fnrt_n * maintresp_nonleaf_baserate * tcsoi * rootfr_ft(ft,j) * maintresp_reduction_factor + live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & + currentCohort%prt%GetState(sapw_organ, nitrogen_element) - ! calculate the cost of carbon for N fixation in each soil layer and calculate N fixation rate based on that [kgC / kgN] + live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & + currentCohort%prt%GetState(sapw_organ, nitrogen_element) - call RootLayerNFixation(bc_in(s)%t_soisno_sl(j),ft,dtime,fnrt_mr_layer,fnrt_mr_nfix_layer,nfix_layer) - - currentCohort%froot_mr = currentCohort%froot_mr + fnrt_mr_nfix_layer + fnrt_mr_layer - currentCohort%sym_nfix_tstep = currentCohort%sym_nfix_tstep + nfix_layer - - - enddo + fnrt_n = currentCohort%prt%GetState(fnrt_organ, nitrogen_element) + + if (hlm_use_tree_damage .eq. itrue) then + + sapw_n = currentCohort%prt%GetState(sapw_organ, nitrogen_element) + + sapw_n_undamaged = sapw_n / & + (1.0_r8 - (agb_frac * branch_frac * crown_reduction)) + + sapw_n_bgw = sapw_n_undamaged * (1.0_r8 - agb_frac) + sapw_n_agw = sapw_n - sapw_n_bgw + + live_croot_n = sapw_n_bgw + + live_stem_n = sapw_n_agw - ! Coarse Root MR (kgC/plant/s) (below ground sapwood) - ! ------------------------------------------------------------------ - if ( int(woody(ft)) == itrue) then - currentCohort%livecroot_mr = 0._r8 - do j = 1,bc_in(s)%nlevsoil - ! Soil temperature used to adjust base rate of MR - tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) - currentCohort%livecroot_mr = currentCohort%livecroot_mr + & - live_croot_n * maintresp_nonleaf_baserate * tcsoi * & - rootfr_ft(ft,j) * maintresp_reduction_factor - enddo - else - currentCohort%livecroot_mr = 0._r8 end if + ! If one wants to break coupling with dynamic N conentrations, + ! use the stoichiometry parameter + ! + ! live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & + ! sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) + ! live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & + ! sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) + ! fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(fnrt_organ)) + - ! ------------------------------------------------------------------ - ! Part IX: Perform some unit conversions (rate to integrated) and - ! calcualate some fluxes that are sums and nets of the base fluxes - ! ------------------------------------------------------------------ + case default - if ( debug ) write(fates_log(),*) 'EDPhoto 904 ', currentCohort%resp_m - if ( debug ) write(fates_log(),*) 'EDPhoto 905 ', currentCohort%rdark - if ( debug ) write(fates_log(),*) 'EDPhoto 906 ', currentCohort%livestem_mr - if ( debug ) write(fates_log(),*) 'EDPhoto 907 ', currentCohort%livecroot_mr - if ( debug ) write(fates_log(),*) 'EDPhoto 908 ', currentCohort%froot_mr + end select + !------------------------------------------------------------------------------ + ! Calculate Whole Plant Respiration + ! (this doesn't really need to be in this iteration at all, surely?) + ! Response: (RGK 12-2016): I think the positioning of these calls is + ! appropriate as of now. Maintenance calculations in sapwood and roots + ! vary by cohort and with changing temperature at the minimum, and there are + ! no sub-pools chopping up those pools any finer that need to be dealt with. + !------------------------------------------------------------------------------ + + ! Live stem MR (kgC/plant/s) (above ground sapwood) + ! ------------------------------------------------------------------ + if ( int(woody(ft)) == itrue) then + tcwood = q10_mr**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) + ! kgC/s = kgN * kgC/kgN/s + currentCohort%livestem_mr = live_stem_n * maintresp_nonleaf_baserate * tcwood * maintresp_reduction_factor + else + currentCohort%livestem_mr = 0._r8 + end if - ! add on whole plant respiration values in kgC/indiv/s-1 - currentCohort%resp_m = currentCohort%livestem_mr + & - currentCohort%livecroot_mr + & - currentCohort%froot_mr - ! no drought response right now.. something like: - ! resp_m = resp_m * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft) * & - ! EDPftvarcon_inst%resp_drought_response(ft)) + ! Fine Root MR (kgC/plant/s) + ! and calculate the N fixation rate as a function of the fixation-specific root respiration + ! for now use dev_arbitrary_pft as scaling term between 0 and 1 as additional increment of root respiration used for N fixation + ! ------------------------------------------------------------------ + currentCohort%froot_mr = 0._r8 + currentCohort%sym_nfix_tstep = 0._r8 - currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark + ! n_fixation is integrated over the course of the day + ! this variable is zeroed at the end of the FATES dynamics sequence - ! save as a diagnostic the un-throttled maintenance respiration to be able to know how strong this is - currentCohort%resp_m_unreduced = currentCohort%resp_m / maintresp_reduction_factor + do j = 1,bc_in(s)%nlevsoil + tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) - ! convert from kgC/indiv/s to kgC/indiv/timestep - currentCohort%resp_m = currentCohort%resp_m * dtime - currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime - currentCohort%ts_net_uptake = currentCohort%ts_net_uptake * dtime + fnrt_mr_layer = fnrt_n * maintresp_nonleaf_baserate * tcsoi * rootfr_ft(ft,j) * maintresp_reduction_factor - if ( debug ) write(fates_log(),*) 'EDPhoto 911 ', currentCohort%gpp_tstep - if ( debug ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep - if ( debug ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m + ! calculate the cost of carbon for N fixation in each soil layer and calculate N fixation rate based on that [kgC / kgN] + call RootLayerNFixation(bc_in(s)%t_soisno_sl(j),ft,dtime,fnrt_mr_layer,fnrt_mr_nfix_layer,nfix_layer) - currentCohort%resp_g_tstep = prt_params%grperc(ft) * & - (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) + currentCohort%froot_mr = currentCohort%froot_mr + fnrt_mr_nfix_layer + fnrt_mr_layer + currentCohort%sym_nfix_tstep = currentCohort%sym_nfix_tstep + nfix_layer - currentCohort%resp_tstep = currentCohort%resp_m + & - currentCohort%resp_g_tstep ! kgC/indiv/ts - currentCohort%npp_tstep = currentCohort%gpp_tstep - & - currentCohort%resp_tstep ! kgC/indiv/ts - ! Accumulate the combined conductance (stomatal+leaf boundary layer) - ! Note that currentCohort%g_sb_laweight is weighted by the leaf area - ! of each cohort and has units of [m/s] * [m2 leaf] + enddo - g_sb_leaves = g_sb_leaves + currentCohort%g_sb_laweight + ! Coarse Root MR (kgC/plant/s) (below ground sapwood) + ! ------------------------------------------------------------------ + if ( int(woody(ft)) == itrue) then + currentCohort%livecroot_mr = 0._r8 + do j = 1,bc_in(s)%nlevsoil + ! Soil temperature used to adjust base rate of MR + tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) + currentCohort%livecroot_mr = currentCohort%livecroot_mr + & + live_croot_n * maintresp_nonleaf_baserate * tcsoi * & + rootfr_ft(ft,j) * maintresp_reduction_factor + enddo + else + currentCohort%livecroot_mr = 0._r8 + end if - ! Accumulate the total effective leaf area from all cohorts - ! in this patch. Normalize by canopy area outside the loop - check_elai = check_elai + cohort_eleaf_area - currentCohort => currentCohort%shorter + ! ------------------------------------------------------------------ + ! Part IX: Perform some unit conversions (rate to integrated) and + ! calcualate some fluxes that are sums and nets of the base fluxes + ! ------------------------------------------------------------------ - enddo ! end cohort loop. - end if !count_cohorts is more than zero. + if ( debug ) write(fates_log(),*) 'EDPhoto 904 ', currentCohort%resp_m + if ( debug ) write(fates_log(),*) 'EDPhoto 905 ', currentCohort%rdark + if ( debug ) write(fates_log(),*) 'EDPhoto 906 ', currentCohort%livestem_mr + if ( debug ) write(fates_log(),*) 'EDPhoto 907 ', currentCohort%livecroot_mr + if ( debug ) write(fates_log(),*) 'EDPhoto 908 ', currentCohort%froot_mr - check_elai = check_elai / currentPatch%total_canopy_area - elai = calc_areaindex(currentPatch,'elai') + + + ! add on whole plant respiration values in kgC/indiv/s-1 + currentCohort%resp_m = currentCohort%livestem_mr + & + currentCohort%livecroot_mr + & + currentCohort%froot_mr + + ! no drought response right now.. something like: + ! resp_m = resp_m * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft) * & + ! EDPftvarcon_inst%resp_drought_response(ft)) + + currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark + + ! save as a diagnostic the un-throttled maintenance respiration to be able to know how strong this is + currentCohort%resp_m_unreduced = currentCohort%resp_m / maintresp_reduction_factor + + ! convert from kgC/indiv/s to kgC/indiv/timestep + currentCohort%resp_m = currentCohort%resp_m * dtime + currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime + currentCohort%ts_net_uptake = currentCohort%ts_net_uptake * dtime + + if ( debug ) write(fates_log(),*) 'EDPhoto 911 ', currentCohort%gpp_tstep + if ( debug ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep + if ( debug ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m + + + currentCohort%resp_g_tstep = prt_params%grperc(ft) * & + (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) + + + currentCohort%resp_tstep = currentCohort%resp_m + & + currentCohort%resp_g_tstep ! kgC/indiv/ts + currentCohort%npp_tstep = currentCohort%gpp_tstep - & + currentCohort%resp_tstep ! kgC/indiv/ts + + ! Accumulate the combined conductance (stomatal+leaf boundary layer) + ! Note that currentCohort%g_sb_laweight is weighted by the leaf area + ! of each cohort and has units of [m/s] * [m2 leaf] + + g_sb_leaves = g_sb_leaves + currentCohort%g_sb_laweight + + ! Accumulate the total effective leaf area from all cohorts + ! in this patch. Normalize by canopy area outside the loop + patch_la = patch_la + cohort_eleaf_area + + currentCohort => currentCohort%shorter + enddo do_cohort_drive ! Normalize canopy total conductance by the effective LAI ! The value here was integrated over each cohort x leaf layer ! and was weighted by m2 of effective leaf area for each layer - if(check_elai>tiny(check_elai)) then + if(patch_la>nearzero) then ! Normalize the leaf-area weighted canopy conductance ! The denominator is the total effective leaf area in the canopy, ! units of [m/s]*[m2] / [m2] = [m/s] - g_sb_leaves = g_sb_leaves / (elai*currentPatch%total_canopy_area) + !g_sb_leaves = g_sb_leaves / (elai*currentPatch%total_canopy_area) + g_sb_leaves = g_sb_leaves / max(0.1_r8*currentPatch%total_canopy_area,patch_la) + if( g_sb_leaves > (1._r8/rsmax0) ) then ! Combined mean leaf resistance is the inverse of mean leaf conductance @@ -947,7 +1051,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! is what is used in the field usually, so we track that form currentPatch%c_lblayer = cf / bc_in(s)%rb_pa(ifp) - end if + end if if_filter2 end if ! not bare ground patch currentPatch => currentPatch%younger @@ -1023,9 +1127,7 @@ end subroutine RootLayerNFixation subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in parsun_lsl, & ! in parsha_lsl, & ! in - laisun_lsl, & ! in - laisha_lsl, & ! in - canopy_area_lsl, & ! in + elai_lsl, & ! in ft, & ! in vcmax, & ! in jmax, & ! in @@ -1067,11 +1169,9 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! Arguments ! ------------------------------------------------------------------------------------ real(r8), intent(in) :: f_sun_lsl ! - real(r8), intent(in) :: parsun_lsl ! Absorbed PAR in sunlist leaves - real(r8), intent(in) :: parsha_lsl ! Absorved PAR in shaded leaves - real(r8), intent(in) :: laisun_lsl ! LAI in sunlit leaves - real(r8), intent(in) :: laisha_lsl ! LAI in shaded leaves - real(r8), intent(in) :: canopy_area_lsl ! + real(r8), intent(in) :: parsun_lsl ! Absorbed PAR in sunlist leaves per sunlit leaf area [W/m2 leaf] + real(r8), intent(in) :: parsha_lsl ! Absorved PAR in shaded leaves per shaded leaf area [W/m2 leaf] + real(r8), intent(in) :: elai_lsl ! ELAI of this layer [m2/m2] integer, intent(in) :: ft ! (plant) Functional Type Index real(r8), intent(in) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) real(r8), intent(in) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) @@ -1201,7 +1301,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! Is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) - if_leafarea: if ( laisun_lsl + laisha_lsl > 0._r8 ) then + if_leafarea: if ( elai_lsl > 0._r8 ) then !Loop aroun shaded and unshaded leaves psn_out = 0._r8 ! psn is accumulated across sun and shaded leaves. @@ -1216,19 +1316,9 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! absorbed per unit leaf area. if(sunsha == 1)then !sunlit - if(( laisun_lsl * canopy_area_lsl) > 0.0000000001_r8)then - - qabs = parsun_lsl / (laisun_lsl * canopy_area_lsl ) - qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 - - else - qabs = 0.0_r8 - end if + qabs = parsun_lsl * qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 else - - qabs = parsha_lsl / (laisha_lsl * canopy_area_lsl) - qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 - + qabs = parsha_lsl * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 end if !convert the absorbed par into absorbed par per m2 of leaf, @@ -1276,17 +1366,9 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! C4: RuBP-limited photosynthesis if(sunsha == 1)then !sunlit - !guard against /0's in the night. - if((laisun_lsl * canopy_area_lsl) > 0.0000000001_r8) then - aj = quant_eff(c3c4_path_index) * parsun_lsl * 4.6_r8 - !convert from per cohort to per m2 of leaf) - aj = aj / (laisun_lsl * canopy_area_lsl) - else - aj = 0._r8 - end if + aj = quant_eff(c3c4_path_index) * parsun_lsl * 4.6_r8 else aj = quant_eff(c3c4_path_index) * parsha_lsl * 4.6_r8 - aj = aj / (laisha_lsl * canopy_area_lsl) end if ! C4: PEP carboxylase-limited (CO2-limited) From a11d4ae741e29b0cc8f39eb1e696a4cec8774bf7 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 16 May 2023 12:52:15 -0400 Subject: [PATCH 056/250] cleaning up two-stream calls and comments --- biogeochem/EDCanopyStructureMod.F90 | 140 ++++++--------------- biogeochem/EDPatchDynamicsMod.F90 | 9 ++ biogeophys/FatesPlantRespPhotosynthMod.F90 | 6 +- radiation/FatesRadiationDriveMod.F90 | 119 +++++++++++++++--- 4 files changed, 148 insertions(+), 126 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 3ce5f38e29..964d760aea 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -20,6 +20,7 @@ module EDCanopyStructureMod use EDCohortDynamicsMod , only : InitPRTBoundaryConditions use FatesAllometryMod , only : tree_lai use FatesAllometryMod , only : tree_sai + use FatesAllometryMod , only : VegAreaLayer use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use EDTypesMod , only : nclmax use EDTypesMod , only : nlevleaf @@ -42,7 +43,9 @@ module EDCanopyStructureMod use PRTGenericMod, only : struct_organ use PRTGenericMod, only : SetState use PRTGenericMod, only : carbon12_element - + use FatesAllometryMod , only : VegAreaLayer + use FatesTwoStreamInterfaceMod, only : FatesConstructRadElements + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -1432,10 +1435,11 @@ subroutine canopy_summarization( nsites, sites, bc_in ) currentPatch => currentPatch%younger end do !patch loop - - call leaf_area_profile(sites(s)) + call FatesConstructRadElements(sites(s),bc_in(s)%fcansno_pa,bc_in(s)%coszen_pa) + + end do ! site loop return @@ -1493,8 +1497,6 @@ subroutine leaf_area_profile( currentSite ) ! currentPatch%esai_profile(cl,ft,iv) ! non-snow covered m2 of stems per m2 of PFT footprint ! currentPatch%canopy_area_profile(cl,ft,iv) ! Fractional area of leaf layer ! ! relative to vegetated area - ! currentPatch%layer_height_profile(cl,ft,iv) ! Elevation of layer in m - ! ! ----------------------------------------------------------------------------------- ! !USES: @@ -1516,17 +1518,16 @@ subroutine leaf_area_profile( currentSite ) integer :: iv ! Vertical leaf layer index integer :: cl ! Canopy layer index real(r8) :: fraction_exposed ! how much of this layer is not covered by snow? - real(r8) :: layer_top_hite ! notional top height of this canopy layer (m) - real(r8) :: layer_bottom_hite ! notional bottom height of this canopy layer (m) real(r8) :: frac_canopy(N_HITE_BINS) ! amount of canopy in each height class real(r8) :: minh(N_HITE_BINS) ! minimum height in height class (m) real(r8) :: maxh(N_HITE_BINS) ! maximum height in height class (m) real(r8) :: dh ! vertical detph of height class (m) real(r8) :: min_chite ! bottom of cohort canopy (m) real(r8) :: max_chite ! top of cohort canopy (m) - real(r8) :: lai ! leaf area per canopy area - real(r8) :: sai ! stem area per canopy area - + real(r8) :: elai_layer,tlai_layer ! leaf area per canopy area + real(r8) :: esai_layer,tsai_layer ! stem area per canopy area + real(r8) :: vai_top,vai_bot ! integrated top down veg area index at boundary of layer + !---------------------------------------------------------------------- @@ -1550,7 +1551,6 @@ subroutine leaf_area_profile( currentSite ) currentPatch%tsai_profile(:,:,:) = 0._r8 currentPatch%elai_profile(:,:,:) = 0._r8 currentPatch%esai_profile(:,:,:) = 0._r8 - currentPatch%layer_height_profile(:,:,:) = 0._r8 currentPatch%canopy_area_profile(:,:,:) = 0._r8 currentPatch%canopy_mask(:,:) = 0 @@ -1563,6 +1563,8 @@ subroutine leaf_area_profile( currentSite ) call UpdatePatchLAI(currentPatch) + currentPatch%nrad(:,:) = currentPatch%ncan(:,:) + ! ----------------------------------------------------------------------------- ! Standard canopy layering model. ! Go through all cohorts and add their leaf area @@ -1573,103 +1575,32 @@ subroutine leaf_area_profile( currentSite ) do while(associated(currentCohort)) ft = currentCohort%pft cl = currentCohort%canopy_layer - - ! ---------------------------------------------------------------- - ! How much of each tree is stem area index? Assuming that there is - ! This may indeed be zero if there is a sensecent grass - ! ---------------------------------------------------------------- - lai = currentCohort%treelai * currentCohort%c_area/currentPatch%total_canopy_area - sai = currentCohort%treesai * currentCohort%c_area/currentPatch%total_canopy_area - if( (currentCohort%treelai+currentCohort%treesai) > nearzero)then - - ! See issue: https://github.com/NGEET/fates/issues/899 - ! fleaf = currentCohort%treelai / (currentCohort%treelai + currentCohort%treesai) - fleaf = lai / (lai+sai) - else - fleaf = 0._r8 - endif - - currentPatch%nrad(cl,ft) = currentPatch%ncan(cl,ft) - - if (currentPatch%nrad(cl,ft) > nlevleaf ) then - write(fates_log(), *) 'Number of radiative leaf layers is larger' - write(fates_log(), *) ' than the maximum allowed.' - write(fates_log(), *) ' cl: ',cl - write(fates_log(), *) ' ft: ',ft - write(fates_log(), *) ' nlevleaf: ',nlevleaf - write(fates_log(), *) ' currentPatch%nrad(cl,ft): ', currentPatch%nrad(cl,ft) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - ! -------------------------------------------------------------------------- - ! Whole layers. Make a weighted average of the leaf area in each layer - ! before dividing it by the total area. Fill up layer for whole layers. - ! -------------------------------------------------------------------------- - + do iv = 1,currentCohort%NV - ! This loop builds the arrays that define the effective (not snow covered) - ! and total (includes snow covered) area indices for leaves and stems - ! We calculate the absolute elevation of each layer to help determine if the layer - ! is obscured by snow. - - layer_top_hite = currentCohort%hite - & - ( real(iv-1,r8)/currentCohort%NV * currentCohort%hite * & - prt_params%crown_depth_frac(currentCohort%pft) ) - - layer_bottom_hite = currentCohort%hite - & - ( real(iv,r8)/currentCohort%NV * currentCohort%hite * & - prt_params%crown_depth_frac(currentCohort%pft) ) - - fraction_exposed = 1.0_r8 - if(currentSite%snow_depth > layer_top_hite)then - fraction_exposed = 0._r8 - endif - if(currentSite%snow_depth < layer_bottom_hite)then - fraction_exposed = 1._r8 - endif - if(currentSite%snow_depth >= layer_bottom_hite .and. & - currentSite%snow_depth <= layer_top_hite) then !only partly hidden... - fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(currentSite%snow_depth -layer_bottom_hite)/ & - (layer_top_hite-layer_bottom_hite )))) - endif - - if(iv==currentCohort%NV) then - remainder = (currentCohort%treelai + currentCohort%treesai) - & - (dlower_vai(iv) - dinc_vai(iv)) - if(remainder > dinc_vai(iv) )then - write(fates_log(), *)'ED: issue with remainder', & - currentCohort%treelai,currentCohort%treesai,dinc_vai(iv), & - currentCohort%NV,remainder - - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - else - remainder = dinc_vai(iv) - end if + call VegAreaLayer(currentCohort%treelai, & + currentCohort%treesai, & + currentCohort%hite, & + iv,currentCohort%nv,currentCohort%pft, & + currentSite%snow_depth, & + vai_top,vai_bot, & + elai_layer,esai_layer,tlai_layer,tsai_layer) currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) + & - remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area + tlai_layer * currentCohort%c_area/currentPatch%total_canopy_area currentPatch%elai_profile(cl,ft,iv) = currentPatch%elai_profile(cl,ft,iv) + & - remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & - fraction_exposed + elai_layer * currentCohort%c_area/currentPatch%total_canopy_area currentPatch%tsai_profile(cl,ft,iv) = currentPatch%tsai_profile(cl,ft,iv) + & - remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area - + tsai_layer * currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%esai_profile(cl,ft,iv) = currentPatch%esai_profile(cl,ft,iv) + & - remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area * & - fraction_exposed + esai_layer * currentCohort%c_area/currentPatch%total_canopy_area currentPatch%canopy_area_profile(cl,ft,iv) = currentPatch%canopy_area_profile(cl,ft,iv) + & currentCohort%c_area/currentPatch%total_canopy_area - currentPatch%layer_height_profile(cl,ft,iv) = currentPatch%layer_height_profile(cl,ft,iv) + & - (remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & - (layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. - end do currentCohort => currentCohort%taller @@ -1758,11 +1689,6 @@ subroutine leaf_area_profile( currentSite ) currentPatch%canopy_area_profile(cl,ft,iv) end if - if(currentPatch%tlai_profile(cl,ft,iv)>nearzero )then - currentPatch%layer_height_profile(cl,ft,iv) = currentPatch%layer_height_profile(cl,ft,iv) & - /currentPatch%tlai_profile(cl,ft,iv) - end if - enddo enddo @@ -1770,16 +1696,22 @@ subroutine leaf_area_profile( currentSite ) ! -------------------------------------------------------------------------- ! Set the mask that identifies which PFT x can-layer combinations have - ! scattering elements in them. + ! scattering elements in them for radiation. + ! RGK: I'm not sure we need nrad ... I can't see a scenario where + ! canopy_area_profile for these layers is not >0 for layers in ncan ... + ! Leaving this for the time being. ! -------------------------------------------------------------------------- - + currentPatch%canopy_mask(:,:) = 0 do cl = 1,currentPatch%NCL_p do ft = 1,numpft - do iv = 1, currentPatch%nrad(cl,ft) + do_leaflayer: do iv = 1, currentPatch%nrad(cl,ft) if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then currentPatch%canopy_mask(cl,ft) = 1 + exit do_leaflayer + else + exit do_leaflayer endif - end do !iv + end do do_leaflayer !iv enddo !ft enddo ! loop over cl diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index ae42cbc754..fc80db8146 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2140,6 +2140,10 @@ subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) new_patch%older => null() ! pointer to next older patch new_patch%younger => null() ! pointer to next shorter patch + new_patch%twostr%scelg => null() ! The radiation module will check if this + ! is associated, since it is not, then it will + ! initialize and allocate + ! assign known patch attributes new_patch%age = age @@ -3045,6 +3049,11 @@ subroutine dealloc_patch(cpatch) end do + ! Deallocate Radiation scattering elements + if(associated(cpatch%twostr%scelg)) then + call cpatch%twostr%DeallocTwoStream() + end if + ! Deallocate all litter objects do el=1,num_elements call cpatch%litter(el)%DeallocateLitt() diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 8733a35b97..01d9313846 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -2269,7 +2269,7 @@ end subroutine LeafLayerMaintenanceRespiration_Atkin_etal_2017 ! ==================================================================================== -subroutine LeafLayerBiophysicalRates( parsun_lsl, & +subroutine LeafLayerBiophysicalRates( parsun_per_la, & ft, & vcmax25top_ft, & jmax25top_ft, & @@ -2301,7 +2301,7 @@ subroutine LeafLayerBiophysicalRates( parsun_lsl, & ! Arguments ! ------------------------------------------------------------------------------ - real(r8), intent(in) :: parsun_lsl ! PAR absorbed in sunlit leaves for this layer + real(r8), intent(in) :: parsun_per_la ! PAR absorbed per sunlit leaves for this layer integer, intent(in) :: ft ! (plant) Functional Type Index real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile real(r8), intent(in) :: vcmax25top_ft ! canopy top maximum rate of carboxylation at 25C @@ -2370,7 +2370,7 @@ subroutine LeafLayerBiophysicalRates( parsun_lsl, & vcmaxc = fth25_f(vcmaxhd, vcmaxse) jmaxc = fth25_f(jmaxhd, jmaxse) - if ( parsun_lsl <= 0._r8) then ! night time + if ( parsun_per_la <= nearzero) then ! night time vcmax = 0._r8 jmax = 0._r8 co2_rcurve_islope = 0._r8 diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index 5c7bf7a0e8..eab926f048 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -54,7 +54,17 @@ module FatesRadiationDriveMod contains subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) - + + ! Perform normalized (ie per unit downwelling radiative forcing) radiation + ! scattering of the vegetation canopy. + ! This call is normalized because the host wants an albedo for the next time + ! step, but it does not have the absolute beam and diffuse forcing for the + ! next step yet. + ! However, with both Norman and Two stream, we save normalized scattering + ! and absorption profiles amonst the vegetation, and that can + ! be scaled by the forcing when we perform diagnostics, calculate heating + ! rates (HLM side), and calculate absorbed leaf PAR for photosynthesis. + ! ! !USES: use EDPftvarcon , only : EDPftvarcon_inst @@ -75,7 +85,13 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) integer :: ifp ! patch loop counter integer :: ib ! radiation broad band counter type(ed_patch_type), pointer :: currentPatch ! patch pointer - + real(r8) :: Rdiff_up_atm_beam ! Upwelling diffuse radiation at top from beam scattering [W/m2 ground] + real(r8) :: Rdiff_up_atm_diff ! Upwelling diffuse radiation at top from diffuse scattering [W/m2 ground] + real(r8) :: Rbeam_can_abs ! Total beam radiation absorbed by the canopy [W/m2 ground] + real(r8) :: Rdiff_can_abs ! Total diffuse radiation absorbed by the canopy [W/m2 ground] + real(r8) :: Rbeam_dn_grnd_beam ! Average beam radiation at ground [W/m2 ground] + real(r8) :: Rdiff_dn_grnd_beam ! Average downward diffuse radiation at ground due to beam sourcing [W/m2 ground] + real(r8) :: Rdiff_dn_grnd_diff ! Average downward diffuse radiation at ground from diffuse sourcing [W/m2 ground] !----------------------------------------------------------------------- ! ------------------------------------------------------------------------------- ! TODO (mv, 2014-10-29) the filter here is different than below @@ -90,7 +106,7 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) - if(currentpatch%nocomp_pft_label.ne.nocomp_bareground)then + if_notbareground: if(currentpatch%nocomp_pft_label.ne.nocomp_bareground)then ! do not do albedo calculations for bare ground patch in SP mode ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein ! ifp=1 is the first vegetated patch. @@ -116,7 +132,14 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) currentPatch%gnd_alb_dir(1:hlm_numSWb) = bc_in(s)%albgr_dir_rb(1:hlm_numSWb) currentPatch%fcansno = bc_in(s)%fcansno_pa(ifp) - if(currentPatch%solar_zenith_flag )then + ! RGK: The ZenithPrep should only be necessary if the flag is true + ! Move and test this. + if(rad_solver.eq.twostr_solver) then + call currentPatch%twostr%CanopyPrep(bc_in(s)%fcansno_pa(ifp)) + call currentPatch%twostr%ZenithPrep(bc_in(s)%coszen_pa(ifp)) + end if + + if_zenith_flag: if(currentPatch%solar_zenith_flag )then bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM @@ -126,7 +149,7 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM - if (maxval(currentPatch%nrad(1,:))==0)then + if_nrad: if (maxval(currentPatch%nrad(1,:))==0)then !there are no leaf layers in this patch. it is effectively bare ground. ! no radiation is absorbed bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 @@ -137,27 +160,54 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 - !bc_out(s)%ftid_parb(ifp,ib)= 1.0_r8 bc_out(s)%ftid_parb(ifp,ib)= 0.0_r8 bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 enddo else - call PatchNormanRadiation (currentPatch, & - bc_out(s)%albd_parb(ifp,:), & - bc_out(s)%albi_parb(ifp,:), & - bc_out(s)%fabd_parb(ifp,:), & - bc_out(s)%fabi_parb(ifp,:), & - bc_out(s)%ftdd_parb(ifp,:), & - bc_out(s)%ftid_parb(ifp,:), & - bc_out(s)%ftii_parb(ifp,:)) + if_solver: if(rad_solver.eq.norman_solver) then + + call PatchNormanRadiation (currentPatch, & + bc_out(s)%albd_parb(ifp,:), & ! Surface Albedo direct + bc_out(s)%albi_parb(ifp,:), & ! Surface Albedo (indirect) diffuse + bc_out(s)%fabd_parb(ifp,:), & ! Fraction direct absorbed by canopy per unit incident + bc_out(s)%fabi_parb(ifp,:), & ! Fraction diffuse absorbed by canopy per unit incident + bc_out(s)%ftdd_parb(ifp,:), & ! Down direct flux below canopy per unit direct at top + bc_out(s)%ftid_parb(ifp,:), & ! Down diffuse flux below canopy per unit direct at top + bc_out(s)%ftii_parb(ifp,:)) ! Down diffuse flux below canopy per unit diffuse at top + + else + + associate( twostr => currentPatch%twostr) + + !call twostr%CanopyPrep(bc_in(s)%fcansno_pa(ifp)) + !call twostr%ZenithPrep(bc_in(s)%coszen_pa(ifp)) + do ib = 1,hlm_numSWb - endif ! is there vegetation? + twostr%band(ib)%albedo_grnd_diff = bc_in(s)%albgr_dif_rb(ib) + twostr%band(ib)%albedo_grnd_beam = bc_in(s)%albgr_dir_rb(ib) - end if ! if the vegetation and zenith filter is active - endif ! not bare ground + call twostr%Solve(ib, & ! in + normalized_upper_boundary, & ! in + 1.0_r8,1.0_r8, & ! in + bc_out(s)%albd_parb(ifp,ib), & ! out + bc_out(s)%albi_parb(ifp,ib), & ! out + bc_out(s)%fabd_parb(ifp,ib), & ! out + bc_out(s)%fabi_parb(ifp,ib), & ! out + bc_out(s)%ftdd_parb(ifp,ib), & ! out + bc_out(s)%ftid_parb(ifp,ib), & ! out + bc_out(s)%ftii_parb(ifp,ib)) + + end do + end associate + + end if if_solver + end if if_nrad + endif if_zenith_flag + end if if_notbareground + currentPatch => currentPatch%younger end do ! Loop linked-list patches enddo ! Loop Sites @@ -1132,7 +1182,7 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) cpatch => sites(s)%oldest_patch do while (associated(cpatch)) - if(cpatch%nocomp_pft_label.ne.nocomp_bareground)then !only for veg patches + if_notbareground:if(cpatch%nocomp_pft_label.ne.nocomp_bareground)then !only for veg patches ! do not do albedo calculations for bare ground patch in SP mode ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein ! ifp=1 is the first vegetated patch. @@ -1156,6 +1206,8 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) cpatch%parprof_dir_z(:,:) = 0._r8 cpatch%parprof_dif_z(:,:) = 0._r8 + if_norm_twostr: if (rad_solver.eq.norman_solver) then + ! Loop over patches to calculate laisun_z and laisha_z for each layer. ! Derive canopy laisun, laisha, and fsun from layer sums. ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from @@ -1278,7 +1330,36 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) cpatch%nrmlzd_parprof_dif_z(idiffuse,CL,iv)) end do ! iv end do ! CL - endif ! not bareground patch + + else + + ! Two-stream + ! ----------------------------------------------------------- + do ib = 1,hlm_numSWb + cpatch%twostr%band(ib)%Rbeam_atm = bc_in(s)%solad_parb(ifp,ib) + cpatch%twostr%band(ib)%Rdiff_atm = bc_in(s)%solai_parb(ifp,ib) + end do + + if(cpatch%solar_zenith_flag )then + call FatesPatchFSun(cpatch, & + bc_out(s)%fsun_pa(ifp), & + bc_out(s)%laisun_pa(ifp), & + bc_out(s)%laisha_pa(ifp)) + + call CheckPatchRadiationBalance(cpatch, sites(s)%snow_depth, ivis,bc_out(s)%fabd_parb(ifp,ivis), bc_out(s)%fabi_parb(ifp,ivis)) + call CheckPatchRadiationBalance(cpatch, sites(s)%snow_depth, inir,bc_out(s)%fabd_parb(ifp,inir), bc_out(s)%fabi_parb(ifp,inir)) + else + + bc_out(s)%fsun_pa(ifp) = 0.5_r8 + bc_out(s)%laisun_pa(ifp) = 0.5_r8*calc_areaindex(cpatch,'elai') + bc_out(s)%laisha_pa(ifp) = 0.5_r8*calc_areaindex(cpatch,'elai') + + end if + + + end if if_norm_twostr + + endif if_notbareground cpatch => cpatch%younger enddo From b7863082ede966621599349bb11b2193a4fed9f9 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 19 May 2023 10:02:59 -0400 Subject: [PATCH 057/250] Added fsun to history diagnostics,testing different fsun formulations in two-stream --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 13 +- .../radiation/RadiationUTestDriver.py | 1018 +++++++++++++++++ .../radiation/build_radiation_f90_objects.sh | 24 + .../radiation/f90_src/RadiationWrapMod.F90 | 265 +++++ .../shared/py_src/PyF90Utils.py | 3 + main/FatesHistoryInterfaceMod.F90 | 32 +- radiation/FatesRadiationDriveMod.F90 | 2 +- radiation/FatesRadiationMemMod.F90 | 2 +- radiation/FatesTwoStreamInterfaceMod.F90 | 2 +- radiation/TwoStreamMLPEMod.F90 | 31 +- 10 files changed, 1367 insertions(+), 25 deletions(-) create mode 100644 functional_unit_testing/radiation/RadiationUTestDriver.py create mode 100755 functional_unit_testing/radiation/build_radiation_f90_objects.sh create mode 100644 functional_unit_testing/radiation/f90_src/RadiationWrapMod.F90 diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 01d9313846..8fe13fb654 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -644,7 +644,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! depth interval and ground footprint (m2) ! cohort_layer_elai*fsun Leaf area in sunlight within this interval and ground footprint ! cohort_layer_elai*(1-fsun) Leaf area in shade within this interval and ground footprint - + if(fsun>nearzero) then par_per_sunla = (rd_abs_leaf*fsun + rb_abs_leaf) / (fsun*cohort_layer_elai(iv)) else @@ -662,9 +662,6 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) end if if_radsolver - - - ! Part VII: Calculate (1) maximum rate of carboxylation (vcmax), ! (2) maximum electron transport rate, (3) triose phosphate ! utilization rate and (4) the initial slope of CO2 response curve @@ -675,8 +672,6 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! calculations that take localized environmental effects (temperature) ! into consideration. - - call LeafLayerBiophysicalRates(par_per_sunla, & ! in ft, & ! in currentCohort%vcmax25top, & ! in @@ -1722,11 +1717,11 @@ subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv ! [m/s] * [m2 cohort's leaf layer] g_sb_laweight = g_sb_laweight + 1.0_r8/(rs_llz(il)+rb) * cohort_layer_eleaf_area - ! GPP [umolC/m2leaf/s] * [m2 leaf ] -> [umolC/s] (This is cohort group sum) + ! GPP [umolC/m2leaf/s] * [m2 leaf ] -> [umolC/s] gpp = gpp + psn_llz(il) * cohort_layer_eleaf_area ! Dark respiration - ! [umolC/m2leaf/s] * [m2 leaf] (This is the cohort group sum) + ! [umolC/m2leaf/s] * [m2 leaf] rdark = rdark + lmr_llz(il) * cohort_layer_eleaf_area end do @@ -2181,6 +2176,8 @@ subroutine LeafLayerMaintenanceRespiration_Ryan_1991(lnc_top, & real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) real(r8) :: lmr25top ! canopy top leaf maint resp rate at 25C for this pft (umol CO2/m**2/s) + + ! Parameter real(r8), parameter :: lmrha = 46390._r8 ! activation energy for lmr (J/mol) real(r8), parameter :: lmrhd = 150650._r8 ! deactivation energy for lmr (J/mol) diff --git a/functional_unit_testing/radiation/RadiationUTestDriver.py b/functional_unit_testing/radiation/RadiationUTestDriver.py new file mode 100644 index 0000000000..d11432da6c --- /dev/null +++ b/functional_unit_testing/radiation/RadiationUTestDriver.py @@ -0,0 +1,1018 @@ +# ======================================================================================= +# +# For usage: $python RadiationUTestDriver.py --help +# +# This script runs unit tests on the two-stream functions. +# +# +# ======================================================================================= + +import matplotlib as mpl +#mpl.use('Agg') +import matplotlib.pyplot as plt +from datetime import datetime +import argparse +#from matplotlib.backends.backend_pdf import PdfPages +import platform +import numpy as np +import matplotlib +import os +import sys +import getopt +#import code # For development: code.interact(local=dict(globals(), **locals())) +import code # For development: code.interact(local=locals()) code.interact(local=dict(globals(), **locals())) +import time +import importlib +import csv +import ctypes +from ctypes import * +from operator import add +sys.path.append('../shared/py_src') +from PyF90Utils import c8, ci, cchar, c8_arr, ci_arr, ccharnb + +font = {'family' : 'sans-serif', + 'weight' : 'normal', + 'size' : 12} + +matplotlib.rc('font', **font) + + +# Instantiate the F90 modules +f90_mem_obj = ctypes.CDLL('bld/FatesRadiationMemMod.o',mode=ctypes.RTLD_GLOBAL) +f90_twostr_obj = ctypes.CDLL('bld/TwoStreamMLPEMod.o',mode=ctypes.RTLD_GLOBAL) +f90_wrap_obj = ctypes.CDLL('bld/RadiationWrapMod.o',mode=ctypes.RTLD_GLOBAL) + + +# Create aliases for the calls and define arguments if it helps with clarity +alloc_twostream_call = f90_wrap_obj.__radiationwrapmod_MOD_initallocate +dealloc_twostream_call = f90_wrap_obj.__radiationwrapmod_MOD_dealloc +alloc_radparams_call = f90_twostr_obj.__twostreammlpemod_MOD_allocateradparams +set_radparams_call = f90_wrap_obj.__radiationwrapmod_MOD_setradparam +set_radparams_call.argtypes = [POINTER(c_double),POINTER(c_int),POINTER(c_int),c_char_p,c_long] +param_prep_call = f90_twostr_obj.__twostreammlpemod_MOD_paramprep + +setup_canopy_call = f90_wrap_obj.__radiationwrapmod_MOD_setupcanopy +setup_canopy_call.argtypes = [POINTER(c_int),POINTER(c_int),POINTER(c_int), \ + POINTER(c_double),POINTER(c_double),POINTER(c_double)] + +grndsnow_albedo_call = f90_wrap_obj.__radiationwrapmod_MOD_setgroundsnow +grndsnow_albedo_call.argtypes = [POINTER(c_int),POINTER(c_double),c_char_p,c_long] + +canopy_prep_call = f90_wrap_obj.__radiationwrapmod_MOD_wrapcanopyprep +zenith_prep_call = f90_wrap_obj.__radiationwrapmod_MOD_wrapzenithprep +solver_call = f90_wrap_obj.__radiationwrapmod_MOD_wrapsolve +setdown_call = f90_wrap_obj.__radiationwrapmod_MOD_wrapsetdownwelling + +getintens_call = f90_wrap_obj.__radiationwrapmod_MOD_wrapgetintensity +getabsrad_call = f90_wrap_obj.__radiationwrapmod_MOD_wrapgetabsrad +getparams_call = f90_wrap_obj.__radiationwrapmod_MOD_wrapgetparams +forceparam_call = f90_wrap_obj.__radiationwrapmod_MOD_wrapforceparams +forceparam_call.argtypes = [POINTER(c_int),POINTER(c_int),POINTER(c_int),POINTER(c_double),c_char_p,c_long] + +leaf_rhonir = [0.46, 0.41, 0.39, 0.46, 0.41, 0.41, 0.46, 0.41, 0.41, 0.28, 0.28, 0.28 ] +leaf_rhovis = [0.11, 0.09, 0.08, 0.11, 0.08, 0.08, 0.11, 0.08, 0.08, 0.05, 0.05, 0.05 ] +leaf_taunir = [0.33, 0.32, 0.42, 0.33, 0.43, 0.43, 0.33, 0.43, 0.43, 0.4, 0.4, 0.4 ] +leaf_tauvis = [0.06, 0.04, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.05, 0.05, 0.05] +leaf_xl = [0.32, 0.01, 0.01, 0.32, 0.2, 0.59, 0.32, 0.59, 0.59, -0.23, -0.23, -0.23] +leaf_clumping_index = [0.85, 0.85, 0.8, 0.85, 0.85, 0.9, 0.85, 0.9, 0.9, 0.75, 0.75, 0.75] +stem_rhonir = [0.49, 0.36, 0.36, 0.49, 0.49, 0.49, 0.49, 0.49, 0.49, 0.53, 0.53, 0.53] +stem_rhovis = [0.21, 0.12, 0.12, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.31, 0.31, 0.31] +stem_taunir = [0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.25, 0.25, 0.25] +stem_tauvis = [0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.12, 0.12, 0.12] + + +visb = 1 +nirb = 2 + +normalized_boundary = 1 +absolute_boundary = 2 + +class elem_type: + def __init__(self,n_vai): + + self.area = -9.0 + self.lai = -9.0 + self.sai = -9.0 + + self.n_vai = n_vai + self.avai = np.zeros([n_vai]) + self.r_dn = np.zeros([n_vai]) + self.r_up = np.zeros([n_vai]) + self.r_b = np.zeros([n_vai]) + self.r_abs = np.zeros([n_vai]) + #self.sunfrac = np.zeros([n_vai]) + +class cohort_type: + def __init__(self,n_vai,lai,sai): + + self.n_vai = n_vai + #self.avai = np.zeros([n_vai]) + dvai = (lai+sai)/n_vai + self.avai = np.linspace(dvai,lai+sai,num=n_vai) + self.rd_abs_leaf = np.zeros([n_vai]) + self.rb_abs_leaf = np.zeros([n_vai]) + self.r_abs_stem = np.zeros([n_vai]) + self.sunfrac = np.zeros([n_vai]) + +def main(argv): + + # All tests will use 2 bands 1=vis, 2=nir + + # Initialize radiation parameters + n_bands = 2 + n_pft = 12 + + iret = alloc_radparams_call(ci(n_pft),ci(n_bands)) + + for ft in range(n_pft): + + pft=ft+1 + # rho (vis+nir) + iret = set_radparams_call(c_double(leaf_rhovis[ft]),c_int(pft),c_int(visb),*ccharnb("rhol")) + iret = set_radparams_call(c_double(leaf_rhonir[ft]),c_int(pft),c_int(nirb),*ccharnb("rhol")) + iret = set_radparams_call(c_double(stem_rhovis[ft]),c_int(pft),c_int(visb),*ccharnb("rhos")) + iret = set_radparams_call(c_double(stem_rhonir[ft]),c_int(pft),c_int(nirb),*ccharnb("rhos")) + # tau (vis+nir) + iret = set_radparams_call(c_double(leaf_tauvis[ft]),c_int(pft),c_int(visb),*ccharnb("taul")) + iret = set_radparams_call(c_double(leaf_taunir[ft]),c_int(pft),c_int(nirb),*ccharnb("taul")) + iret = set_radparams_call(c_double(stem_tauvis[ft]),c_int(pft),c_int(visb),*ccharnb("taus")) + iret = set_radparams_call(c_double(stem_taunir[ft]),c_int(pft),c_int(nirb),*ccharnb("taus")) + # orientations + iret = set_radparams_call(c_double(leaf_xl[ft]),c_int(pft),c_int(0),*ccharnb("xl")) + iret = set_radparams_call(c_double(leaf_clumping_index[ft]),c_int(pft),c_int(0),*ccharnb("clumping_index")) + + # Process the core 2Stream parameters from parameters in file + iret = param_prep_call(ci(n_pft)) + + if(False): + ParallelElementPerturbDist() + + if(True): + SunFracTests() + + if(False): + SingleElementPerturbTest() + + if(False): + SerialParallelCanopyTest() + + plt.show() + +def SerialParallelCanopyTest(): + + + # Lets first construct a bunch of cohorts, 5 cohorts + # equal area, but folding by 2 in LAI + + cohort_lai = np.array([0.25,0.5,1.0,2.0,4.0]) + cohort_area = np.array([0.2,0.2,0.2,0.2,0.2]) + n_cohorts = len(cohort_lai) + + sai_frac = 0.1 + + pft = 1 + + # Serial approach: 5 layers with veg and ghost + n_col = 2 + n_layer = 5 + iret = alloc_twostream_call(ci(n_layer),ci(n_col)) + + #class cohort_type: + #def __init__(self,n_vai): + #self.n_vai = n_vai + #self.avai = np.zeros([n_vai]) + + + serialc = [] + serialc.append(cohort_type(100,cohort_lai[0],cohort_lai[0]*sai_frac)) + serialc.append(cohort_type(100,cohort_lai[1],cohort_lai[1]*sai_frac)) + serialc.append(cohort_type(100,cohort_lai[2],cohort_lai[2]*sai_frac)) + serialc.append(cohort_type(100,cohort_lai[3],cohort_lai[3]*sai_frac)) + serialc.append(cohort_type(100,cohort_lai[4],cohort_lai[4]*sai_frac)) + + parallelc = [] + parallelc.append(cohort_type(100,cohort_lai[0],cohort_lai[0]*sai_frac)) + parallelc.append(cohort_type(100,cohort_lai[1],cohort_lai[1]*sai_frac)) + parallelc.append(cohort_type(100,cohort_lai[2],cohort_lai[2]*sai_frac)) + parallelc.append(cohort_type(100,cohort_lai[3],cohort_lai[3]*sai_frac)) + parallelc.append(cohort_type(100,cohort_lai[4],cohort_lai[4]*sai_frac)) + + elems = [] + elems.append([]) + elems.append([]) + n_vai = 100 + + dvai = 0.05 + + for i in range(n_layer): + ican = i+1 + + icol = 1 + area = np.sum(cohort_area[i:]) + if(i==0): + lai = cohort_lai[i] + else: + lai = cohort_lai[i]-cohort_lai[i-1] + + sai = lai*sai_frac + + n_vai = int((lai+sai)/dvai) + elems[0].append(elem_type(n_vai)) + + + elems[0][-1].lai = lai + elems[0][-1].sai = sai + elems[0][-1].area = area + elems[0][-1].avai = np.linspace(0,lai+sai,num=n_vai) + iret = setup_canopy_call(c_int(ican),c_int(icol),c_int(pft),c_double(area),c_double(lai),c_double(sai)) + + icol = 2 + area = 1-np.sum(cohort_area[i:]) + elems[1].append(elem_type(1)) + elems[1][-1].lai = 0.0 + elems[1][-1].sai = 0.0 + elems[1][-1].area = area + lai = 0.0 + sai = 0.0 + air_pft = 0 + iret = setup_canopy_call(c_int(ican),c_int(icol),c_int(air_pft),c_double(area),c_double(lai),c_double(sai)) + + # Decide on a band: + ib = visb + + cd_r_beam = c_double(-9.0) + cd_r_diff_up = c_double(-9.0) + cd_r_diff_dn = c_double(-9.0) + cd_kb = c_double(-9.0) + cd_kd = c_double(-9.0) + cd_om = c_double(-9.0) + cd_betad = c_double(-9.0) + cd_betab = c_double(-9.0) + cd_rd_abs_leaf = c_double(-9.0) + cd_rb_abs_leaf = c_double(-9.0) + cd_r_abs_stem = c_double(-9.0) + cd_r_abs_snow = c_double(-9.0) + cd_leaf_sun_frac = c_double(-9.0) + + cd_albedo_beam = c_double(-9.0) + cd_albedo_diff = c_double(-9.0) + cd_canabs_beam = c_double(-9.0) + cd_canabs_diff = c_double(-9.0) + cd_ffbeam_beam = c_double(-9.0) + cd_ffdiff_beam = c_double(-9.0) + cd_ffdiff_diff = c_double(-9.0) + + + R_beam = 100. + R_diff = 100. + cosz = np.cos(0.0) + + ground_albedo_diff = 0.3 + ground_albedo_beam = 0.3 + frac_snow = 0.0 + + iret = grndsnow_albedo_call(c_int(visb),c_double(ground_albedo_diff),*ccharnb('albedo_grnd_diff')) + iret = grndsnow_albedo_call(c_int(visb),c_double(ground_albedo_beam),*ccharnb('albedo_grnd_beam')) + iret = grndsnow_albedo_call(c_int(nirb),c_double(ground_albedo_diff),*ccharnb('albedo_grnd_diff')) + iret = grndsnow_albedo_call(c_int(nirb),c_double(ground_albedo_beam),*ccharnb('albedo_grnd_beam')) + + iret = canopy_prep_call(c8(frac_snow)) + iret = zenith_prep_call(c8(cosz)) + + + + iret = solver_call(ci(ib),ci(normalized_boundary),c8(1.0),c8(1.0), \ + byref(cd_albedo_beam),byref(cd_albedo_diff), \ + byref(cd_canabs_beam),byref(cd_canabs_diff), \ + byref(cd_ffbeam_beam),byref(cd_ffdiff_beam),byref(cd_ffdiff_diff)) + + iret = setdown_call(ci(ib),c8(R_beam),c8(R_diff)) + + + for i in range(n_layer): + + ican = i+1 + icol = 1 + for iv in range(elems[0][i].n_vai): + iret = getintens_call(ci(ican),ci(icol),ci(ib),c8(elems[0][i].avai[iv]),byref(cd_r_diff_dn),byref(cd_r_diff_up),byref(cd_r_beam)) + elems[0][i].r_dn[iv] = cd_r_diff_dn.value + elems[0][i].r_up[iv] = cd_r_diff_up.value + elems[0][i].r_b[iv] = cd_r_beam.value + if(iv>0): + elems[0][i].r_abs[iv-1] = (elems[0][i].r_dn[iv]-elems[0][i].r_dn[iv-1]) + \ + (elems[0][i].r_up[iv-1]-elems[0][i].r_up[iv]) + \ + (elems[0][i].r_b[iv]-elems[0][i].r_b[iv-1]) + + for iv in range(elems[1][i].n_vai): + iret = getintens_call(ci(ican),ci(icol+1),ci(ib),c8(elems[1][i].avai[iv]),byref(cd_r_diff_dn),byref(cd_r_diff_up),byref(cd_r_beam)) + elems[1][i].r_dn[iv] = cd_r_diff_dn.value + elems[1][i].r_up[iv] = cd_r_diff_up.value + elems[1][i].r_b[iv] = cd_r_beam.value + if(iv>0): + elems[1][i].r_abs[iv-1] = (elems[1][i].r_dn[iv]-elems[1][i].r_dn[iv-1]) + \ + (elems[1][i].r_up[iv-1]-elems[1][i].r_up[iv]) + \ + (elems[1][i].r_b[iv]-elems[1][i].r_b[iv-1]) + + # Lets get the absorbed radiation from the cohorts + + #class cohort_type: + #def __init__(self,n_vai,lai,sai): + #self.n_vai = n_vai + ##self.avai = np.zeros([n_vai]) + #dvai = (lai+sai/n_vai) + #self.avai = np.linspace(dvai,lai+sai,num=n_vai) + #self.rabs_leaf = np.zeros([n_vai]) + #self.rabs_stem = np.zeros([n_vai]) + + for i in range(len(serialc)): + for iv in range(serialc[i].n_vai): + + vai_bot = serialc[i].avai[iv] + + ican = np.sum(serialc[i].avai[iv]>(cohort_lai*(1+sai_frac))) + if(ican>0): + vai_above = cohort_lai[ican-1]*(1+sai_frac) + else: + vai_above = 0. + + vai_bot = serialc[i].avai[iv]-vai_above + if(iv==0): + vai_top = 0 + else: + vai_top = np.max([0,serialc[i].avai[iv-1]-vai_above]) + + #print(i,iv,serialc[i].avai[iv],vai_above,vai_bot,vai_top,ican,cohort_lai*(1+sai_frac)) + icol = 1 # b/c 2 is air + iret = getabsrad_call(ci(ican+1),ci(icol),ci(ib),c8(vai_top),c8(vai_bot), \ + byref(cd_rd_abs_leaf),byref(cd_rb_abs_leaf),byref(cd_r_abs_stem), \ + byref(cd_r_abs_snow),byref(cd_leaf_sun_frac)) + serialc[i].rd_abs_leaf[iv] = cd_rd_abs_leaf.value + serialc[i].rb_abs_leaf[iv] = cd_rb_abs_leaf.value + serialc[i].r_abs_stem[iv] = cd_r_abs_stem.value + serialc[i].sunfrac[iv] = cd_leaf_sun_frac.value + + + + # Plot out absorbances and sun fractions in cohorts only + # --------------------------------------------- + + + + max_rd_abs_leaf = 0 + max_rb_abs_leaf = 0 + max_r_abs_stem = 0 + max_r_abs = 0 + maxlai = 0 + max_sunfrac = 0 + for i in range(n_cohorts): + max_rd_abs_leaf = np.max([max_rd_abs_leaf,np.max(serialc[i].rd_abs_leaf) ]) + max_rb_abs_leaf = np.max([max_rb_abs_leaf,np.max(serialc[i].rb_abs_leaf) ]) + max_r_abs_stem = np.max([max_r_abs_stem,np.max(serialc[i].r_abs_stem) ]) + max_r_abs = np.max([max_r_abs,np.max(serialc[i].r_abs_stem+serialc[i].rd_abs_leaf+serialc[i].rb_abs_leaf) ]) + maxlai = np.max([maxlai,np.max(serialc[i].avai) ]) + max_sunfrac = np.max([max_sunfrac,np.max(serialc[i].sunfrac)]) + + fig, axs = plt.subplots(ncols=n_cohorts,nrows=1,figsize=(9,5)) + ax1s = axs.reshape(-1) + + y0 = 0.1 + xpad = 0.1 + dx = (1.0-2*xpad)/float(n_cohorts) + dy = 0.8 + + ic=0 + x0 = xpad + for i in range(n_cohorts): + + ax = ax1s[ic] + ap = ax.plot(serialc[i].rd_abs_leaf+serialc[i].rb_abs_leaf+serialc[i].r_abs_stem ,serialc[i].avai) + ax.set_ylim([0,maxlai]) + ax.invert_yaxis() + ax.set_xlabel('[W/m2]') + ax.set_xlim([0,max_r_abs]) + + ax.set_title('Cohort {}'.format(i+1)) + if(i==0): + + ax.set_ylabel('Absorbed Radiation\nVAI [m2/m2]') + else: + ax.set_yticklabels([]) + + ax.grid(True) + ax.set_position([x0,y0,dx,dy]) + x0 = x0+dx + ic=ic+1 + + fig, axs = plt.subplots(ncols=n_cohorts,nrows=1,figsize=(9,5)) + ax1s = axs.reshape(-1) + + y0 = 0.1 + xpad = 0.1 + dx = (1.0-2*xpad)/float(n_cohorts) + dy = 0.8 + + # Sun fractions + ic=0 + x0 = xpad + for i in range(n_cohorts): + + ax = ax1s[ic] + ap = ax.plot(serialc[i].sunfrac ,serialc[i].avai) + ax.set_ylim([0,maxlai]) + ax.invert_yaxis() + ax.set_xlabel('[m2/m2]') + ax.set_xlim([0,max_sunfrac]) + + ax.set_title('Cohort {}'.format(i+1)) + if(i==0): + + ax.set_ylabel('Sunlit fraction of leaves [m2/m2]') + else: + ax.set_yticklabels([]) + + ax.grid(True) + ax.set_position([x0,y0,dx,dy]) + x0 = x0+dx + ic=ic+1 + + dealloc_twostream_call() + + + + if(True): + PlotRadMaps(elems,0,'Beam Radiation [W/m2]') + PlotRadMaps(elems,1,'Downwelling Diffuse Radiation [W/m2]') + PlotRadMaps(elems,2,'Upwelling Diffuse Radiation [W/m2]') + + +def SunFracTests(): + + + n_col = 1 + n_layer = 1 + iret = alloc_twostream_call(ci(n_layer),ci(n_col)) + + ican = 1 # Single canopy layer + icol = 1 # Single PFT + pft = 1 # Use PFT number 1 + area = 1.0 # Assume only 90% of the ground is covered + lai = 5.0 # LAI + sai = 0.5 # SAI + vai = lai+sai + iret = setup_canopy_call(c_int(1),c_int(1),c_int(pft),c_double(area),c_double(lai),c_double(sai)) + + # Decide on a band: + ib = visb + cd_r_beam = c_double(-9.0) + cd_r_diff_up = c_double(-9.0) + cd_r_diff_dn = c_double(-9.0) + cd_kb = c_double(-9.0) + cd_kd = c_double(-9.0) + cd_om = c_double(-9.0) + cd_betad = c_double(-9.0) + cd_betab = c_double(-9.0) + + R_beam = 1. + R_diff = 0. + cosz = np.cos(0.0) + n_vai = 200 + n_cosz = 100 + + dv = vai/n_vai + vai_a = np.linspace(dv,vai,num=n_vai) + cosz_a = np.linspace(0,1.0,num=n_cosz) + kb_a = np.zeros([n_cosz]) + lsf_a = np.zeros([n_cosz,n_vai]) + rbeamsf_a = np.zeros([n_cosz,n_vai]) + rbeam_a = np.zeros([n_cosz,n_vai]) + + + + cd_rd_abs_leaf = c_double(-9.0) + cd_rb_abs_leaf = c_double(-9.0) + cd_r_abs_stem = c_double(-9.0) + cd_r_abs_snow = c_double(-9.0) + cd_leaf_sun_frac = c_double(-9.0) + cd_albedo_beam = c_double(-9.0) + cd_albedo_diff = c_double(-9.0) + cd_canabs_beam = c_double(-9.0) + cd_canabs_diff = c_double(-9.0) + cd_ffbeam_beam = c_double(-9.0) + cd_ffdiff_beam = c_double(-9.0) + cd_ffdiff_diff = c_double(-9.0) + cd_r_diff_dn = c_double(-9.0) + cd_r_diff_up = c_double(-9.0) + cd_r_beam = c_double(-9.0) + + ground_albedo_diff = 0.3 + ground_albedo_beam = 0.3 + frac_snow = 0.5 + + iret = grndsnow_albedo_call(c_int(ib),c_double(ground_albedo_diff),*ccharnb('albedo_grnd_diff')) + iret = grndsnow_albedo_call(c_int(ib),c_double(ground_albedo_beam),*ccharnb('albedo_grnd_beam')) + + iret = canopy_prep_call(c8(frac_snow)) + + for ic,cosz in enumerate(cosz_a): + iret = zenith_prep_call(c8(cosz)) + + iret = solver_call(ci(ib),ci(normalized_boundary),c8(1.0),c8(1.0), \ + byref(cd_albedo_beam),byref(cd_albedo_diff), \ + byref(cd_canabs_beam),byref(cd_canabs_diff), \ + byref(cd_ffbeam_beam),byref(cd_ffdiff_beam),byref(cd_ffdiff_diff)) + + iret = setdown_call(ci(ib),c8(R_beam),c8(R_diff)) + + iret = getparams_call(ci(ican),ci(icol),ci(ib),byref(cd_kb), \ + byref(cd_kd),byref(cd_om),byref(cd_betad),byref(cd_betab)) + + kb_a[ic] = cd_betab.value + + for iv in range(n_vai): + + if(iv==0): + vai_top = 0. + else: + vai_top = vai_a[iv-1] + + vai_bot = vai_a[iv] + + + iret = getabsrad_call(ci(ican),ci(icol),ci(ib),c8(vai_top),c8(vai_bot), \ + byref(cd_rd_abs_leaf),byref(cd_rb_abs_leaf),byref(cd_r_abs_stem), \ + byref(cd_r_abs_snow),byref(cd_leaf_sun_frac)) + + iret = getintens_call(ci(ican),ci(icol),ci(ib),c8(vai_bot),byref(cd_r_diff_dn), \ + byref(cd_r_diff_up),byref(cd_r_beam)) + + lsf_a[ic,iv] = cd_leaf_sun_frac.value + + #sun_area = (vai_bot - vai_top)*cd_leaf_sun_frac.value/cd_kb.value + sun_area = (vai_bot - vai_top)*cd_kb.value + rbeam_a[ic,iv] = cd_r_beam.value + + if(iv==0): + rbeamsf_a[ic,iv] = R_beam*(1.0 - sun_area) + #print(rbeamsf_a[ic,iv],sun_area,vai_bot,vai_top,cd_leaf_sun_frac.value,vai_a[iv]) + #exit(0) + else: + rbeamsf_a[ic,iv] = rbeamsf_a[ic,iv-1]*(1.0 - sun_area) + #print(rbeamsf_a[ic,iv]) + + fig, axs = plt.subplots(ncols=2,nrows=2,figsize=(9,5)) + ax1s = axs.reshape(-1) + + ic0 = [2,25,50,99] + + for ia,ax in enumerate(ax1s): + + #Plot LSF profiles at 4 different cosz's + + ap = ax.plot(lsf_a[ic0[ia],:],vai_a[:],rbeam_a[ic0[ia],:],vai_a[:]) + ax.invert_yaxis() + ax.set_title('cos(z) = {:.2f}'.format(cosz_a[ic0[ia]])) + ax.set_xlabel('[Sun Fraction]') + ax.set_xlim([0,1]) + ax.grid(True) + if(ia<2): + ax.set_xlabel('') + ax.set_xticklabels([]) + #if(ia==0): + # ax.set_ylabel('Absorbed Radiation\nVAI [m2/m2]') + #else: + # ax.set_yticklabels([]) + plt.tight_layout() + + fig2, axs = plt.subplots(ncols=2,nrows=2,figsize=(9,5)) + ax1s = axs.reshape(-1) + + ic0 = [2,25,50,99] + + for ia,ax in enumerate(ax1s): + + #Plot LSF profiles at 4 different cosz's + + ap = ax.plot(rbeam_a[ic0[ia],:],vai_a[:],rbeamsf_a[ic0[ia],:],vai_a[:]) + ax.invert_yaxis() + ax.set_title('cos(z) = {:.2f}'.format(cosz_a[ic0[ia]])) + ax.set_xlabel('[Beam Fraction]') + ax.set_xlim([0,1]) + ax.grid(True) + if(ia<2): + ax.set_xlabel('') + ax.set_xticklabels([]) + #if(ia==0): + # ax.set_ylabel('Absorbed Radiation\nVAI [m2/m2]') + #else: + # ax.set_yticklabels([]) + plt.tight_layout() + + + dealloc_twostream_call() + + +def ParallelElementPerturbDist(): + + + # Lets first construct a bunch of cohorts, 5 cohorts + # equal area, but folding by 2 in LAI + + cohort_lai = np.array([0.25,0.5,1.0,2.0,4.0]) + cohort_area = np.array([0.9,0.19,0.19,0.19,0.19]) + n_cohorts = len(cohort_lai) + + sai_frac = 0.1 + + pft = 1 + + # Serial approach: 5 layers with veg and ghost + n_col = n_cohorts+1 + n_layer = 1 + iret = alloc_twostream_call(ci(n_layer),ci(n_col)) + + for icol in range(n_col-1): + iret = setup_canopy_call(c_int(1),c_int(icol+1),c_int(pft), \ + c_double(cohort_area[icol]),c_double(cohort_lai[icol]),c_double(cohort_lai[icol]*sai_frac)) + + # Add the air element + iret = setup_canopy_call(c_int(1),c_int(n_col),c_int(0),c_double(1.0-np.sum(cohort_area)),c_double(0.0),c_double(0.0)) + + num_params = 9 + paramsets = [] + + labels = ["clumping_index","leaf_rhonir","leaf_rhovis","leaf_taunir","leaf_tauvis", \ + "stem_rhonir","stem_rhovis","stem_taunir","stem_tauvis"] + + ic = 0 + with open('albedo_callib_param_vals.csv', newline='') as csvfile: + + reader = csv.reader(csvfile, delimiter=',') + next(reader, None) + nsets=0 + for irow, rowtext in enumerate(reader): + ic=ic+1 + if(ic==num_params): + ic=0 + nsets=nsets+1 + + with open('albedo_callib_param_vals.csv', newline='') as csvfile: + paramset = np.zeros([num_params,nsets]) + reader = csv.reader(csvfile, delimiter=',') + next(reader, None) + ic=0 + iset=0 + for irow, rowtext in enumerate(reader): + paramset[ic,iset] = float(rowtext[3]) + ic=ic+1 + if(ic==num_params): + ic=0 + iset=iset+1 + + + fig1, axs = plt.subplots(3,3,figsize=(9,7)) + ax1s = axs.reshape(-1) + + for ip,ax in enumerate(ax1s): + + ap = ax.hist(paramset[ip,:]) + #ax1.set_ylabel('Integrated VAI [m2/m2]') + ax.set_title(labels[ip]) + ax.grid(True) + + plt.tight_layout() + plt.show() + dealloc_twostream_call() + +def SingleElementPerturbTest(): + + + # =================================================================================== + n_col = 2 + n_layer = 1 + iret = alloc_twostream_call(ci(n_layer),ci(n_col)) + + ican = 1 # Single canopy layer + icol = 1 # Single PFT + pft = 1 # Use PFT number 1 + area = 0.9 # Assume only 90% of the ground is covered + lai = 2.0 # LAI + sai = 0.5 # SAI + vai = lai+sai + iret = setup_canopy_call(c_int(1),c_int(1),c_int(pft),c_double(area),c_double(lai),c_double(sai)) + iret = setup_canopy_call(c_int(1),c_int(2),c_int(0),c_double(1.0-area),c_double(0.0),c_double(0.0)) + + # Decide on a band: + + ib = visb + + cd_r_beam = c_double(-9.0) + cd_r_diff_up = c_double(-9.0) + cd_r_diff_dn = c_double(-9.0) + cd_kb = c_double(-9.0) + cd_kd = c_double(-9.0) + cd_om = c_double(-9.0) + cd_betad = c_double(-9.0) + cd_betab = c_double(-9.0) + + + # Make parameter pertubations, bump up 50% + pp_dict = {} + pp_dict['Kb'] = 0.66118239744 #74 #*1.5 + pp_dict['Kd'] = 0.9063246621781269 #*1.5 + pp_dict['om'] = 0.17819999999999997 #*1.5 + pp_dict['betab'] = 0.48253004714288084 #*1.5 + pp_dict['betad'] = 0.5999777777777778 #*1.5 + + R_beam = 100. + R_diff = 100. + cosz = np.cos(0.0) + n_vai = 100 + vai_a = np.linspace(0,vai,num=n_vai) + + dv = vai/n_vai + + r_diff_up = np.zeros(n_vai) + r_diff_dn = np.zeros(n_vai) + r_beam = np.zeros(n_vai) + + drdv_diff_up = np.zeros(n_vai-1) # Delta + drdv_diff_dn = np.zeros(n_vai-1) # Delta + drdv_ubeam = np.zeros(n_vai-1) # Delta + drdv_dbeam = np.zeros(n_vai-1) # Delta + + p_r_diff_up = np.zeros([n_vai,len(pp_dict)]) + p_r_diff_dn = np.zeros([n_vai,len(pp_dict)]) + p_r_beam = np.zeros([n_vai,len(pp_dict)]) + p_drdv_diff_up = np.zeros([n_vai-1,len(pp_dict)]) + p_drdv_diff_dn = np.zeros([n_vai-1,len(pp_dict)]) + p_drdv_ubeam = np.zeros([n_vai-1,len(pp_dict)]) + p_drdv_dbeam = np.zeros([n_vai-1,len(pp_dict)]) + + cd_albedo_beam = c_double(-9.0) + cd_albedo_diff = c_double(-9.0) + cd_canabs_beam = c_double(-9.0) + cd_canabs_diff = c_double(-9.0) + cd_ffbeam_beam = c_double(-9.0) + cd_ffdiff_beam = c_double(-9.0) + cd_ffdiff_diff = c_double(-9.0) + + ground_albedo_diff = 0.1 + ground_albedo_beam = 0.1 + frac_snow = 0.0 + + iret = grndsnow_albedo_call(c_int(ib),c_double(ground_albedo_diff),*ccharnb('albedo_grnd_diff')) + iret = grndsnow_albedo_call(c_int(ib),c_double(ground_albedo_beam),*ccharnb('albedo_grnd_beam')) + iret = canopy_prep_call(c8(frac_snow)) + iret = zenith_prep_call(c8(cosz)) + + iret = solver_call(ci(ib),ci(normalized_boundary),c8(1.0),c8(1.0), \ + byref(cd_albedo_beam),byref(cd_albedo_diff), \ + byref(cd_canabs_beam),byref(cd_canabs_diff), \ + byref(cd_ffbeam_beam),byref(cd_ffdiff_beam),byref(cd_ffdiff_diff)) + + iret = setdown_call(ci(ib),c8(R_beam),c8(R_diff)) + + iret = getparams_call(ci(ican),ci(icol),ci(ib),byref(cd_kb), \ + byref(cd_kd),byref(cd_om),byref(cd_betad),byref(cd_betab)) + + #print(cd_kb.value,cd_kd.value,cd_om.value,cd_betad.value,cd_betab.value) + #exit(0) + + + for iv in range(n_vai): + iret = getintens_call(ci(ican),ci(icol),ci(ib),c8(vai_a[iv]),byref(cd_r_diff_dn), \ + byref(cd_r_diff_up),byref(cd_r_beam)) + + r_beam[iv] = cd_r_beam.value + r_diff_up[iv] = cd_r_diff_up.value + r_diff_dn[iv] = cd_r_diff_dn.value + + if(iv>0): + drdv_ubeam[iv-1] = -cd_om.value*cd_betab.value*(r_beam[iv]-r_beam[iv-1])/dv + drdv_dbeam[iv-1] = -cd_om.value*(1.-cd_betab.value)*(r_beam[iv]-r_beam[iv-1])/dv + drdv_diff_dn[iv-1] = -(r_diff_dn[iv]-r_diff_dn[iv-1])/dv + drdv_diff_up[iv-1] = (r_diff_up[iv]-r_diff_up[iv-1])/dv + + # Redo the scattering with perturbations + i = -1 + for key,val in pp_dict.items(): + i=i+1 + iret = canopy_prep_call(c8(frac_snow)) + iret = zenith_prep_call(c8(cosz)) + iret = forceparam_call(c_int(ican),c_int(icol),ci(ib),c_double(val),*ccharnb(key)) + + iret = solver_call(ci(ib),ci(normalized_boundary),c8(1.0),c8(1.0), \ + byref(cd_albedo_beam),byref(cd_albedo_diff), \ + byref(cd_canabs_beam),byref(cd_canabs_diff), \ + byref(cd_ffbeam_beam),byref(cd_ffdiff_beam),byref(cd_ffdiff_diff)) + + iret = setdown_call(ci(ib),c8(R_beam),c8(R_diff)) + + for iv in range(n_vai): + iret = getintens_call(ci(ican),ci(icol),ci(ib),c8(vai_a[iv]),byref(cd_r_diff_dn),byref(cd_r_diff_up),byref(cd_r_beam)) + + #print(iv,i,cd_r_beam.value) + p_r_beam[iv,i] = cd_r_beam.value + p_r_diff_up[iv,i] = cd_r_diff_up.value + p_r_diff_dn[iv,i] = cd_r_diff_dn.value + + if(iv>0): + p_drdv_ubeam[iv-1] = -cd_om.value*cd_betab.value*(p_r_beam[iv]-p_r_beam[iv-1])/dv + p_drdv_dbeam[iv-1] = -cd_om.value*(1.-cd_betab.value)*(p_r_beam[iv]-p_r_beam[iv-1])/dv + p_drdv_diff_dn[iv-1] = -(p_r_diff_dn[iv]-p_r_diff_dn[iv-1])/dv + p_drdv_diff_up[iv-1] = (p_r_diff_up[iv]-p_r_diff_up[iv-1])/dv + + + fig1, ((ax1,ax2),(ax3,ax4)) = plt.subplots(2,2,figsize=(9,7)) + + ap = ax1.plot(r_beam,vai_a,p_r_beam[:,i],vai_a) + first_color = ap[0].get_color() + last_color = ap[-1].get_color() + ax1.invert_yaxis() + ax1.set_xlabel('') + ax1.set_ylabel('Integrated VAI [m2/m2]') + ax1.set_title('Beam Intensity [W/m2]') + ax1.grid(True) + + ax2.plot(r_diff_dn,vai_a,p_r_diff_dn[:,i],vai_a) + ax2.invert_yaxis() + ax2.set_xlabel('') + ax2.set_yticklabels('') + ax2.set_ylabel('') + ax2.set_title('Down Diffuse Intensity [W/m2] ') + ax2.grid(True) + + ax3.plot(r_diff_up,vai_a,p_r_diff_up[:,i],vai_a) + ax3.invert_yaxis() + ax3.set_xlabel('') + ax3.set_ylabel('Integrated VAI [m2/m2]') + ax3.set_title('Up Diffuse Intensity [W/m2]') + ax3.grid(True) + + ax4.axis("off") + ax4.set_axis_off() + + if(ib==visb): + band_name = "Visible" + elif(ib==nirb): + band_name = "Near Infrared" + else: + print("Unknown band") + exit(2) + + + param_str = r"""In-element Scattering Profiles + +Broad band: {0} +$R_{{b,atm}} = ${1:.0f} +$R_{{d,atm}} = ${2:.0f} +$cos(\phi) = ${3:.2f} +$K_b = ${4:.2f} +$K_d = ${5:.2f} +$\omega = ${6:.2f} +$\beta_b = ${7:.2f} +$\beta_d = ${8:.2f} +$\alpha_{{gd}} = ${9:.2f} +$\alpha_{{gb}} = ${9:.2f}""".format(band_name,R_beam,R_diff,cosz,cd_kb.value,cd_kd.value,cd_om.value,cd_betab.value,cd_betad.value,ground_albedo_diff,ground_albedo_beam) + ax4.text(0.1, 0.5, param_str, horizontalalignment='left', \ + verticalalignment='center', transform=ax4.transAxes,backgroundcolor=[1.0,1.0,1.0],fontsize=12,color=first_color) + ax4.text(0.5,0.5,r"{0}={1:.2f}".format(key,val),color=last_color) + plt.subplots_adjust(wspace=0.1, hspace=0.25) + plt.show() + + + dealloc_twostream_call() + + +# Plotting Functions + + +def PlotRadMaps(elems,rtype,plt_title): + + fig, ax = plt.subplots(ncols=1,nrows=1,figsize=(8,8)) + + cmap = mpl.cm.Reds + + #code.interact(local=dict(globals(), **locals())) + n_layer = len(elems[0]) + + total_vai = 0 + for i in range(n_layer): + total_vai = total_vai + \ + np.max([elems[0][i].lai+elems[0][i].sai,elems[1][i].lai+elems[1][i].sai]) + + ax.set_ylim([0,total_vai]) + + total_vai = 0 + rect = [] + rcolor = [] + for i in range(n_layer): + + # Vegetated + + for iv in range(elems[0][i].n_vai-1): + #rel_intense = np.max([0,np.min([1.,elems[0][i].r_dn[iv]/R_diff])]) + #rel_intense = np.max([0,np.min([R_diff,elems[0][i].r_dn[iv]])]) + if(rtype==0): + rel_intense = np.max([0,elems[0][i].r_b[iv]]) + elif(rtype==1): + rel_intense = np.max([0,elems[0][i].r_dn[iv]]) + elif(rtype==2): + rel_intense = np.max([0,elems[0][i].r_up[iv]]) + + + dvai = elems[0][i].avai[iv+1]-elems[0][i].avai[iv] + rect.append(mpl.patches.Rectangle((0,(elems[0][i].avai[iv]+total_vai)),elems[0][i].area,dvai)) #,color = [rel_intense,0.5,0.5])) + rcolor.append(rel_intense) + + # Air + #rel_intense = np.max([0,np.min([1.,elems[1][i].r_dn[0]/R_diff])]) + #rel_intense = np.max([0,elems[1][i].r_dn[0]]) + if(rtype==0): + rel_intense = np.max([1,elems[1][i].r_b[0]]) + elif(rtype==1): + rel_intense = np.max([1,elems[1][i].r_dn[0]]) + elif(rtype==2): + rel_intense = np.max([1,elems[1][i].r_up[0]]) + + + rect.append(mpl.patches.Rectangle((elems[0][i].area,total_vai),(1.-elems[0][i].area),(elems[0][i].lai+elems[0][i].sai))) #,color = [rel_intense,0.5,0.5])) + rcolor.append(rel_intense) + + total_vai = total_vai + \ + np.max([elems[0][i].lai+elems[0][i].sai,elems[1][i].lai+elems[1][i].sai]) + + + p = mpl.collections.PatchCollection(rect,cmap = cmap,alpha = 1.0) + p.set_array(rcolor) + im = ax.add_collection(p) + + + #code.interact(local=dict(globals(), **locals())) + + ax.invert_yaxis() + ax.set_ylabel('Integrated Vegetated Area Index') + ax.set_xlabel('Ground Area Fraction') + ax.set_title(plt_title) #) + plt.colorbar(im) + + +def PlotRadLines(): + + fig, axs = plt.subplots(ncols=2,nrows=n_layer,figsize=(8,8)) + ax1s = axs.reshape(-1) + ic=0 + y0 = 0.9 + ypad = 0.1 + dy = (y0-ypad)/n_layer + xpad = 0.1 + xwid = 1-2*xpad + + for i in range(n_layer): + + ax = ax1s[ic] + ap = ax.plot(elems[0][i].r_dn,elems[0][i].avai) + ax.set_ylim([np.min(elems[0][i].avai),np.max(elems[0][i].avai)]) + ax.invert_yaxis() + ax.set_xlabel('') + ax.set_xlim([0,R_diff]) + ax.set_ylabel('VAI [m2/m2]') + if(i==0): + ax.set_title('Diffuse Down Intensity [W/m2]') + if(i!=n_layer-1): + ax.set_xticklabels([]) + ax.grid(True) + y0 = y0-dy + x0 = xpad + dx = 0.4 + #dx = elems[0][i].area*(1-2*xpad) + ax.set_position([x0,y0,dx,dy]) + ic=ic+1 + + ax = ax1s[ic] + ap = ax.plot([elems[1][i].r_dn[0],elems[1][i].r_dn[-1]],[0,1]) + ax.invert_yaxis() + ax.set_xlabel('') + ax.set_xlim([0,R_diff]) + if(i==0): + ax.set_title('Diffuse Down Intensity [W/m2]') + if(i!=n_layer-1): + ax.set_xticklabels([]) + ax.set_ylabel('') + ax.set_yticklabels([]) + ax.set_yticks([]) + ax.set_ylim([0,1]) + x0 = xpad+dx + dx=0.4 + #dx = elems[1][i].area*(1-2*xpad) + ax.set_position([x0,y0,dx,dy]) + ax.grid(True) + ic=ic+1 + + + +# ======================================================================================= +# This is the actual call to main + +if __name__ == "__main__": + main(sys.argv) diff --git a/functional_unit_testing/radiation/build_radiation_f90_objects.sh b/functional_unit_testing/radiation/build_radiation_f90_objects.sh new file mode 100755 index 0000000000..5ff5f3c9ae --- /dev/null +++ b/functional_unit_testing/radiation/build_radiation_f90_objects.sh @@ -0,0 +1,24 @@ +#!/bin/bash + +# Path to FATES src + +FC='gfortran' + +F_OPTS="-shared -fPIC -g -O0 -ffpe-trap=zero,overflow,underflow -fbacktrace -fbounds-check -Wall" +#F_OPTS="-shared -fPIC -O" + + +MOD_FLAG="-J" + +rm -f bld/*.o +rm -f bld/*.mod + +# Build the new file with constants + +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/FatesRadiationMemMod.o ../../radiation/FatesRadiationMemMod.F90 +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/TwoStreamMLPEMod.o ../../radiation/TwoStreamMLPEMod.F90 +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/RadiationWrapMod.o f90_src/RadiationWrapMod.F90 + + + + diff --git a/functional_unit_testing/radiation/f90_src/RadiationWrapMod.F90 b/functional_unit_testing/radiation/f90_src/RadiationWrapMod.F90 new file mode 100644 index 0000000000..ed35afcc2a --- /dev/null +++ b/functional_unit_testing/radiation/f90_src/RadiationWrapMod.F90 @@ -0,0 +1,265 @@ +module RadiationWrapMod + + use TwoStreamMLPEMod + use iso_c_binding, only : c_char + use iso_c_binding, only : c_int + use iso_c_binding, only : r8 => c_double + + implicit none + public + save + + integer(kind=c_int), parameter :: param_string_length = 32 + + type(twostream_type) :: twostream + + +contains + + subroutine InitAllocate(n_layer,n_column) + + integer(kind=c_int), intent(in) :: n_layer + integer(kind=c_int), intent(in) :: n_column + + integer(kind=c_int) :: ican + + + call twostream%AllocInitTwoStream((/1,2/),n_layer,n_column) + + + twostream%n_lyr = n_layer + + do ican = 1,n_layer + twostream%n_col(ican) = n_column + end do + + twostream%force_prep = .true. + + call twostream%GetNScel() + + twostream%frac_snow = 0._r8 + twostream%frac_snow_old = 1._r8 + + print*,"Allocated twostream instance" + print*," with ",twostream%n_scel," elements" + + return + end subroutine InitAllocate + + + subroutine Dealloc() + + call twostream%DeallocTwoStream() + + end subroutine Dealloc + + + subroutine SetRadParam(val,pft,ib,pname) + + real(r8), intent(in) :: val + character(kind=c_char,len=*), intent(in) :: pname + integer(kind=c_int), intent(in) :: pft + integer(kind=c_int), intent(in) :: ib + + select case(trim(pname)) + case('rhol') + rad_params%rhol(ib,pft) = val + case('rhos') + rad_params%rhos(ib,pft) = val + case('taul') + rad_params%taul(ib,pft) = val + case('taus') + rad_params%taus(ib,pft) = val + case('xl') + rad_params%xl(pft) = val + case('clumping_index') + rad_params%clumping_index(pft) = val + case default + print*,"An unknown parameter name was sent to the parameter" + print*,"initialization function." + print*,"name:--",trim(pname),"--" + stop + end select + + end subroutine SetRadParam + + ! ============================================================================= + + subroutine SetGroundSnow(ib,val,pname) + + real(r8), intent(in) :: val + integer, intent(in) :: ib + character(kind=c_char,len=*), intent(in) :: pname + + select case(trim(pname)) + case('albedo_grnd_diff') + twostream%band(ib)%albedo_grnd_diff = val + case('albedo_grnd_beam') + twostream%band(ib)%albedo_grnd_beam = val + case default + print*,"An unknown parameter name was sent to ground/snow" + print*,"initialization function." + print*,"name:--",trim(pname),"--" + stop + end select + end subroutine SetGroundSnow + + ! ============================================================================= + + subroutine SetupCanopy(ican,icol,pft,area,lai,sai) + + integer(kind=c_int), intent(in) :: ican ! Canopy layer index + integer(kind=c_int), intent(in) :: icol ! Column (pft) position index + integer(kind=c_int), intent(in) :: pft ! PFT index + real(r8), intent(in) :: area ! columns fraction of the ground + real(r8), intent(in) :: lai ! LAI + real(r8), intent(in) :: sai + + + twostream%scelg(ican,icol)%pft = pft + twostream%scelg(ican,icol)%area = area + twostream%scelg(ican,icol)%lai = lai + twostream%scelg(ican,icol)%sai = sai + + return + end subroutine SetupCanopy + + subroutine WrapCanopyPrep(frac_snow) + + real(kind=r8),intent(in) :: frac_snow + + call twostream%CanopyPrep(frac_snow) + + end subroutine WrapCanopyPrep + + subroutine WrapZenithPrep(cosz) + + real(kind=r8),intent(in) :: cosz + + call twostream%ZenithPrep(cosz) + + return + end subroutine WrapZenithPrep + + subroutine WrapSetDownwelling(ib,Rbeam_atm,Rdiff_atm) + + integer(c_int) :: ib + real(r8) :: Rbeam_atm ! Intensity of beam radiation at top of canopy [W/m2 ground] + real(r8) :: Rdiff_atm ! Intensity of diffuse radiation at top of canopy [W/m2 ground] + + twostream%band(ib)%Rbeam_atm = Rbeam_atm + twostream%band(ib)%Rdiff_atm = Rdiff_atm + + return + end subroutine WrapSetDownwelling + + + subroutine WrapSolve(ib,boundary_type,Rbeam_atm,Rdiff_atm, & + albedo_beam, & + albedo_diff, & + frac_abs_can_beam, & + frac_abs_can_diff, & + frac_beam_grnd_beam, & + frac_diff_grnd_beam, & + frac_diff_grnd_diff) + + integer(c_int) :: ib + integer(c_int) :: boundary_type + + real(r8) :: albedo_beam + real(r8) :: albedo_diff + real(r8) :: frac_abs_can_beam + real(r8) :: frac_abs_can_diff + real(r8) :: frac_beam_grnd_beam + real(r8) :: frac_diff_grnd_beam + real(r8) :: frac_diff_grnd_diff + real(r8) :: Rbeam_atm ! Intensity of beam radiation at top of canopy [W/m2 ground] + real(r8) :: Rdiff_atm ! Intensity of diffuse radiation at top of canopy [W/m2 ground] + + call twostream%Solve(ib,boundary_type, & + Rbeam_atm,Rdiff_atm, & + albedo_beam, & + albedo_diff, & + frac_abs_can_beam, & + frac_abs_can_diff, & + frac_beam_grnd_beam, & + frac_diff_grnd_beam, & + frac_diff_grnd_diff) + + return + end subroutine WrapSolve + + subroutine WrapGetIntensity(ican,icol,ib,vai,r_diff_dn,r_diff_up,r_beam) + + integer(c_int) :: ican, icol + integer(c_int) :: ib + real(r8) :: vai + real(r8) :: r_diff_dn + real(r8) :: r_diff_up + real(r8) :: r_beam + + r_diff_dn = twostream%GetRdDn(ican,icol,ib,vai) + r_diff_up = twostream%GetRdUp(ican,icol,ib,vai) + r_beam = twostream%GetRb(ican,icol,ib,vai) + + return + end subroutine WrapGetIntensity + + subroutine WrapGetAbsRad(ican,icol,ib,vai_top,vai_bot,Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow,leaf_sun_frac) + + integer(c_int) :: ican, icol + integer(c_int) :: ib + real(r8) :: vai_top,vai_bot + real(r8) :: Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow,leaf_sun_frac,Rb_abs,Rd_abs + + call twostream%GetAbsRad(ican,icol,ib,vai_top,vai_bot,Rb_abs,Rd_abs,Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow,leaf_sun_frac) + + return + end subroutine WrapGetAbsRad + + subroutine WrapGetParams(ican,icol,ib,Kb,Kd,om,betad,betab) + + integer(c_int) :: ican, icol + integer(c_int) :: ib + real(r8) :: Kb,Kd,om,betad,betab + + Kb = twostream%scelg(ican,icol)%Kb + Kd = twostream%scelg(ican,icol)%Kd + om = twostream%band(ib)%scelb(ican,icol)%om + betad = twostream%band(ib)%scelb(ican,icol)%betad + betab = twostream%band(ib)%scelb(ican,icol)%betab + + return + end subroutine WrapGetParams + + subroutine WrapForceParams(ican,icol,ib,val,pname) + + ! This will overwrite the 2-stream parameters + ! that are derived from the fates params + + integer(c_int) :: ican, icol + integer(c_int) :: ib + real(r8), intent(in) :: val + character(kind=c_char,len=*), intent(in) :: pname + + select case(trim(pname)) + case('Kb') + twostream%scelg(ican,icol)%Kb = val + case('Kd') + twostream%scelg(ican,icol)%Kd = val + case('om') + twostream%band(ib)%scelb(ican,icol)%om = val + case('betab') + twostream%band(ib)%scelb(ican,icol)%betab = val + case('betad') + twostream%band(ib)%scelb(ican,icol)%betad = val + case default + print*,"An unknown parameter name was sent to the parameter" + print*,"initialization function." + print*,"name:--",trim(pname),"--" + stop + end select + + end subroutine WrapForceParams + +end module RadiationWrapMod diff --git a/functional_unit_testing/shared/py_src/PyF90Utils.py b/functional_unit_testing/shared/py_src/PyF90Utils.py index a9ffaf89ad..3665b59785 100644 --- a/functional_unit_testing/shared/py_src/PyF90Utils.py +++ b/functional_unit_testing/shared/py_src/PyF90Utils.py @@ -19,6 +19,9 @@ def cchar(fchar): def cchar3(fchar): return(byref(c_char(fchar.encode('utf-8')))) +def ccharnb(fchar): + return([c_char_p(fchar.encode('utf-8')),c_long(len(fchar))]) + # We do NOT pass arrays back by reference # This is because we will need to get their length # on the argument diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index d71087353b..7f8668d22b 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -725,6 +725,8 @@ module FatesHistoryInterfaceMod integer :: ih_fabi_sha_top_si_can integer :: ih_crownarea_si_can + integer :: ih_fsun_si + ! indices to (patch age x fuel size class) variables integer :: ih_fuel_amount_age_fuel @@ -4333,7 +4335,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) return end subroutine update_history_dyn - subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) + subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) ! --------------------------------------------------------------------------------- ! This is the call to update the history IO arrays that are expected to only change @@ -4348,6 +4350,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) type(bc_in_type) , intent(in) :: bc_in(nsites) + type(bc_out_type) , intent(in) :: bc_out(nsites) real(r8) , intent(in) :: dt_tstep ! Locals @@ -4370,7 +4373,8 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort real(r8) :: per_dt_tstep ! Time step in frequency units (/s) - + real(r8) :: elai_tot + associate( hio_gpp_si => this%hvars(ih_gpp_si)%r81d, & hio_gpp_secondary_si => this%hvars(ih_gpp_secondary_si)%r81d, & hio_npp_si => this%hvars(ih_npp_si)%r81d, & @@ -4447,7 +4451,8 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_parsun_top_si_can => this%hvars(ih_parsun_top_si_can)%r82d, & hio_parsha_top_si_can => this%hvars(ih_parsha_top_si_can)%r82d, & hio_maint_resp_unreduced_si => this%hvars(ih_maint_resp_unreduced_si)%r81d, & - hio_tveg => this%hvars(ih_tveg_si)%r81d) + hio_tveg => this%hvars(ih_tveg_si)%r81d, & + hio_fsun_si => this%hvars(ih_fsun_si)%r81d) ! Flush the relevant history variables call this%flush_hvars(nc,upfreq_in=2) @@ -4467,6 +4472,8 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) patch_area_by_age(1:nlevage) = 0._r8 canopy_area_by_age(1:nlevage) = 0._r8 + + elai_tot = 0._r8 ! Calculate the site-level total vegetated area (i.e. non-bareground) site_area_veg = area @@ -4477,6 +4484,10 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) cpatch => sites(s)%oldest_patch do while(associated(cpatch)) + + hio_fsun_si = hio_fsun_si + bc_out(s)%laisun_pa(ifp)*cpatch%area + elai_tot = elai_tot + (bc_out(s)%laisun_pa(ifp)+bc_out(s)%laisha_pa(ifp))*cpatch%area + patch_area_by_age(cpatch%age_class) = & patch_area_by_age(cpatch%age_class) + cpatch%area @@ -4765,6 +4776,13 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) cpatch => cpatch%younger end do !patch loop + if(elai_tot this%band(ib)%scelb(ican,icol), & scelg => this%scelg(ican,icol), & @@ -465,11 +465,23 @@ subroutine GetAbsRad(this,ican,icol,ib,vai_top,vai_bot, & vai_max = scelg%lai + scelg%sai dvai = vai_bot - vai_top - dlai = dvai * scelg%lai/( scelg%lai+ scelg%sai) - leaf_sun_frac = max(0.001_r8,min(0.999_r8,scelb%Rbeam0/ & - (dvai*scelg%Kb/rad_params%clumping_index(ft)) * (exp(-scelg%Kb*vai_top) - exp(-scelg%Kb*vai_bot)) )) - + lai_top = vai_top*scelg%lai/( scelg%lai+ scelg%sai) + lai_bot = vai_bot*scelg%lai/( scelg%lai+ scelg%sai) + dlai = dvai * scelg%lai/( scelg%lai+ scelg%sai) + + + !!if(dlai>nearzero)then + !! leaf_sun_frac = max(0.001_r8,min(0.999_r8,scelb%Rbeam0/(dlai*scelg%Kb_leaf/rad_params%clumping_index(ft)) & + !! *(exp(-scelg%Kb_leaf*lai_top) - exp(-scelg%Kb_leaf*lai_bot)))) + !!else + !! leaf_sun_frac = 0001._r8 + !!end if + + leaf_sun_frac = max(0.001_r8,min(0.999_r8,scelb%Rbeam0/(dvai*scelg%Kb/rad_params%clumping_index(ft)) & + *(exp(-scelg%Kb*vai_top) - exp(-scelg%Kb*vai_bot)))) + + if(debug) then if(leaf_sun_frac>1.0_r8 .or. leaf_sun_frac<0._r8) then print*,"impossible leaf sun fraction" @@ -940,9 +952,9 @@ subroutine Solve(this, ib, & !real(r8),allocatable :: TAU(:) !real(r8),allocatable :: LAMBDA(:) - real(r8) :: OMEGA(100,100) - real(r8) :: TAU(100) - real(r8) :: LAMBDA(100) + real(r8) :: OMEGA(200,200) + real(r8) :: TAU(200) + real(r8) :: LAMBDA(200) integer :: isol ! Solution index loop (beam, beam+diff) integer :: ican ! Loop index for canopy layers @@ -980,7 +992,6 @@ subroutine Solve(this, ib, & real(r8) :: work(workmax) ! Work array integer :: lwork ! Dimension of work array integer :: info ! Procedure diagnostic ouput - integer :: alloc_err ! Allocation error code ! Testing switch ! If true, then allow elements ! of different layers, but same row, to have priority From 882e02a3c4a151c7bd885e031d03e1929e25e256 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 19 May 2023 10:15:06 -0400 Subject: [PATCH 058/250] added type definition --- main/FatesHistoryInterfaceMod.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 7f8668d22b..bb92d267f0 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -49,6 +49,7 @@ module FatesHistoryInterfaceMod use FatesInterfaceTypesMod , only : nlevsclass, nlevage use FatesInterfaceTypesMod , only : nlevheight use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : bc_out_type use FatesInterfaceTypesMod , only : hlm_model_day use FatesInterfaceTypesMod , only : nlevcoage use FatesInterfaceTypesMod , only : hlm_use_nocomp @@ -4485,8 +4486,8 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) do while(associated(cpatch)) - hio_fsun_si = hio_fsun_si + bc_out(s)%laisun_pa(ifp)*cpatch%area - elai_tot = elai_tot + (bc_out(s)%laisun_pa(ifp)+bc_out(s)%laisha_pa(ifp))*cpatch%area + hio_fsun_si = hio_fsun_si + bc_out(s)%laisun_pa(ipa)*cpatch%area + elai_tot = elai_tot + (bc_out(s)%laisun_pa(ipa)+bc_out(s)%laisha_pa(ipa))*cpatch%area patch_area_by_age(cpatch%age_class) = & patch_area_by_age(cpatch%age_class) + cpatch%area From dd916b64544e8cd6e850ae7f1bdd2034c5e7eb4b Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 23 May 2023 14:22:12 -0700 Subject: [PATCH 059/250] add logic to handle incoming NaNs from LUH2 --- biogeochem/FatesLandUseChangeMod.F90 | 40 +++++++++++++++++------ main/EDInitMod.F90 | 47 +++++++++++++++++----------- 2 files changed, 58 insertions(+), 29 deletions(-) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index fb90f2fa6f..338648605b 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -207,21 +207,44 @@ end subroutine get_landusechange_rules subroutine get_luh_statedata(bc_in, state_vector) + use shr_infnan_mod , only : isnan => shr_infnan_isnan + type(bc_in_type) , intent(in) :: bc_in real(r8), intent(out) :: state_vector(n_landuse_cats) ! [m2/m2] ! LOCALS type(luh2_fates_lutype_map) :: lumap + real(r8) :: temp_vector(hlm_num_luh2_states) ! [m2/m2] real(r8) :: urban_fraction integer :: i_luh2_states integer :: ii character(5) :: state_name - ! zero state vector + ! zero state vector and temporary state vector state_vector(:) = 0._r8 + temp_vector = 0._r8 ! identify urban fraction so that it can be factored into the land use state output - urban_fraction = bc_in%hlm_luh_states(findloc(bc_in%hlm_luh_state_names,'urban',dim=1)) + urban_fraction = 0._r8 + + ! Check to see if the incoming state vector is NaN. + ! This suggests that there is a discepency where the HLM and LUH2 states + ! there is vegetated ground. In this case, states should be Nan. If so, + ! set the current state to be all primary forest. + ! If only a portion of the vector is NaN, there is something amiss with + ! the data, so end the run. + if (all(isnan(bc_in%hlm_luh_states))) then + temp_vector(1) = 1._r8 + write(fates_log(),*) 'WARNING: land use state is all NaN; setting state as all primary forest.' + else if (any(isnan(bc_in%hlm_luh_states))) then + if (any(.not. isnan(bc_in%hlm_luh_states))) then + write(fates_log(),*) 'ERROR: land use state has NaN: ', bc_in%hlm_luh_states + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + else + temp_vector = bc_in%hlm_luh_states + urban_fraction = bc_in%hlm_luh_states(findloc(bc_in%hlm_luh_state_names,'urban',dim=1)) + end if ! loop over all states and add up the ones that correspond to a given fates land use type do i_luh2_states = 1, hlm_num_luh2_states @@ -231,20 +254,17 @@ subroutine get_luh_statedata(bc_in, state_vector) state_name = bc_in%hlm_luh_state_names(i_luh2_states) ii = lumap%GetIndex(state_name) - ! Avoid 'urban' states whose indices have been given unset values - if (ii .ne. fates_unset_int) then - state_vector(ii) = state_vector(ii) + & - bc_in%hlm_luh_states(i_luh2_states) / (1._r8 - urban_fraction) + ! Avoid 'urban' states whose indices have been given unset values + if (ii .ne. fates_unset_int) then + state_vector(ii) = state_vector(ii) + & + temp_vector(i_luh2_states) / (1._r8 - urban_fraction) end if - ! end do end do ! check to ensure total area == 1, and correct if not if ( abs(sum(state_vector(:)) - 1._r8) .gt. nearzero ) then write(fates_log(),*) 'warning: sum(state_vector) = ', sum(state_vector(:)) - do ii = 1, n_landuse_cats - state_vector(ii) = state_vector(ii) / sum(state_vector(:)) - end do + state_vector = state_vector / sum(state_vector) end if end subroutine get_luh_statedata diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index d010becf27..aeefa16b8b 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -524,10 +524,11 @@ subroutine init_patches( nsites, sites, bc_in) real(r8) :: newparea, newparea_withlanduse real(r8) :: tota !check on area integer :: is_first_patch - integer :: n_luh_states - integer :: luh_state_counter + ! integer :: n_luh_states + ! integer :: luh_state_counter real(r8) :: state_vector(n_landuse_cats) ! [m2/m2] integer :: i_lu, i_lu_state + integer :: n_active_landuse_cats type(ed_site_type), pointer :: sitep @@ -592,27 +593,33 @@ subroutine init_patches( nsites, sites, bc_in) ! read in luh state data to determine initial land use types if (hlm_use_luh .eq. itrue) then - call get_luh_statedata(bc_in(s), state_vector) - n_luh_states = 0 - do i_lu = 1, hlm_num_luh2_transitions - if ( state_vector(i_lu) .gt. nearzero ) then - n_luh_states = n_luh_states +1 - end if - end do - - if (n_luh_states .eq. 0) then - write(fates_log(),*) 'error. n_luh_states .eq. 0.' - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif + ! Set the number of active land use categories to the maximum number + ! This could be updated in the future to allow a variable number of + ! categories based on which states are zero + n_active_landuse_cats = n_landuse_cats + call get_luh_statedata(bc_in(s), state_vector) + ! n_luh_states = 0 + ! do i_lu = 1, hlm_num_luh2_transitions + ! if ( state_vector(i_lu) .gt. nearzero ) then + ! n_luh_states = n_luh_states +1 + ! end if + ! end do + + ! if (n_luh_states .eq. 0) then + ! write(fates_log(),*) 'error. n_luh_states .eq. 0.' + ! call endrun(msg=errMsg(sourcefile, __LINE__)) + ! endif else + ! If LUH2 data is not being used, we initialize with primarylands, + ! i.e. array index equals '1' + n_active_landuse_cats = primaryland state_vector(:) = 0._r8 state_vector(primaryland) = 1._r8 - n_luh_states = 1 endif is_first_patch = itrue - luh_state_counter = 0 + ! luh_state_counter = 0 new_patch_nocomp_loop: do n = start_patch, num_new_patches ! set the PFT index for patches if in nocomp mode. @@ -638,12 +645,13 @@ subroutine init_patches( nsites, sites, bc_in) newparea = area end if !nocomp mode - luh_state_loop: do i_lu_state = 1, n_landuse_cats + luh_state_loop: do i_lu_state = 1, n_active_landuse_cats lu_state_present_if: if ( state_vector(i_lu_state) .gt. nearzero ) then - newparea_withlanduse = newparea / state_vector(i_lu_state) - ! for now, spread nocomp PFTs evenly across land use types + newparea_withlanduse = newparea * state_vector(i_lu_state) + write(fates_log(),*) 'init_patches: istate, state_vector: ', i_lu_state, state_vector(i_lu_state) + ! for now, spread nocomp PFTs evenly across land use types new_patch_area_gt_zero: if(newparea_withlanduse.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode allocate(newp) @@ -697,6 +705,7 @@ subroutine init_patches( nsites, sites, bc_in) newp => sites(s)%oldest_patch do while (associated(newp)) tota=tota+newp%area + write(fates_log(),*) 'init_patches: area, tota, lul: ', newp%area, tota, newp%land_use_label newp=>newp%younger end do From a4cb74230a7f1be174f44d64057f147df044f03f Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 23 May 2023 15:28:48 -0700 Subject: [PATCH 060/250] correct logic on transition matrix update --- biogeochem/FatesLandUseChangeMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index 338648605b..1e8f16dbdb 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -99,7 +99,7 @@ subroutine get_landuse_transition_rates(bc_in, landuse_transition_matrix) i_receiver = lumap%GetIndex(receiver_name) ! Avoid transitions with 'urban' as those are handled seperately - if (i_donor .ne. fates_unset_int .or. i_receiver .ne. fates_unset_int) then + if (.not.(i_donor .eq. fates_unset_int .or. i_receiver .eq. fates_unset_int)) then landuse_transition_matrix(i_donor,i_receiver) = & landuse_transition_matrix(i_donor,i_receiver) + bc_in%hlm_luh_transitions(i_luh2_transitions) / (1._r8 - urban_fraction) From c94158fa1a3e8729221e852c8b29e00fbad8fa49 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 23 May 2023 17:03:51 -0700 Subject: [PATCH 061/250] transfer luh2 nan check into its own procedure --- biogeochem/FatesLandUseChangeMod.F90 | 78 ++++++++++++++++++++-------- 1 file changed, 55 insertions(+), 23 deletions(-) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index 1e8f16dbdb..e2e93e706c 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -76,16 +76,26 @@ subroutine get_landuse_transition_rates(bc_in, landuse_transition_matrix) character(5) :: donor_name, receiver_name character(14) :: transition_name real(r8) :: urban_fraction + real(r8) :: temp_vector(hlm_num_luh2_transitions) + logical :: modified_flag - ! zero the transition matrix + ! zero the transition matrix and the urban fraction landuse_transition_matrix(:,:) = 0._r8 + urban_fraction = 0._r8 use_luh_if: if ( hlm_use_luh .eq. itrue ) then - + + ! Check the LUH data incoming to see if any of the transitions are NaN + temp_vector = bc_in%hlm_luh_transitions + call CheckLUHData(temp_vector,modified_flag) + if (.not. modified_flag) then + ! identify urban fraction so that it can be factored into the land use state output + urban_fraction = bc_in%hlm_luh_states(findloc(bc_in%hlm_luh_state_names,'urban',dim=1)) + end if !!may need some logic here to ask whether or not ot perform land use cahnge on this timestep. current code occurs every day. ! identify urban fraction so that it can be accounted for in the fates land use aggregation - urban_fraction = bc_in%hlm_luh_states(findloc(bc_in%hlm_luh_state_names,'urban',dim=1)) + ! urban_fraction = bc_in%hlm_luh_states(findloc(bc_in%hlm_luh_state_names,'urban',dim=1)) transitions_loop: do i_luh2_transitions = 1, hlm_num_luh2_transitions @@ -101,7 +111,8 @@ subroutine get_landuse_transition_rates(bc_in, landuse_transition_matrix) ! Avoid transitions with 'urban' as those are handled seperately if (.not.(i_donor .eq. fates_unset_int .or. i_receiver .eq. fates_unset_int)) then landuse_transition_matrix(i_donor,i_receiver) = & - landuse_transition_matrix(i_donor,i_receiver) + bc_in%hlm_luh_transitions(i_luh2_transitions) / (1._r8 - urban_fraction) + landuse_transition_matrix(i_donor,i_receiver) + temp_vector(i_luh2_transitions) / (1._r8 - urban_fraction) + !landuse_transition_matrix(i_donor,i_receiver) + bc_in%hlm_luh_transitions(i_luh2_transitions) / (1._r8 - urban_fraction) end if end do transitions_loop @@ -219,30 +230,17 @@ subroutine get_luh_statedata(bc_in, state_vector) integer :: i_luh2_states integer :: ii character(5) :: state_name + logical :: modified_flag - ! zero state vector and temporary state vector + ! zero state vector and urban fraction state_vector(:) = 0._r8 - temp_vector = 0._r8 - - ! identify urban fraction so that it can be factored into the land use state output urban_fraction = 0._r8 ! Check to see if the incoming state vector is NaN. - ! This suggests that there is a discepency where the HLM and LUH2 states - ! there is vegetated ground. In this case, states should be Nan. If so, - ! set the current state to be all primary forest. - ! If only a portion of the vector is NaN, there is something amiss with - ! the data, so end the run. - if (all(isnan(bc_in%hlm_luh_states))) then - temp_vector(1) = 1._r8 - write(fates_log(),*) 'WARNING: land use state is all NaN; setting state as all primary forest.' - else if (any(isnan(bc_in%hlm_luh_states))) then - if (any(.not. isnan(bc_in%hlm_luh_states))) then - write(fates_log(),*) 'ERROR: land use state has NaN: ', bc_in%hlm_luh_states - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - else - temp_vector = bc_in%hlm_luh_states + temp_vector = bc_in%hlm_luh_states + call CheckLUHData(temp_vector,modified_flag) + if (.not. modified_flag) then + ! identify urban fraction so that it can be factored into the land use state output urban_fraction = bc_in%hlm_luh_states(findloc(bc_in%hlm_luh_state_names,'urban',dim=1)) end if @@ -269,4 +267,38 @@ subroutine get_luh_statedata(bc_in, state_vector) end subroutine get_luh_statedata + !---------------------------------------------------------------------------------------------------- + + subroutine CheckLUHData(luh_vector,modified_flag) + + use shr_infnan_mod , only : isnan => shr_infnan_isnan + + real(r8), intent(inout) :: luh_vector(:) ! [m2/m2] + logical, intent(out) :: modified_flag + + ! Check to see if the incoming luh2 vector is NaN. + ! This suggests that there is a discepency where the HLM and LUH2 states + ! there is vegetated ground. In this case, states should be Nan. If so, + ! set the current state to be all primary forest. + ! If only a portion of the vector is NaN, there is something amiss with + ! the data, so end the run. + + modified_flag = .false. + if (all(isnan(luh_vector))) then + luh_vector = 0._r8 + ! Check if this is a state vector, otherwise leave transitions as zero + if (size(luh_vector) .eq. hlm_num_luh2_states) then + luh_vector(1) = 1._r8 + end if + modified_flag = .true. + write(fates_log(),*) 'WARNING: land use state is all NaN; setting state as all primary forest.' + else if (any(isnan(luh_vector))) then + if (any(.not. isnan(luh_vector))) then + write(fates_log(),*) 'ERROR: land use vector has NaN' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + end subroutine CheckLUHData + end module FatesLandUseChangeMod From 7033cef427127ac124f060933b1f36e945fea425 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 23 May 2023 17:04:37 -0700 Subject: [PATCH 062/250] remove diagnostics --- main/EDInitMod.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index aeefa16b8b..5f27e1f04f 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -649,7 +649,6 @@ subroutine init_patches( nsites, sites, bc_in) lu_state_present_if: if ( state_vector(i_lu_state) .gt. nearzero ) then newparea_withlanduse = newparea * state_vector(i_lu_state) - write(fates_log(),*) 'init_patches: istate, state_vector: ', i_lu_state, state_vector(i_lu_state) ! for now, spread nocomp PFTs evenly across land use types new_patch_area_gt_zero: if(newparea_withlanduse.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode @@ -705,7 +704,6 @@ subroutine init_patches( nsites, sites, bc_in) newp => sites(s)%oldest_patch do while (associated(newp)) tota=tota+newp%area - write(fates_log(),*) 'init_patches: area, tota, lul: ', newp%area, tota, newp%land_use_label newp=>newp%younger end do From a20b69693b614ed3bb154624f06b078cd77a5cc8 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 24 May 2023 09:10:59 -0700 Subject: [PATCH 063/250] remove unnessary use statements --- biogeochem/FatesLandUseChangeMod.F90 | 3 --- 1 file changed, 3 deletions(-) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index e2e93e706c..92992d4680 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -17,7 +17,6 @@ module FatesLandUseChangeMod use EDTypesMod , only : area_site => area ! CIME globals - use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) use shr_log_mod , only : errMsg => shr_log_errMsg ! @@ -218,8 +217,6 @@ end subroutine get_landusechange_rules subroutine get_luh_statedata(bc_in, state_vector) - use shr_infnan_mod , only : isnan => shr_infnan_isnan - type(bc_in_type) , intent(in) :: bc_in real(r8), intent(out) :: state_vector(n_landuse_cats) ! [m2/m2] From 53ee4a2a01976ebe52b7ee88f1d9a4cb5ce15f9a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 31 May 2023 21:05:04 -0400 Subject: [PATCH 064/250] All sorts of two-stream and general radiation clean up --- biogeochem/EDPatchDynamicsMod.F90 | 6 - biogeophys/FatesPlantRespPhotosynthMod.F90 | 41 +- main/EDInitMod.F90 | 3 +- main/EDMainMod.F90 | 2 +- main/EDTypesMod.F90 | 16 +- main/FatesHistoryInterfaceMod.F90 | 1484 +++++++++++--------- main/FatesIOVariableKindMod.F90 | 9 + main/FatesInterfaceTypesMod.F90 | 7 +- main/FatesInventoryInitMod.F90 | 4 +- main/FatesRestartInterfaceMod.F90 | 54 +- radiation/FatesRadiationDriveMod.F90 | 199 +-- radiation/FatesRadiationMemMod.F90 | 2 +- radiation/FatesTwoStreamInterfaceMod.F90 | 4 +- radiation/TwoStreamMLPEMod.F90 | 31 +- 14 files changed, 1037 insertions(+), 825 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index fc80db8146..bbadaa2e24 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2163,8 +2163,6 @@ subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) ! rates routine is called. This does not need to be remembered or in the restart file. new_patch%f_sun = 0._r8 - new_patch%ed_laisun_z(:,:,:) = 0._r8 - new_patch%ed_laisha_z(:,:,:) = 0._r8 new_patch%ed_parsun_z(:,:,:) = 0._r8 new_patch%ed_parsha_z(:,:,:) = 0._r8 new_patch%fabi = 0._r8 @@ -2244,8 +2242,6 @@ subroutine zero_patch(cp_p) currentPatch%fabi_sun_z(:,:,:) = nan currentPatch%fabi_sha_z(:,:,:) = nan - currentPatch%ed_laisun_z(:,:,:) = nan - currentPatch%ed_laisha_z(:,:,:) = nan currentPatch%ed_parsun_z(:,:,:) = nan currentPatch%ed_parsha_z(:,:,:) = nan currentPatch%psn_z(:,:,:) = 0._r8 @@ -2309,8 +2305,6 @@ subroutine zero_patch(cp_p) ! diagnostic radiation profiles currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 currentPatch%solar_zenith_flag = .false. currentPatch%solar_zenith_angle = nan diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 8fe13fb654..08ba77d4cd 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -279,9 +279,12 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8),dimension(50) :: cohort_vaibot real(r8),dimension(50) :: cohort_layer_elai real(r8),dimension(50) :: cohort_layer_esai + real(r8),dimension(50) :: cohort_layer_tlai + real(r8),dimension(50) :: cohort_layer_tsai real(r8) :: cohort_elai real(r8) :: cohort_esai real(r8) :: elai_layer + real(r8) :: laisun,laisha ! ----------------------------------------------------------------------------------- ! Keeping these two definitions in case they need to be added later @@ -440,7 +443,9 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) cohort_vaitop(iv), & cohort_vaibot(iv), & cohort_layer_elai(iv), & - cohort_layer_esai(iv)) + cohort_layer_esai(iv))!, & + !cohort_layer_tlai(iv), & + ! cohort_layer_tsai(iv)) end do cohort_elai = sum(cohort_layer_elai(1:currentCohort%nv)) @@ -489,6 +494,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) rate_mask_if: if ( .not.rate_mask_z(iv,ft,cl) .or. & (hlm_use_planthydro.eq.itrue) .or. & (rad_solver .eq. twostr_solver ) .or. & + (rad_solver .eq. norman_solver ) .or. & (nleafage > 1) .or. & (hlm_parteh_mode .ne. prt_carbon_allom_hyp ) ) then @@ -542,8 +548,10 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) kn = decay_coeff_kn(ft,currentCohort%vcmax25top) ! Scale for leaf nitrogen profile - nscaler = exp(-kn * cumulative_lai) + !nscaler = exp(-kn * cumulative_lai) + nscaler = 1.0_r8 + ! Leaf maintenance respiration to match the base rate used in CN ! but with the new temperature functions for C3 and C4 plants. @@ -608,25 +616,37 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! ------------------------------------------------------------------ if_radsolver: if(rad_solver.eq.norman_solver) then - - if(((currentPatch%ed_laisun_z(cl,ft,iv)*currentPatch%canopy_area_profile(cl,ft,iv)) >nearzero) .and. & + + laisun = currentPatch%elai_profile(cl,ft,iv)*currentPatch%f_sun(cl,ft,iv) + laisha = currentPatch%elai_profile(cl,ft,iv)*(1._r8-currentPatch%f_sun(cl,ft,iv)) + + if(((laisun*currentPatch%canopy_area_profile(cl,ft,iv)) >nearzero) .and. & (currentPatch%ed_parsun_z(cl,ft,iv)>nearzero)) then + + ! laisun: m2 of exposed leaf, per m2 of crown. If this is the lowest layer + ! for the pft/canopy group, than the m2 per crown is probably not + ! as large as the layer above. + ! ed_parsun_z: this is W/m2 ground times the canopy_area_profile, which is the + ! fraction of m2 of ground in the crown per m2 ground in the + ! total canopy area. This results in W/m2 of total canopy. + par_per_sunla = currentPatch%ed_parsun_z(cl,ft,iv) / & - (currentPatch%ed_laisun_z(cl,ft,iv)*currentPatch%canopy_area_profile(cl,ft,iv)) + (laisun*currentPatch%canopy_area_profile(cl,ft,iv)) + else par_per_sunla = 0._r8 end if - if(((currentPatch%ed_laisha_z(cl,ft,iv)*currentPatch%canopy_area_profile(cl,ft,iv)) >nearzero) .and. & + if(((laisha*currentPatch%canopy_area_profile(cl,ft,iv)) >nearzero) .and. & (currentPatch%ed_parsha_z(cl,ft,iv)>nearzero)) then par_per_shala = currentPatch%ed_parsha_z(cl,ft,iv) / & - (currentPatch%ed_laisha_z(cl,ft,iv)*currentPatch%canopy_area_profile(cl,ft,iv)) + (laisha*currentPatch%canopy_area_profile(cl,ft,iv)) else par_per_shala = 0._r8 end if fsun = currentPatch%f_sun(cl,ft,iv) - elai_layer = currentPatch%ed_laisha_z(cl,ft,iv) + currentPatch%ed_laisun_z(cl,ft,iv) + elai_layer = currentPatch%elai_profile(cl,ft,iv) else @@ -653,6 +673,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) par_per_shala = rd_abs_leaf*(1._r8-fsun) / ((1._r8 - fsun)*cohort_layer_elai(iv)) else + par_per_sunla = 0._r8 par_per_shala = 0._r8 fsun = 0.5_r8 !avoid div0, should have no impact @@ -2169,7 +2190,7 @@ subroutine LeafLayerMaintenanceRespiration_Ryan_1991(lnc_top, & real(r8), intent(in) :: lnc_top ! Leaf nitrogen content per unit area at canopy top [gN/m2] real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8) :: veg_tempk ! vegetation temperature real(r8), intent(out) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) ! Locals @@ -2185,6 +2206,8 @@ subroutine LeafLayerMaintenanceRespiration_Ryan_1991(lnc_top, & real(r8), parameter :: lmrc = 1.15912391_r8 ! scaling factor for high ! temperature inhibition (25 C = 1.0) + !veg_tempk = 27._r8+271._r8 + lmr25top = EDPftvarcon_inst%maintresp_leaf_ryan1991_baserate(ft) * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) lmr25top = lmr25top * lnc_top / (umolC_to_kgC * g_per_kg) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 45b3ac7551..98e1e89bdd 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -557,8 +557,9 @@ subroutine init_patches( nsites, sites, bc_in) call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & biomass_stock,litter_stock,seed_stock) end do + call set_patchno(sites(s)) enddo - + else do s = 1, nsites diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 427a687f8c..121b3dfac2 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -839,7 +839,7 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) if( hlm_day_of_year == hlm_days_per_year-1) then if(hlm_use_sp.eq.ifalse)then - call trim_canopy(currentSite) + call trim_canopy(currentSite) endif endif diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 07bfef42be..b700edbcc1 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -30,7 +30,7 @@ module EDTypesMod private ! By default everything is private save - integer, parameter, public :: nclmax = 2 ! Maximum number of canopy layers + integer, parameter, public :: nclmax = 3 ! Maximum number of canopy layers integer, parameter, public :: ican_upper = 1 ! Nominal index for the upper canopy integer, parameter, public :: ican_ustory = 2 ! Nominal index for diagnostics that refer ! to understory layers (all layers that @@ -482,9 +482,6 @@ module EDTypesMod real(r8) :: fabi_sha_z(nclmax,maxpft,nlevleaf) ! shade fraction of indirect light absorbed by each canopy ! layer, pft, and leaf layer:- - real(r8) :: ed_laisun_z(nclmax,maxpft,nlevleaf) ! amount of LAI in the sun in each canopy layer, - ! pft, and leaf layer. m2/m2 - real(r8) :: ed_laisha_z(nclmax,maxpft,nlevleaf) ! amount of LAI in the shade in each canopy layer, real(r8) :: ed_parsun_z(nclmax,maxpft,nlevleaf) ! PAR absorbed in the sun in each canopy layer, real(r8) :: ed_parsha_z(nclmax,maxpft,nlevleaf) ! PAR absorbed in the shade in each canopy layer, real(r8) :: f_sun(nclmax,maxpft,nlevleaf) ! fraction of leaves in the sun in each canopy layer, pft, @@ -499,19 +496,10 @@ module EDTypesMod ! incident type (direct/diffuse at top of canopy),leaf,pft,leaf (unitless) real(r8) :: nrmlzd_parprof_pft_dif_z(num_rad_stream_types,nclmax,maxpft,nlevleaf) - ! normalized direct photosynthetically active radiation profiles by - ! incident type (direct/diffuse at top of canopy),leaf,leaf (unitless) - real(r8) :: nrmlzd_parprof_dir_z(num_rad_stream_types,nclmax,nlevleaf) - - ! normalized diffuse photosynthetically active radiation profiles by - ! incident type (direct/diffuse at top of canopy),leaf,leaf (unitless) - real(r8) :: nrmlzd_parprof_dif_z(num_rad_stream_types,nclmax,nlevleaf) - real(r8) :: parprof_pft_dir_z(nclmax,maxpft,nlevleaf) ! direct-beam PAR profile through canopy, by canopy,PFT,leaf level (w/m2) real(r8) :: parprof_pft_dif_z(nclmax,maxpft,nlevleaf) ! diffuse PAR profile through canopy, by canopy,PFT,leaf level (w/m2) - real(r8) :: parprof_dir_z(nclmax,nlevleaf) ! direct-beam PAR profile through canopy, by canopy,leaf level (w/m2) - real(r8) :: parprof_dif_z(nclmax,nlevleaf) ! diffuse PAR profile through canopy, by canopy,leaf level (w/m2) + ! and leaf layer. m2/m2 real(r8),allocatable :: tr_soil_dir(:) ! fraction of incoming direct radiation that (cm_numSWb) ! is transmitted to the soil as direct diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index bb92d267f0..bc86b7ae45 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -31,6 +31,7 @@ module FatesHistoryInterfaceMod use EDTypesMod , only : dtype_ifall use EDTypesMod , only : dtype_ifire use EDTypesMod , only : dtype_ilog + use FatesIOVariableKindMod , only : upfreq_hifr_multi use FatesIODimensionsMod , only : fates_io_dimension_type use FatesIOVariableKindMod , only : fates_io_variable_kind_type use FatesIOVariableKindMod , only : site_int @@ -54,6 +55,9 @@ module FatesHistoryInterfaceMod use FatesInterfaceTypesMod , only : nlevcoage use FatesInterfaceTypesMod , only : hlm_use_nocomp use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog + + use FatesInterfaceTypesMod , only : hio_include_hifr_multi + use FatesAllometryMod , only : CrownDepth use FatesAllometryMod , only : bstore_allom use FatesAllometryMod , only : set_root_fraction @@ -576,6 +580,7 @@ module FatesHistoryInterfaceMod integer :: ih_firemortality_carbonflux_si_pft integer :: ih_crownarea_si_pft integer :: ih_canopycrownarea_si_pft + integer :: ih_crownarea_si_cnlf integer :: ih_gpp_si_pft integer :: ih_gpp_sec_si_pft integer :: ih_npp_si_pft @@ -676,21 +681,25 @@ module FatesHistoryInterfaceMod integer :: ih_fabi_sun_si_cnlf integer :: ih_fabi_sha_si_cnlf integer :: ih_ts_net_uptake_si_cnlf - integer :: ih_crownarea_si_cnlf + integer :: ih_crownarea_clll integer :: ih_parprof_dir_si_cnlf integer :: ih_parprof_dif_si_cnlf ! indices to (site x [canopy layer x leaf layer x pft]) variables integer :: ih_parsun_z_si_cnlfpft integer :: ih_parsha_z_si_cnlfpft - integer :: ih_laisun_z_si_cnlfpft - integer :: ih_laisha_z_si_cnlfpft + integer :: ih_laisun_clllpf + integer :: ih_laisha_clllpf + integer :: ih_parprof_dir_si_cnlfpft + integer :: ih_parprof_dif_si_cnlfpft + integer :: ih_crownfrac_clllpf + + integer :: ih_fabd_sun_si_cnlfpft integer :: ih_fabd_sha_si_cnlfpft integer :: ih_fabi_sun_si_cnlfpft integer :: ih_fabi_sha_si_cnlfpft - integer :: ih_parprof_dir_si_cnlfpft - integer :: ih_parprof_dif_si_cnlfpft + ! indices to site x crown damage variables ! site x crown damage x pft x sizeclass @@ -724,10 +733,8 @@ module FatesHistoryInterfaceMod integer :: ih_fabd_sha_top_si_can integer :: ih_fabi_sun_top_si_can integer :: ih_fabi_sha_top_si_can - integer :: ih_crownarea_si_can + integer :: ih_crownarea_cl - integer :: ih_fsun_si - ! indices to (patch age x fuel size class) variables integer :: ih_fuel_amount_age_fuel @@ -773,7 +780,8 @@ module FatesHistoryInterfaceMod procedure :: assemble_history_output_types procedure :: update_history_dyn - procedure :: update_history_hifrq + procedure :: update_history_hifrq_simple + procedure :: update_history_hifrq_multi procedure :: update_history_hydraulics procedure :: update_history_nutrflux @@ -2069,15 +2077,6 @@ subroutine update_history_nutrflux(this,csite) cpatch => cpatch%older end do - ! Normalize the layer x size x pft arrays - !do iclscpf = 1,nclmax*numpft*nlevsclass - !if(fnrtc_clscpf(iclscpf)>nearzero) then - ! hio_l2fr_clscpf(io_si,iclscpf) = hio_l2fr_clscpf(io_si,iclscpf) / fnrtc_clscpf(iclscpf) - !else - ! hio_l2fr_clscpf(io_si,iclscpf) = hlm_hio_ignore_val - !end if - !end do - do ft = 1,numpft hio_recl2fr_canopy_pf(io_si,ft) = csite%rec_l2fr(ft,1) hio_recl2fr_ustory_pf(io_si,ft) = csite%rec_l2fr(ft,2) @@ -2467,7 +2466,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_cwd_ag_out_si_cwdsc => this%hvars(ih_cwd_ag_out_si_cwdsc)%r82d, & hio_cwd_bg_out_si_cwdsc => this%hvars(ih_cwd_bg_out_si_cwdsc)%r82d, & hio_crownarea_si_cnlf => this%hvars(ih_crownarea_si_cnlf)%r82d, & - hio_crownarea_si_can => this%hvars(ih_crownarea_si_can)%r82d, & + hio_crownarea_cl => this%hvars(ih_crownarea_cl)%r82d, & hio_nplant_si_scag => this%hvars(ih_nplant_si_scag)%r82d, & hio_nplant_canopy_si_scag => this%hvars(ih_nplant_canopy_si_scag)%r82d, & hio_nplant_understory_si_scag => this%hvars(ih_nplant_understory_si_scag)%r82d, & @@ -2487,7 +2486,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_dleafoff_si => this%hvars(ih_dleafoff_si)%r81d, & hio_dleafon_si => this%hvars(ih_dleafon_si)%r81d, & hio_tveg24 => this%hvars(ih_tveg24_si)%r81d, & - hio_tlongterm => this%hvars(ih_tlongterm_si)%r81d, & + hio_tlongterm => this%hvars(ih_tlongterm_si)%r81d, & hio_tgrowth => this%hvars(ih_tgrowth_si)%r81d, & hio_meanliqvol_si => this%hvars(ih_meanliqvol_si)%r81d, & hio_cbal_err_fates_si => this%hvars(ih_cbal_err_fates_si)%r81d, & @@ -3636,7 +3635,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! resolve some canopy area profiles, both total and of occupied leaves ican = ccohort%canopy_layer ! - hio_crownarea_si_can(io_si, ican) = hio_crownarea_si_can(io_si, ican) + ccohort%c_area / AREA + hio_crownarea_cl(io_si, ican) = hio_crownarea_cl(io_si, ican) + ccohort%c_area / AREA ! do ileaf=1,ccohort%nv cnlf_indx = ileaf + (ican-1) * nlevleaf @@ -4336,11 +4335,214 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) return end subroutine update_history_dyn - subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) + + + subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) + + use EDTypesMod , only : nclmax, nlevleaf + ! + ! Arguments + class(fates_history_interface_type) :: this + integer , intent(in) :: nc ! clump index + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type) , intent(in) :: bc_in(nsites) + type(bc_out_type) , intent(in) :: bc_out(nsites) + real(r8) , intent(in) :: dt_tstep + + ! Locals + integer :: s ! The local site index + integer :: io_si ! The site index of the IO array + integer :: ipa ! patch bc index for the patch + real(r8) :: site_area_veg_inv ! inverse canopy area of the site (1/m2) + real(r8) :: dt_tstep_inv ! inverse timestep (1/sec) + real(r8) :: n_perm2 ! number of plants per square meter + type(ed_patch_type),pointer :: cpatch + type(ed_cohort_type),pointer :: ccohort + + associate( hio_gpp_si => this%hvars(ih_gpp_si)%r81d, & + hio_gpp_secondary_si => this%hvars(ih_gpp_secondary_si)%r81d, & + hio_npp_si => this%hvars(ih_npp_si)%r81d, & + hio_npp_secondary_si => this%hvars(ih_npp_secondary_si)%r81d, & + hio_aresp_si => this%hvars(ih_aresp_si)%r81d, & + hio_aresp_secondary_si => this%hvars(ih_aresp_secondary_si)%r81d, & + hio_maint_resp_si => this%hvars(ih_maint_resp_si)%r81d, & + hio_maint_resp_secondary_si => this%hvars(ih_maint_resp_secondary_si)%r81d, & + hio_growth_resp_si => this%hvars(ih_growth_resp_si)%r81d, & + hio_growth_resp_secondary_si => this%hvars(ih_growth_resp_secondary_si)%r81d, & + hio_c_stomata_si => this%hvars(ih_c_stomata_si)%r81d, & + hio_c_lblayer_si => this%hvars(ih_c_lblayer_si)%r81d, & + hio_rad_error_si => this%hvars(ih_rad_error_si)%r81d, & + hio_nep_si => this%hvars(ih_nep_si)%r81d, & + hio_hr_si => this%hvars(ih_hr_si)%r81d, & + hio_gpp_canopy_si => this%hvars(ih_gpp_canopy_si)%r81d, & + hio_ar_canopy_si => this%hvars(ih_ar_canopy_si)%r81d, & + hio_gpp_understory_si => this%hvars(ih_gpp_understory_si)%r81d, & + hio_ar_understory_si => this%hvars(ih_ar_understory_si)%r81d, & + hio_leaf_mr_si => this%hvars(ih_leaf_mr_si)%r81d, & + hio_froot_mr_si => this%hvars(ih_froot_mr_si)%r81d, & + hio_livecroot_mr_si => this%hvars(ih_livecroot_mr_si)%r81d, & + hio_livestem_mr_si => this%hvars(ih_livestem_mr_si)%r81d, & + hio_maint_resp_unreduced_si => this%hvars(ih_maint_resp_unreduced_si)%r81d, & + hio_tveg => this%hvars(ih_tveg_si)%r81d) + + + ! Flush the relevant history variables + call this%flush_hvars(nc,upfreq_in=2) + + dt_tstep_inv = 1.0_r8/dt_tstep + + do_sites: do s = 1,nsites + + call this%zero_site_hvars(sites(s), upfreq_in=2) + + io_si = sites(s)%h_gid + + hio_nep_si(io_si) = -bc_in(s)%tot_het_resp * kg_per_g + hio_hr_si(io_si) = bc_in(s)%tot_het_resp * kg_per_g + + site_area_veg_inv = 0._r8 + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + site_area_veg_inv = site_area_veg_inv + cpatch%total_canopy_area + cpatch => cpatch%younger + end do !patch loop + + if_veg_area: if(site_area_veg_inv < nearzero) then + + hio_c_stomata_si(io_si) = hlm_hio_ignore_val + hio_c_lblayer_si(io_si) = hlm_hio_ignore_val + hio_rad_error_si(io_si) = hlm_hio_ignore_val + hio_tveg(io_si) = hlm_hio_ignore_val + + exit if_veg_area + + else + + ipa = 0 + site_area_veg_inv = 1._r8/site_area_veg_inv + + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + + ipa = ipa + 1 + + + hio_c_stomata_si(io_si) = hio_c_stomata_si(io_si) + & + cpatch%c_stomata * cpatch%total_canopy_area * mol_per_umol * site_area_veg_inv + + hio_c_lblayer_si(io_si) = hio_c_lblayer_si(io_si) + & + cpatch%c_lblayer * cpatch%total_canopy_area * mol_per_umol * site_area_veg_inv + + hio_rad_error_si(io_si) = hio_rad_error_si(io_si) + & + cpatch%radiation_error * cpatch%total_canopy_area * site_area_veg_inv + + ! Only accumulate the instantaneous vegetation temperature for vegetated patches + if (cpatch%patchno .ne. 0) then + hio_tveg(io_si) = hio_tveg(io_si) + & + (bc_in(s)%t_veg_pa(cpatch%patchno) - t_water_freeze_k_1atm) * & + cpatch%total_canopy_area * site_area_veg_inv + end if + + ccohort => cpatch%shortest + do while(associated(ccohort)) + + n_perm2 = ccohort%n * AREA_INV + + if_notnew: if ( .not. ccohort%isnew ) then + + ! scale up cohort fluxes to the site level + hio_npp_si(io_si) = hio_npp_si(io_si) + & + ccohort%npp_tstep * n_perm2 * dt_tstep_inv + + ! Net Ecosystem Production [kgC/m2/s] + hio_nep_si(io_si) = hio_nep_si(io_si) + & + ccohort%npp_tstep * n_perm2 * dt_tstep_inv + + hio_gpp_si(io_si) = hio_gpp_si(io_si) + & + ccohort%gpp_tstep * n_perm2 * dt_tstep_inv + + hio_aresp_si(io_si) = hio_aresp_si(io_si) + & + ccohort%resp_tstep * n_perm2 * dt_tstep_inv + + hio_growth_resp_si(io_si) = hio_growth_resp_si(io_si) + & + ccohort%resp_g_tstep * n_perm2 * dt_tstep_inv + + hio_maint_resp_si(io_si) = hio_maint_resp_si(io_si) + & + ccohort%resp_m * n_perm2 * dt_tstep_inv + + hio_maint_resp_unreduced_si(io_si) = hio_maint_resp_unreduced_si(io_si) + & + ccohort%resp_m_unreduced * n_perm2 * dt_tstep_inv + + ! Secondary forest only + if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + hio_npp_secondary_si(io_si) = hio_npp_secondary_si(io_si) + & + ccohort%npp_tstep * n_perm2 * dt_tstep_inv + + hio_gpp_secondary_si(io_si) = hio_gpp_secondary_si(io_si) + & + ccohort%gpp_tstep * n_perm2 * dt_tstep_inv + + hio_aresp_secondary_si(io_si) = hio_aresp_secondary_si(io_si) + & + ccohort%resp_tstep * n_perm2 * dt_tstep_inv + + hio_growth_resp_secondary_si(io_si) = hio_growth_resp_secondary_si(io_si) + & + ccohort%resp_g_tstep * n_perm2 * dt_tstep_inv + + hio_maint_resp_secondary_si(io_si) = hio_maint_resp_secondary_si(io_si) + & + ccohort%resp_m * n_perm2 * dt_tstep_inv + end if + + ! Maintenance respiration of different organs + hio_leaf_mr_si(io_si) = hio_leaf_mr_si(io_si) + ccohort%rdark & + * n_perm2 + hio_froot_mr_si(io_si) = hio_froot_mr_si(io_si) + ccohort%froot_mr & + * n_perm2 + hio_livecroot_mr_si(io_si) = hio_livecroot_mr_si(io_si) + ccohort%livecroot_mr & + * n_perm2 + hio_livestem_mr_si(io_si) = hio_livestem_mr_si(io_si) + ccohort%livestem_mr & + * n_perm2 + + ! accumulate fluxes on canopy- and understory- separated fluxes + if (ccohort%canopy_layer .eq. 1) then + + ! bulk fluxes are in gC / m2 / s + hio_gpp_canopy_si(io_si) = hio_gpp_canopy_si(io_si) + & + ccohort%gpp_tstep * n_perm2 * dt_tstep_inv + + hio_ar_canopy_si(io_si) = hio_ar_canopy_si(io_si) + & + ccohort%resp_tstep * n_perm2 * dt_tstep_inv + + else + + ! bulk fluxes are in gC / m2 / s + hio_gpp_understory_si(io_si) = hio_gpp_understory_si(io_si) + & + ccohort%gpp_tstep * n_perm2 * dt_tstep_inv + + hio_ar_understory_si(io_si) = hio_ar_understory_si(io_si) + & + ccohort%resp_tstep * n_perm2 * dt_tstep_inv + + end if + + end if if_notnew + ccohort => ccohort%taller + end do + + cpatch => cpatch%younger + end do + end if if_veg_area + end do do_sites + end associate + return + end subroutine update_history_hifrq_simple + + ! =============================================================================================== + + subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) ! --------------------------------------------------------------------------------- - ! This is the call to update the history IO arrays that are expected to only change - ! after rapid timescale productivity calculations (gpp and respiration). + ! This is the call to update the history IO arrays for multi-dimension arrays + ! that change rapidly. This is an expensive call, the model will probably run + ! much faster if the user is not using any of these diagnostics. ! --------------------------------------------------------------------------------- use EDTypesMod , only : nclmax, nlevleaf @@ -4368,126 +4570,100 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) real(r8) :: n_perm2 ! individuals per m2 for the whole column real(r8) :: patch_area_by_age(nlevage) ! patch area in each bin for normalizing purposes real(r8) :: canopy_area_by_age(nlevage) ! canopy area in each bin for normalizing purposes - real(r8) :: site_area_veg ! area of the site that is not bare-ground + real(r8) :: site_area_veg_inv ! 1/area of the site that is not bare-ground integer :: ipa2 ! patch incrementer integer :: cnlfpft_indx, cnlf_indx, ipft, ican, ileaf ! more iterators and indices type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort - real(r8) :: per_dt_tstep ! Time step in frequency units (/s) - real(r8) :: elai_tot - - associate( hio_gpp_si => this%hvars(ih_gpp_si)%r81d, & - hio_gpp_secondary_si => this%hvars(ih_gpp_secondary_si)%r81d, & - hio_npp_si => this%hvars(ih_npp_si)%r81d, & - hio_npp_secondary_si => this%hvars(ih_npp_secondary_si)%r81d, & - hio_aresp_si => this%hvars(ih_aresp_si)%r81d, & - hio_aresp_secondary_si => this%hvars(ih_aresp_secondary_si)%r81d, & - hio_maint_resp_si => this%hvars(ih_maint_resp_si)%r81d, & - hio_maint_resp_secondary_si => this%hvars(ih_maint_resp_secondary_si)%r81d, & - hio_growth_resp_si => this%hvars(ih_growth_resp_si)%r81d, & - hio_growth_resp_secondary_si => this%hvars(ih_growth_resp_secondary_si)%r81d, & - hio_c_stomata_si => this%hvars(ih_c_stomata_si)%r81d, & - hio_c_lblayer_si => this%hvars(ih_c_lblayer_si)%r81d, & - hio_rad_error_si => this%hvars(ih_rad_error_si)%r81d, & - hio_nep_si => this%hvars(ih_nep_si)%r81d, & - hio_hr_si => this%hvars(ih_hr_si)%r81d, & - hio_ar_si_scpf => this%hvars(ih_ar_si_scpf)%r82d, & - hio_ar_grow_si_scpf => this%hvars(ih_ar_grow_si_scpf)%r82d, & - hio_ar_maint_si_scpf => this%hvars(ih_ar_maint_si_scpf)%r82d, & - hio_ar_agsapm_si_scpf => this%hvars(ih_ar_agsapm_si_scpf)%r82d, & - hio_ar_darkm_si_scpf => this%hvars(ih_ar_darkm_si_scpf)%r82d, & - hio_ar_crootm_si_scpf => this%hvars(ih_ar_crootm_si_scpf)%r82d, & - hio_ar_frootm_si_scpf => this%hvars(ih_ar_frootm_si_scpf)%r82d, & - hio_gpp_canopy_si => this%hvars(ih_gpp_canopy_si)%r81d, & - hio_ar_canopy_si => this%hvars(ih_ar_canopy_si)%r81d, & - hio_gpp_understory_si => this%hvars(ih_gpp_understory_si)%r81d, & - hio_ar_understory_si => this%hvars(ih_ar_understory_si)%r81d, & - hio_rdark_canopy_si_scls => this%hvars(ih_rdark_canopy_si_scls)%r82d, & - hio_livestem_mr_canopy_si_scls => this%hvars(ih_livestem_mr_canopy_si_scls)%r82d, & - hio_livecroot_mr_canopy_si_scls => this%hvars(ih_livecroot_mr_canopy_si_scls)%r82d, & - hio_froot_mr_canopy_si_scls => this%hvars(ih_froot_mr_canopy_si_scls)%r82d, & - hio_resp_g_canopy_si_scls => this%hvars(ih_resp_g_canopy_si_scls)%r82d, & - hio_resp_m_canopy_si_scls => this%hvars(ih_resp_m_canopy_si_scls)%r82d, & - hio_rdark_understory_si_scls => this%hvars(ih_rdark_understory_si_scls)%r82d, & - hio_livestem_mr_understory_si_scls => this%hvars(ih_livestem_mr_understory_si_scls)%r82d, & - hio_livecroot_mr_understory_si_scls => this%hvars(ih_livecroot_mr_understory_si_scls)%r82d, & - hio_froot_mr_understory_si_scls => this%hvars(ih_froot_mr_understory_si_scls)%r82d, & - hio_resp_g_understory_si_scls => this%hvars(ih_resp_g_understory_si_scls)%r82d, & - hio_resp_m_understory_si_scls => this%hvars(ih_resp_m_understory_si_scls)%r82d, & - hio_leaf_mr_si => this%hvars(ih_leaf_mr_si)%r81d, & - hio_froot_mr_si => this%hvars(ih_froot_mr_si)%r81d, & - hio_livecroot_mr_si => this%hvars(ih_livecroot_mr_si)%r81d, & - hio_livestem_mr_si => this%hvars(ih_livestem_mr_si)%r81d, & - hio_gpp_si_age => this%hvars(ih_gpp_si_age)%r82d, & - hio_npp_si_age => this%hvars(ih_npp_si_age)%r82d, & - hio_c_stomata_si_age => this%hvars(ih_c_stomata_si_age)%r82d, & - hio_c_lblayer_si_age => this%hvars(ih_c_lblayer_si_age)%r82d, & - hio_parsun_z_si_cnlf => this%hvars(ih_parsun_z_si_cnlf)%r82d, & - hio_parsha_z_si_cnlf => this%hvars(ih_parsha_z_si_cnlf)%r82d, & - hio_ts_net_uptake_si_cnlf => this%hvars(ih_ts_net_uptake_si_cnlf)%r82d, & - hio_parsun_z_si_cnlfpft => this%hvars(ih_parsun_z_si_cnlfpft)%r82d, & - hio_parsha_z_si_cnlfpft => this%hvars(ih_parsha_z_si_cnlfpft)%r82d, & - hio_laisun_z_si_cnlf => this%hvars(ih_laisun_z_si_cnlf)%r82d, & - hio_laisha_z_si_cnlf => this%hvars(ih_laisha_z_si_cnlf)%r82d, & - hio_laisun_z_si_cnlfpft => this%hvars(ih_laisun_z_si_cnlfpft)%r82d, & - hio_laisha_z_si_cnlfpft => this%hvars(ih_laisha_z_si_cnlfpft)%r82d, & - hio_laisun_top_si_can => this%hvars(ih_laisun_top_si_can)%r82d, & - hio_laisha_top_si_can => this%hvars(ih_laisha_top_si_can)%r82d, & - hio_fabd_sun_si_cnlfpft => this%hvars(ih_fabd_sun_si_cnlfpft)%r82d, & - hio_fabd_sha_si_cnlfpft => this%hvars(ih_fabd_sha_si_cnlfpft)%r82d, & - hio_fabi_sun_si_cnlfpft => this%hvars(ih_fabi_sun_si_cnlfpft)%r82d, & - hio_fabi_sha_si_cnlfpft => this%hvars(ih_fabi_sha_si_cnlfpft)%r82d, & - hio_fabd_sun_si_cnlf => this%hvars(ih_fabd_sun_si_cnlf)%r82d, & - hio_fabd_sha_si_cnlf => this%hvars(ih_fabd_sha_si_cnlf)%r82d, & - hio_fabi_sun_si_cnlf => this%hvars(ih_fabi_sun_si_cnlf)%r82d, & - hio_fabi_sha_si_cnlf => this%hvars(ih_fabi_sha_si_cnlf)%r82d, & - hio_parprof_dir_si_cnlf => this%hvars(ih_parprof_dir_si_cnlf)%r82d, & - hio_parprof_dif_si_cnlf => this%hvars(ih_parprof_dif_si_cnlf)%r82d, & - hio_parprof_dir_si_cnlfpft => this%hvars(ih_parprof_dir_si_cnlfpft)%r82d, & - hio_parprof_dif_si_cnlfpft => this%hvars(ih_parprof_dif_si_cnlfpft)%r82d, & - hio_fabd_sun_top_si_can => this%hvars(ih_fabd_sun_top_si_can)%r82d, & - hio_fabd_sha_top_si_can => this%hvars(ih_fabd_sha_top_si_can)%r82d, & - hio_fabi_sun_top_si_can => this%hvars(ih_fabi_sun_top_si_can)%r82d, & - hio_fabi_sha_top_si_can => this%hvars(ih_fabi_sha_top_si_can)%r82d, & - hio_parsun_top_si_can => this%hvars(ih_parsun_top_si_can)%r82d, & - hio_parsha_top_si_can => this%hvars(ih_parsha_top_si_can)%r82d, & - hio_maint_resp_unreduced_si => this%hvars(ih_maint_resp_unreduced_si)%r81d, & - hio_tveg => this%hvars(ih_tveg_si)%r81d, & - hio_fsun_si => this%hvars(ih_fsun_si)%r81d) + real(r8) :: dt_tstep_inv ! Time step in frequency units (/s) + if(.not.hio_include_hifr_multi) return + + associate( hio_ar_si_scpf => this%hvars(ih_ar_si_scpf)%r82d, & + hio_ar_grow_si_scpf => this%hvars(ih_ar_grow_si_scpf)%r82d, & + hio_ar_maint_si_scpf => this%hvars(ih_ar_maint_si_scpf)%r82d, & + hio_ar_agsapm_si_scpf => this%hvars(ih_ar_agsapm_si_scpf)%r82d, & + hio_ar_darkm_si_scpf => this%hvars(ih_ar_darkm_si_scpf)%r82d, & + hio_ar_crootm_si_scpf => this%hvars(ih_ar_crootm_si_scpf)%r82d, & + hio_ar_frootm_si_scpf => this%hvars(ih_ar_frootm_si_scpf)%r82d, & + hio_rdark_canopy_si_scls => this%hvars(ih_rdark_canopy_si_scls)%r82d, & + hio_livestem_mr_canopy_si_scls => this%hvars(ih_livestem_mr_canopy_si_scls)%r82d, & + hio_livecroot_mr_canopy_si_scls => this%hvars(ih_livecroot_mr_canopy_si_scls)%r82d, & + hio_froot_mr_canopy_si_scls => this%hvars(ih_froot_mr_canopy_si_scls)%r82d, & + hio_resp_g_canopy_si_scls => this%hvars(ih_resp_g_canopy_si_scls)%r82d, & + hio_resp_m_canopy_si_scls => this%hvars(ih_resp_m_canopy_si_scls)%r82d, & + hio_rdark_understory_si_scls => this%hvars(ih_rdark_understory_si_scls)%r82d, & + hio_livestem_mr_understory_si_scls => this%hvars(ih_livestem_mr_understory_si_scls)%r82d, & + hio_livecroot_mr_understory_si_scls => this%hvars(ih_livecroot_mr_understory_si_scls)%r82d, & + hio_froot_mr_understory_si_scls => this%hvars(ih_froot_mr_understory_si_scls)%r82d, & + hio_resp_g_understory_si_scls => this%hvars(ih_resp_g_understory_si_scls)%r82d, & + hio_resp_m_understory_si_scls => this%hvars(ih_resp_m_understory_si_scls)%r82d, & + hio_gpp_si_age => this%hvars(ih_gpp_si_age)%r82d, & + hio_npp_si_age => this%hvars(ih_npp_si_age)%r82d, & + hio_c_stomata_si_age => this%hvars(ih_c_stomata_si_age)%r82d, & + hio_c_lblayer_si_age => this%hvars(ih_c_lblayer_si_age)%r82d, & + hio_parsun_z_si_cnlf => this%hvars(ih_parsun_z_si_cnlf)%r82d, & + hio_parsha_z_si_cnlf => this%hvars(ih_parsha_z_si_cnlf)%r82d, & + hio_ts_net_uptake_si_cnlf => this%hvars(ih_ts_net_uptake_si_cnlf)%r82d, & + hio_parsun_z_si_cnlfpft => this%hvars(ih_parsun_z_si_cnlfpft)%r82d, & + hio_parsha_z_si_cnlfpft => this%hvars(ih_parsha_z_si_cnlfpft)%r82d, & + hio_laisun_z_si_cnlf => this%hvars(ih_laisun_z_si_cnlf)%r82d, & + hio_laisha_z_si_cnlf => this%hvars(ih_laisha_z_si_cnlf)%r82d, & + hio_laisun_clllpf => this%hvars(ih_laisun_clllpf)%r82d, & + hio_laisha_clllpf => this%hvars(ih_laisha_clllpf)%r82d, & + hio_crownfrac_clllpf => this%hvars(ih_crownfrac_clllpf)%r82d, & + hio_laisun_top_si_can => this%hvars(ih_laisun_top_si_can)%r82d, & + hio_laisha_top_si_can => this%hvars(ih_laisha_top_si_can)%r82d, & + hio_fabd_sun_si_cnlfpft => this%hvars(ih_fabd_sun_si_cnlfpft)%r82d, & + hio_fabd_sha_si_cnlfpft => this%hvars(ih_fabd_sha_si_cnlfpft)%r82d, & + hio_fabi_sun_si_cnlfpft => this%hvars(ih_fabi_sun_si_cnlfpft)%r82d, & + hio_fabi_sha_si_cnlfpft => this%hvars(ih_fabi_sha_si_cnlfpft)%r82d, & + hio_fabd_sun_si_cnlf => this%hvars(ih_fabd_sun_si_cnlf)%r82d, & + hio_fabd_sha_si_cnlf => this%hvars(ih_fabd_sha_si_cnlf)%r82d, & + hio_fabi_sun_si_cnlf => this%hvars(ih_fabi_sun_si_cnlf)%r82d, & + hio_fabi_sha_si_cnlf => this%hvars(ih_fabi_sha_si_cnlf)%r82d, & + hio_parprof_dir_si_cnlf => this%hvars(ih_parprof_dir_si_cnlf)%r82d, & + hio_parprof_dif_si_cnlf => this%hvars(ih_parprof_dif_si_cnlf)%r82d, & + hio_parprof_dir_si_cnlfpft => this%hvars(ih_parprof_dir_si_cnlfpft)%r82d, & + hio_parprof_dif_si_cnlfpft => this%hvars(ih_parprof_dif_si_cnlfpft)%r82d, & + hio_fabd_sun_top_si_can => this%hvars(ih_fabd_sun_top_si_can)%r82d, & + hio_fabd_sha_top_si_can => this%hvars(ih_fabd_sha_top_si_can)%r82d, & + hio_fabi_sun_top_si_can => this%hvars(ih_fabi_sun_top_si_can)%r82d, & + hio_fabi_sha_top_si_can => this%hvars(ih_fabi_sha_top_si_can)%r82d, & + hio_parsun_top_si_can => this%hvars(ih_parsun_top_si_can)%r82d, & + hio_parsha_top_si_can => this%hvars(ih_parsha_top_si_can)%r82d ) + ! Flush the relevant history variables - call this%flush_hvars(nc,upfreq_in=2) - - per_dt_tstep = 1.0_r8/dt_tstep - - do s = 1,nsites + call this%flush_hvars(nc,upfreq_in=upfreq_hifr_multi) + + dt_tstep_inv = 1.0_r8/dt_tstep + + do_sites: do s = 1,nsites + + site_area_veg_inv = 0._r8 + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + site_area_veg_inv = site_area_veg_inv + cpatch%total_canopy_area + cpatch => cpatch%younger + end do !patch loop + site_area_veg_inv = 1._r8/site_area_veg_inv - call this%zero_site_hvars(sites(s), upfreq_in=2) + ! If there is no vegetation, go to the next site + if(site_area_veg_inv < nearzero) cycle do_sites io_si = sites(s)%h_gid - hio_nep_si(io_si) = -bc_in(s)%tot_het_resp * kg_per_g - hio_hr_si(io_si) = bc_in(s)%tot_het_resp * kg_per_g - ipa = 0 patch_area_by_age(1:nlevage) = 0._r8 canopy_area_by_age(1:nlevage) = 0._r8 - elai_tot = 0._r8 + call this%zero_site_hvars(sites(s), upfreq_in=upfreq_hifr_multi) - ! Calculate the site-level total vegetated area (i.e. non-bareground) - site_area_veg = area - if (hlm_use_nocomp .eq. itrue .and. hlm_use_fixed_biogeog .eq. itrue) then - site_area_veg = area - sites(s)%area_pft(0) - end if - cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - - hio_fsun_si = hio_fsun_si + bc_out(s)%laisun_pa(ipa)*cpatch%area - elai_tot = elai_tot + (bc_out(s)%laisun_pa(ipa)+bc_out(s)%laisha_pa(ipa))*cpatch%area + ipa = ipa + 1 patch_area_by_age(cpatch%age_class) = & patch_area_by_age(cpatch%age_class) + cpatch%area @@ -4495,6 +4671,8 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) canopy_area_by_age(cpatch%age_class) = & canopy_area_by_age(cpatch%age_class) + cpatch%total_canopy_area + + ! Canopy resitance terms hio_c_stomata_si_age(io_si,cpatch%age_class) = & hio_c_stomata_si_age(io_si,cpatch%age_class) + & @@ -4504,24 +4682,8 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) hio_c_lblayer_si_age(io_si,cpatch%age_class) + & cpatch%c_lblayer * cpatch%total_canopy_area * mol_per_umol - hio_c_stomata_si(io_si) = hio_c_stomata_si(io_si) + & - cpatch%c_stomata * cpatch%total_canopy_area * mol_per_umol - - hio_c_lblayer_si(io_si) = hio_c_lblayer_si(io_si) + & - cpatch%c_lblayer * cpatch%total_canopy_area * mol_per_umol - - hio_rad_error_si(io_si) = hio_rad_error_si(io_si) + & - cpatch%radiation_error * cpatch%area * AREA_INV - - ! Only accumulate the instantaneous vegetation temperature for vegetated patches - if (cpatch%patchno .ne. 0) then - hio_tveg(io_si) = hio_tveg(io_si) + & - (bc_in(s)%t_veg_pa(cpatch%patchno) - t_water_freeze_k_1atm) * & - cpatch%area / site_area_veg - end if - - ccohort => cpatch%shortest - do while(associated(ccohort)) + ccohort => cpatch%shortest + do while(associated(ccohort)) n_perm2 = ccohort%n * AREA_INV @@ -4535,63 +4697,17 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) associate( scpf => ccohort%size_by_pft_class, & scls => ccohort%size_class ) - ! scale up cohort fluxes to the site level - hio_npp_si(io_si) = hio_npp_si(io_si) + & - npp * n_perm2 * per_dt_tstep - - hio_gpp_si(io_si) = hio_gpp_si(io_si) + & - ccohort%gpp_tstep * n_perm2 * per_dt_tstep - - hio_aresp_si(io_si) = hio_aresp_si(io_si) + & - aresp * n_perm2 * per_dt_tstep - hio_growth_resp_si(io_si) = hio_growth_resp_si(io_si) + & - resp_g * n_perm2 * per_dt_tstep - hio_maint_resp_si(io_si) = hio_maint_resp_si(io_si) + & - ccohort%resp_m * n_perm2 * per_dt_tstep - - hio_maint_resp_unreduced_si(io_si) = hio_maint_resp_unreduced_si(io_si) + & - ccohort%resp_m_unreduced * n_perm2 * per_dt_tstep - - ! Secondary forest only - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then - hio_npp_secondary_si(io_si) = hio_npp_secondary_si(io_si) + & - npp * n_perm2 * per_dt_tstep - hio_gpp_secondary_si(io_si) = hio_gpp_secondary_si(io_si) + & - ccohort%gpp_tstep * n_perm2 * per_dt_tstep - hio_aresp_secondary_si(io_si) = hio_aresp_secondary_si(io_si) + & - aresp * n_perm2 * per_dt_tstep - hio_growth_resp_secondary_si(io_si) = hio_growth_resp_secondary_si(io_si) + & - resp_g * n_perm2 * per_dt_tstep - hio_maint_resp_secondary_si(io_si) = hio_maint_resp_secondary_si(io_si) + & - ccohort%resp_m * n_perm2 * per_dt_tstep - end if - - ! Add up the total Net Ecosystem Production - ! for this timestep. [kgC/m2/s] - hio_nep_si(io_si) = hio_nep_si(io_si) + & - npp * n_perm2 * per_dt_tstep - - ! aggregate MR fluxes to the site level - hio_leaf_mr_si(io_si) = hio_leaf_mr_si(io_si) + ccohort%rdark & - * n_perm2 - hio_froot_mr_si(io_si) = hio_froot_mr_si(io_si) + ccohort%froot_mr & - * n_perm2 - hio_livecroot_mr_si(io_si) = hio_livecroot_mr_si(io_si) + ccohort%livecroot_mr & - * n_perm2 - hio_livestem_mr_si(io_si) = hio_livestem_mr_si(io_si) + ccohort%livestem_mr & - * n_perm2 - ! Total AR (kgC/m2/s) = (kgC/plant/step) / (s/step) * (plant/m2) hio_ar_si_scpf(io_si,scpf) = hio_ar_si_scpf(io_si,scpf) + & - (ccohort%resp_tstep*per_dt_tstep) * n_perm2 + (ccohort%resp_tstep*dt_tstep_inv) * n_perm2 ! Growth AR (kgC/m2/s) hio_ar_grow_si_scpf(io_si,scpf) = hio_ar_grow_si_scpf(io_si,scpf) + & - (resp_g*per_dt_tstep) * n_perm2 + (resp_g*dt_tstep_inv) * n_perm2 ! Maint AR (kgC/m2/s) hio_ar_maint_si_scpf(io_si,scpf) = hio_ar_maint_si_scpf(io_si,scpf) + & - (ccohort%resp_m*per_dt_tstep) * n_perm2 + (ccohort%resp_m*dt_tstep_inv) * n_perm2 ! Maintenance AR partition variables are stored as rates (kgC/plant/s) ! (kgC/m2/s) = (kgC/plant/s) * (plant/m2) @@ -4610,24 +4726,16 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) hio_ar_frootm_si_scpf(io_si,scpf) = hio_ar_frootm_si_scpf(io_si,scpf) + & ccohort%froot_mr * n_perm2 - ! accumulate fluxes per patch age bin hio_gpp_si_age(io_si,cpatch%age_class) = hio_gpp_si_age(io_si,cpatch%age_class) & - + ccohort%gpp_tstep * ccohort%n * per_dt_tstep + + ccohort%gpp_tstep * ccohort%n * dt_tstep_inv + hio_npp_si_age(io_si,cpatch%age_class) = hio_npp_si_age(io_si,cpatch%age_class) & - + npp * ccohort%n * per_dt_tstep + + npp * ccohort%n * dt_tstep_inv ! accumulate fluxes on canopy- and understory- separated fluxes if (ccohort%canopy_layer .eq. 1) then - ! - ! bulk fluxes are in gC / m2 / s - hio_gpp_canopy_si(io_si) = hio_gpp_canopy_si(io_si) + & - ccohort%gpp_tstep * n_perm2 * per_dt_tstep - - hio_ar_canopy_si(io_si) = hio_ar_canopy_si(io_si) + & - aresp * n_perm2 * per_dt_tstep - ! ! size-resolved respiration fluxes are in kg C / m2 / s hio_rdark_canopy_si_scls(io_si,scls) = hio_rdark_canopy_si_scls(io_si,scls) + & ccohort%rdark * ccohort%n * ha_per_m2 @@ -4637,22 +4745,12 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) ccohort%livecroot_mr * ccohort%n * ha_per_m2 hio_froot_mr_canopy_si_scls(io_si,scls) = hio_froot_mr_canopy_si_scls(io_si,scls) + & ccohort%froot_mr * ccohort%n * ha_per_m2 - hio_resp_g_canopy_si_scls(io_si,scls) = hio_resp_g_canopy_si_scls(io_si,scls) + & - resp_g * ccohort%n * per_dt_tstep * ha_per_m2 + resp_g * ccohort%n * dt_tstep_inv * ha_per_m2 hio_resp_m_canopy_si_scls(io_si,scls) = hio_resp_m_canopy_si_scls(io_si,scls) + & - ccohort%resp_m * ccohort%n * per_dt_tstep * ha_per_m2 + ccohort%resp_m * ccohort%n * dt_tstep_inv * ha_per_m2 else - ! - ! bulk fluxes are in gC / m2 / s - hio_gpp_understory_si(io_si) = hio_gpp_understory_si(io_si) + & - ccohort%gpp_tstep * n_perm2 * per_dt_tstep - - hio_ar_understory_si(io_si) = hio_ar_understory_si(io_si) + & - aresp * n_perm2 * per_dt_tstep - - ! ! size-resolved respiration fluxes are in kg C / m2 / s hio_rdark_understory_si_scls(io_si,scls) = hio_rdark_understory_si_scls(io_si,scls) + & ccohort%rdark * ccohort%n * ha_per_m2 @@ -4663,9 +4761,9 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) hio_froot_mr_understory_si_scls(io_si,scls) = hio_froot_mr_understory_si_scls(io_si,scls) + & ccohort%froot_mr * ccohort%n * ha_per_m2 hio_resp_g_understory_si_scls(io_si,scls) = hio_resp_g_understory_si_scls(io_si,scls) + & - resp_g * ccohort%n * per_dt_tstep * ha_per_m2 + resp_g * ccohort%n * dt_tstep_inv * ha_per_m2 hio_resp_m_understory_si_scls(io_si,scls) = hio_resp_m_understory_si_scls(io_si,scls) + & - ccohort%resp_m * ccohort%n * per_dt_tstep * ha_per_m2 + ccohort%resp_m * ccohort%n * dt_tstep_inv * ha_per_m2 endif end associate endif @@ -4675,114 +4773,135 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) do ileaf=1,ccohort%nv cnlf_indx = ileaf + (ican-1) * nlevleaf hio_ts_net_uptake_si_cnlf(io_si, cnlf_indx) = hio_ts_net_uptake_si_cnlf(io_si, cnlf_indx) + & - ccohort%ts_net_uptake(ileaf) * per_dt_tstep * ccohort%c_area * area_inv + ccohort%ts_net_uptake(ileaf) * dt_tstep_inv * ccohort%c_area * area_inv end do ccohort => ccohort%taller enddo ! cohort loop ! summarize radiation profiles through the canopy - do ipft=1,numpft - do ican=1,cpatch%ncl_p - do ileaf=1,cpatch%ncan(ican,ipft) - ! calculate where we are on multiplexed dimensions - cnlfpft_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax - cnlf_indx = ileaf + (ican-1) * nlevleaf - ! - ! first do all the canopy x leaf x pft calculations - hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - ! - hio_laisun_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_laisun_z_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_laisha_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_laisha_z_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - ! - hio_fabd_sun_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabd_sun_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_fabd_sha_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabd_sha_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_fabi_sun_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabi_sun_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_fabi_sha_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabi_sha_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - ! - hio_parprof_dir_si_cnlfpft(io_si,cnlfpft_indx) = hio_parprof_dir_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%parprof_pft_dir_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_parprof_dif_si_cnlfpft(io_si,cnlfpft_indx) = hio_parprof_dif_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%parprof_pft_dif_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - ! - ! summarize across all PFTs - hio_parsun_z_si_cnlf(io_si,cnlf_indx) = hio_parsun_z_si_cnlf(io_si,cnlf_indx) + & - cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_parsha_z_si_cnlf(io_si,cnlf_indx) = hio_parsha_z_si_cnlf(io_si,cnlf_indx) + & - cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + + if_zenith: if(cpatch%solar_zenith_flag) then + do_pft: do ipft=1,numpft + do_canlev: do ican=1,cpatch%ncl_p + do_leaflev: do ileaf=1,cpatch%ncan(ican,ipft) + ! calculate where we are on multiplexed dimensions + cnlfpft_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax + cnlf_indx = ileaf + (ican-1) * nlevleaf + + ! first do all the canopy x leaf x pft calculations + hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%total_canopy_area * site_area_veg_inv + + hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%total_canopy_area * site_area_veg_inv + ! + hio_laisun_clllpf(io_si,cnlfpft_indx) = hio_laisun_clllpf(io_si,cnlfpft_indx) + & + cpatch%elai_profile(ican,ipft,ileaf)*cpatch%f_sun(ican,ipft,ileaf)*cpatch%area * AREA_INV + + hio_laisha_clllpf(io_si,cnlfpft_indx) = hio_laisha_clllpf(io_si,cnlfpft_indx) + & + cpatch%elai_profile(ican,ipft,ileaf)*(1._r8-cpatch%f_sun(ican,ipft,ileaf))*cpatch%area * AREA_INV + + hio_parprof_dir_si_cnlfpft(io_si,cnlfpft_indx) = hio_parprof_dir_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%parprof_pft_dir_z(ican,ipft,ileaf) * cpatch%total_canopy_area * site_area_veg_inv + + hio_parprof_dif_si_cnlfpft(io_si,cnlfpft_indx) = hio_parprof_dif_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%parprof_pft_dif_z(ican,ipft,ileaf) * cpatch%total_canopy_area * site_area_veg_inv + + ! The fractional area of Canopy layer and PFTs can be used + ! do upscale the CLLLPF properties + hio_crownfrac_clllpf(io_si,cnlfpft_indx) = hio_crownfrac_clllpf(io_si,cnlfpft_indx) + & + cpatch%canopy_area_profile(ican,ipft,ileaf) * cpatch%total_canopy_area * site_area_veg_inv + + ! summarize across all PFTs + ! ---------------------------------------------------------------------------- + hio_parprof_dir_si_cnlf(io_si,cnlf_indx) = hio_parprof_dir_si_cnlf(io_si,cnlf_indx) + & + cpatch%parprof_pft_dir_z(ican,ipft,ileaf) * cpatch%canopy_area_profile(ican,ipft,ileaf) * & + cpatch%total_canopy_area * site_area_veg_inv + + hio_parprof_dif_si_cnlf(io_si,cnlf_indx) = hio_parprof_dif_si_cnlf(io_si,cnlf_indx) + & + cpatch%parprof_pft_dif_z(ican,ipft,ileaf) * cpatch%canopy_area_profile(ican,ipft,ileaf) * & + cpatch%total_canopy_area * site_area_veg_inv + + hio_parsun_z_si_cnlf(io_si,cnlf_indx) = hio_parsun_z_si_cnlf(io_si,cnlf_indx) + & + cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%canopy_area_profile(ican,ipft,ileaf) * & + cpatch%total_canopy_area * site_area_veg_inv + + hio_parsha_z_si_cnlf(io_si,cnlf_indx) = hio_parsha_z_si_cnlf(io_si,cnlf_indx) + & + cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%canopy_area_profile(ican,ipft,ileaf) * & + cpatch%total_canopy_area * site_area_veg_inv + + hio_laisun_z_si_cnlf(io_si,cnlf_indx) = hio_laisun_z_si_cnlf(io_si,cnlf_indx) + & + cpatch%f_sun(ican,ipft,ileaf)*cpatch%elai_profile(ican,ipft,ileaf) * cpatch%area * AREA_INV + + hio_laisha_z_si_cnlf(io_si,cnlf_indx) = hio_laisha_z_si_cnlf(io_si,cnlf_indx) + & + (1._r8-cpatch%f_sun(ican,ipft,ileaf))*cpatch%elai_profile(ican,ipft,ileaf) * cpatch%area * AREA_INV + + hio_fabd_sun_si_cnlf(io_si,cnlf_indx) = hio_fabd_sun_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabd_sha_si_cnlf(io_si,cnlf_indx) = hio_fabd_sha_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabi_sun_si_cnlf(io_si,cnlf_indx) = hio_fabi_sun_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabi_sha_si_cnlf(io_si,cnlf_indx) = hio_fabi_sha_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + + end do do_leaflev ! - hio_laisun_z_si_cnlf(io_si,cnlf_indx) = hio_laisun_z_si_cnlf(io_si,cnlf_indx) + & - cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_laisha_z_si_cnlf(io_si,cnlf_indx) = hio_laisha_z_si_cnlf(io_si,cnlf_indx) + & - cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + ! summarize just the top leaf level across all PFTs, for each canopy level + hio_parsun_top_si_can(io_si,ican) = hio_parsun_top_si_can(io_si,ican) + & + cpatch%ed_parsun_z(ican,ipft,1) * cpatch%total_canopy_area * site_area_veg_inv + hio_parsha_top_si_can(io_si,ican) = hio_parsha_top_si_can(io_si,ican) + & + cpatch%ed_parsha_z(ican,ipft,1) * cpatch%total_canopy_area * site_area_veg_inv + + hio_laisun_top_si_can(io_si,ican) = hio_laisun_top_si_can(io_si,ican) + & + cpatch%f_sun(ican,ipft,1)*cpatch%elai_profile(ican,ipft,1) * cpatch%area * AREA_INV + hio_laisha_top_si_can(io_si,ican) = hio_laisha_top_si_can(io_si,ican) + & + (1._r8-cpatch%f_sun(ican,ipft,1))*cpatch%elai_profile(ican,ipft,1) * cpatch%area * AREA_INV + + hio_fabd_sun_top_si_can(io_si,ican) = hio_fabd_sun_top_si_can(io_si,ican) + & + cpatch%fabd_sun_z(ican,ipft,1) * cpatch%area * AREA_INV + hio_fabd_sha_top_si_can(io_si,ican) = hio_fabd_sha_top_si_can(io_si,ican) + & + cpatch%fabd_sha_z(ican,ipft,1) * cpatch%area * AREA_INV + hio_fabi_sun_top_si_can(io_si,ican) = hio_fabi_sun_top_si_can(io_si,ican) + & + cpatch%fabi_sun_z(ican,ipft,1) * cpatch%area * AREA_INV + hio_fabi_sha_top_si_can(io_si,ican) = hio_fabi_sha_top_si_can(io_si,ican) + & + cpatch%fabi_sha_z(ican,ipft,1) * cpatch%area * AREA_INV ! - hio_fabd_sun_si_cnlf(io_si,cnlf_indx) = hio_fabd_sun_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_fabd_sha_si_cnlf(io_si,cnlf_indx) = hio_fabd_sha_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_fabi_sun_si_cnlf(io_si,cnlf_indx) = hio_fabi_sun_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_fabi_sha_si_cnlf(io_si,cnlf_indx) = hio_fabi_sha_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + end do do_canlev + end do do_pft + end if if_zenith + + cpatch => cpatch%younger + end do !patch loop - end do - ! - ! summarize just the top leaf level across all PFTs, for each canopy level - hio_parsun_top_si_can(io_si,ican) = hio_parsun_top_si_can(io_si,ican) + & - cpatch%ed_parsun_z(ican,ipft,1) * cpatch%area * AREA_INV - hio_parsha_top_si_can(io_si,ican) = hio_parsha_top_si_can(io_si,ican) + & - cpatch%ed_parsha_z(ican,ipft,1) * cpatch%area * AREA_INV - ! - hio_laisun_top_si_can(io_si,ican) = hio_laisun_top_si_can(io_si,ican) + & - cpatch%ed_laisun_z(ican,ipft,1) * cpatch%area * AREA_INV - hio_laisha_top_si_can(io_si,ican) = hio_laisha_top_si_can(io_si,ican) + & - cpatch%ed_laisha_z(ican,ipft,1) * cpatch%area * AREA_INV - ! - hio_fabd_sun_top_si_can(io_si,ican) = hio_fabd_sun_top_si_can(io_si,ican) + & - cpatch%fabd_sun_z(ican,ipft,1) * cpatch%area * AREA_INV - hio_fabd_sha_top_si_can(io_si,ican) = hio_fabd_sha_top_si_can(io_si,ican) + & - cpatch%fabd_sha_z(ican,ipft,1) * cpatch%area * AREA_INV - hio_fabi_sun_top_si_can(io_si,ican) = hio_fabi_sun_top_si_can(io_si,ican) + & - cpatch%fabi_sun_z(ican,ipft,1) * cpatch%area * AREA_INV - hio_fabi_sha_top_si_can(io_si,ican) = hio_fabi_sha_top_si_can(io_si,ican) + & - cpatch%fabi_sha_z(ican,ipft,1) * cpatch%area * AREA_INV - ! + ! Set values that are not represented by canopy to ignore + do ican = 1,nclmax + do ipft = 1,numpft + do ileaf = 1,nlevleaf + cnlfpft_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax + if( hio_crownfrac_clllpf(io_si,cnlfpft_indx) cpatch%younger - end do !patch loop - - if(elai_totFATES ! control parameter passing to ensure all active dimension types received all ! dimensioning specifications from the host, but we currently arent using those diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index e6aedc08f7..9a36cc4509 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -120,7 +120,10 @@ module FatesInterfaceTypesMod ! harvest_rates in dynHarvestMod ! bc_in%hlm_harvest_rates and bc_in%hlm_harvest_catnames - + ! Switch indicating if high-frequency multi-dimensional history output should be + ! used in this run + logical, public, parameter :: hio_include_hifr_multi = .true. + integer, public :: hlm_sf_nofire_def ! Definition of a no-fire case for hlm_spitfire_mode integer, public :: hlm_sf_scalar_lightning_def ! Definition of a scalar-lightning case for hlm_spitfire_mode integer, public :: hlm_sf_successful_ignitions_def ! Definition of a successful-ignition dataset case for hlm_spitfire_mode @@ -245,7 +248,7 @@ module FatesInterfaceTypesMod integer , public, allocatable :: fates_hdim_levfuel(:) ! fire fuel size class (fsc) dimension integer , public, allocatable :: fates_hdim_levcwdsc(:) ! cwd class dimension integer , public, allocatable :: fates_hdim_levcan(:) ! canopy-layer dimension - integer , public, allocatable :: fates_hdim_levleaf(:) ! leaf-layer dimension + real(r8), public, allocatable :: fates_hdim_levleaf(:) ! leaf-layer dimension, integrated VAI [m2/m2] integer , public, allocatable :: fates_hdim_levelem(:) ! element dimension integer , public, allocatable :: fates_hdim_canmap_levcnlf(:) ! canopy-layer map into the canopy-layer x leaf-layer dim integer , public, allocatable :: fates_hdim_lfmap_levcnlf(:) ! leaf-layer map into the can-layer x leaf-layer dimension diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index a0304f2935..8300c2a322 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -94,7 +94,7 @@ module FatesInventoryInitMod ! defined in model memory and a physical ! site listed in the file - logical, parameter :: do_inventory_out = .false. + logical, parameter :: do_inventory_out = .true. public :: initialize_sites_by_inventory @@ -1021,6 +1021,8 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & temp_cohort%dbh = c_dbh temp_cohort%crowndamage = 1 ! assume undamaged + + call h_allom(c_dbh,temp_cohort%pft,temp_cohort%hite) temp_cohort%canopy_trim = 1.0_r8 diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 7125bb0a69..e8a67548c5 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -47,7 +47,8 @@ module FatesRestartInterfaceMod use PRTGenericMod, only : num_elements use FatesRunningMeanMod, only : rmean_type use FatesRunningMeanMod, only : ema_lpa - use FatesRadiationMemMod, only : num_swb + use FatesRadiationMemMod, only : num_swb,rad_solver,norman_solver + use TwoStreamMLPEMod, only : normalized_upper_boundary ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg @@ -3439,8 +3440,6 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) ! zero diagnostic radiation profiles currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 ! ----------------------------------------------------------- ! When calling norman radiation from the short-timestep @@ -3475,15 +3474,46 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) enddo else - call PatchNormanRadiation (currentPatch, & - bc_out(s)%albd_parb(ifp,:), & - bc_out(s)%albi_parb(ifp,:), & - bc_out(s)%fabd_parb(ifp,:), & - bc_out(s)%fabi_parb(ifp,:), & - bc_out(s)%ftdd_parb(ifp,:), & - bc_out(s)%ftid_parb(ifp,:), & - bc_out(s)%ftii_parb(ifp,:)) - + if_solver: if(rad_solver.eq.norman_solver) then + + call PatchNormanRadiation (currentPatch, & + bc_out(s)%albd_parb(ifp,:), & + bc_out(s)%albi_parb(ifp,:), & + bc_out(s)%fabd_parb(ifp,:), & + bc_out(s)%fabi_parb(ifp,:), & + bc_out(s)%ftdd_parb(ifp,:), & + bc_out(s)%ftid_parb(ifp,:), & + bc_out(s)%ftii_parb(ifp,:)) + + + else + associate( twostr => currentPatch%twostr) + + call twostr%CanopyPrep(currentPatch%fcansno) + call twostr%ZenithPrep(currentPatch%solar_zenith_angle) + + do ib = 1,hlm_numSWb + + twostr%band(ib)%albedo_grnd_diff = currentPatch%gnd_alb_dif(ib) + twostr%band(ib)%albedo_grnd_beam = currentPatch%gnd_alb_dir(ib) + + call twostr%Solve(ib, & ! in + normalized_upper_boundary, & ! in + 1.0_r8,1.0_r8, & ! in + bc_out(s)%albd_parb(ifp,ib), & ! out + bc_out(s)%albi_parb(ifp,ib), & ! out + bc_out(s)%fabd_parb(ifp,ib), & ! out + bc_out(s)%fabi_parb(ifp,ib), & ! out + bc_out(s)%ftdd_parb(ifp,ib), & ! out + bc_out(s)%ftid_parb(ifp,ib), & ! out + bc_out(s)%ftii_parb(ifp,ib)) + + end do + + end associate + + end if if_solver + endif ! is there vegetation? end if ! if the vegetation and zenith filter is active diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index 56f760302b..963742af16 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -16,11 +16,13 @@ module FatesRadiationDriveMod use FatesConstantsMod , only : itrue use FatesConstantsMod , only : pi_const use FatesConstantsMod , only : nocomp_bareground + use FatesConstantsMod , only : nearzero use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : bc_out_type use FatesInterfaceTypesMod , only : hlm_numSWb use FatesInterfaceTypesMod , only : numpft use EDTypesMod , only : nclmax + use EDTypesMod , only : dinc_vai,dlower_vai use EDTypesMod , only : nlevleaf use EDCanopyStructureMod, only: calc_areaindex use FatesGlobals , only : fates_log @@ -35,6 +37,7 @@ module FatesRadiationDriveMod use TwoStreamMLPEMod, only : normalized_upper_boundary use FatesTwoStreamInterfaceMod, only : FatesPatchFSun use FatesTwoStreamInterfaceMod, only : CheckPatchRadiationBalance + use FatesInterfaceTypesMod , only : hlm_hio_ignore_val ! CIME globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -45,7 +48,7 @@ module FatesRadiationDriveMod public :: FatesNormalizedCanopyRadiation ! Surface albedo and two-stream fluxes public :: PatchNormanRadiation public :: FatesSunShadeFracs - + logical :: debug = .false. ! for debugging this module character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -123,8 +126,6 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) ! zero diagnostic radiation profiles currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 currentPatch%solar_zenith_flag = bc_in(s)%filter_vegzen_pa(ifp) currentPatch%solar_zenith_angle = bc_in(s)%coszen_pa(ifp) @@ -965,17 +966,10 @@ subroutine PatchNormanRadiation (currentPatch, & do iv = 1, currentPatch%nrad(L,ft) currentPatch%nrmlzd_parprof_pft_dir_z(radtype,L,ft,iv) = & forc_dir(radtype) * tr_dir_z(L,ft,iv) + currentPatch%nrmlzd_parprof_pft_dif_z(radtype,L,ft,iv) = & Dif_dn(L,ft,iv) + Dif_up(L,ft,iv) - ! - currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) = & - currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) + & - (forc_dir(radtype) * tr_dir_z(L,ft,iv)) * & - (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) - currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) = & - currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) + & - (Dif_dn(L,ft,iv) + Dif_up(L,ft,iv)) * & - (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) + end do end if ! ib = visible end if ! present @@ -1146,14 +1140,13 @@ subroutine PatchNormanRadiation (currentPatch, & enddo ! rad-type - end associate return end subroutine PatchNormanRadiation ! ====================================================================================== -subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) +subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out,cold_init) implicit none @@ -1162,8 +1155,8 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) type(ed_site_type),intent(inout),target :: sites(nsites) type(bc_in_type),intent(in) :: bc_in(nsites) type(bc_out_type),intent(inout) :: bc_out(nsites) - - + logical,intent(in) :: cold_init ! If true, then we have not run the solver yet + ! locals type (ed_patch_type),pointer :: cpatch ! c"urrent" patch real(r8) :: sunlai @@ -1174,40 +1167,57 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) integer :: iv,ib integer :: s integer :: ifp - - + integer :: nv + integer :: icol + ! Fraction of the canopy area associated with each pft and layer + ! (used for weighting diagnostics) + real(r8) :: area_vlpfcl(nlevleaf,maxpft,nclmax) + real(r8) :: vai_top,vai_bot + real(r8) :: area_frac + real(r8) :: Rb_abs,Rd_abs,Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow,leaf_sun_frac + real(r8) :: vai + do s = 1,nsites ifp = 0 cpatch => sites(s)%oldest_patch do while (associated(cpatch)) - if_notbareground:if(cpatch%nocomp_pft_label.ne.nocomp_bareground)then !only for veg patches + + if_notbareground:if(cpatch%nocomp_pft_label.ne.nocomp_bareground)then !only for veg patches ! do not do albedo calculations for bare ground patch in SP mode ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein ! ifp=1 is the first vegetated patch. ifp=ifp+1 - if( debug ) write(fates_log(),*) 'edsurfRad_5600',ifp,s,cpatch%NCL_p,numpft - ! zero out various datas + ! If there is no sun out, we have a trivial solution + if_zenithflag: if( .not.cpatch%solar_zenith_flag ) then + + cpatch%ed_parsun_z(1:cpatch%ncl_p,1:numpft,:) = 0._r8 + cpatch%ed_parsha_z(1:cpatch%ncl_p,1:numpft,:) = 0._r8 + cpatch%parprof_pft_dir_z(1:cpatch%ncl_p,1:numpft,:) = hlm_hio_ignore_val + cpatch%parprof_pft_dif_z(1:cpatch%ncl_p,1:numpft,:) = hlm_hio_ignore_val + + !cpatch%f_sun(1:cpatch%ncl_p,1:numpft,:) = hlm_hio_ignore_val + + bc_out(s)%fsun_pa(ifp) = 0._r8 + bc_out(s)%laisun_pa(ifp) = 0._r8 + bc_out(s)%laisha_pa(ifp) = calc_areaindex(cpatch,'elai') + + else + + ! zero out arrays cpatch%ed_parsun_z(:,:,:) = 0._r8 cpatch%ed_parsha_z(:,:,:) = 0._r8 - cpatch%ed_laisun_z(:,:,:) = 0._r8 - cpatch%ed_laisha_z(:,:,:) = 0._r8 - bc_out(s)%fsun_pa(ifp) = 0._r8 - sunlai = 0._r8 shalai = 0._r8 - cpatch%parprof_pft_dir_z(:,:,:) = 0._r8 cpatch%parprof_pft_dif_z(:,:,:) = 0._r8 - cpatch%parprof_dir_z(:,:) = 0._r8 - cpatch%parprof_dif_z(:,:) = 0._r8 if_norm_twostr: if (rad_solver.eq.norman_solver) then - + ! Loop over patches to calculate laisun_z and laisha_z for each layer. ! Derive canopy laisun, laisha, and fsun from layer sums. ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from @@ -1218,31 +1228,15 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) do CL = 1, cpatch%NCL_p do FT = 1,numpft - if( debug ) write(fates_log(),*) 'edsurfRad_5601',CL,FT,cpatch%nrad(CL,ft) - - do iv = 1, cpatch%nrad(CL,ft) !NORMAL CASE. - - ! FIX(SPM,040114) - existing comment - ! ** Should this be elai or tlai? Surely we only do radiation for elai? - - cpatch%ed_laisun_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & - cpatch%f_sun(CL,ft,iv) - - if ( debug ) write(fates_log(),*) 'edsurfRad 570 ',cpatch%elai_profile(CL,ft,iv) - if ( debug ) write(fates_log(),*) 'edsurfRad 571 ',cpatch%f_sun(CL,ft,iv) - - cpatch%ed_laisha_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & - (1._r8 - cpatch%f_sun(CL,ft,iv)) - - end do - !needed for the VOC emissions, etc. - sunlai = sunlai + sum(cpatch%ed_laisun_z(CL,ft,1:cpatch%nrad(CL,ft))) - shalai = shalai + sum(cpatch%ed_laisha_z(CL,ft,1:cpatch%nrad(CL,ft))) + sunlai = sunlai + sum(cpatch%elai_profile(CL,ft,1:cpatch%nrad(CL,ft))*cpatch%f_sun(CL,ft,1:cpatch%nrad(CL,ft))) + shalai = shalai + sum(cpatch%elai_profile(CL,ft,1:cpatch%nrad(CL,ft))) end do end do + shalai = shalai-sunlai + if(sunlai+shalai > 0._r8)then bc_out(s)%fsun_pa(ifp) = sunlai / (sunlai+shalai) else @@ -1274,14 +1268,6 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) do iv = 1, cpatch%nrad(CL,ft) - if ( debug ) then - write(fates_log(),*) 'edsurfRad 653 ', cpatch%ed_parsun_z(CL,ft,iv) - write(fates_log(),*) 'edsurfRad 654 ', bc_in(s)%solad_parb(ifp,ipar) - write(fates_log(),*) 'edsurfRad 655 ', bc_in(s)%solai_parb(ifp,ipar) - write(fates_log(),*) 'edsurfRad 656 ', cpatch%fabd_sun_z(CL,ft,iv) - write(fates_log(),*) 'edsurfRad 657 ', cpatch%fabi_sun_z(CL,ft,iv) - endif - cpatch%ed_parsun_z(CL,ft,iv) = & bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(CL,ft,iv) + & bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(CL,ft,iv) @@ -1310,28 +1296,17 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) cpatch%nrmlzd_parprof_pft_dir_z(idirect,CL,FT,iv)) + & (bc_in(s)%solai_parb(ifp,ipar) * & cpatch%nrmlzd_parprof_pft_dir_z(idiffuse,CL,FT,iv)) + cpatch%parprof_pft_dif_z(CL,FT,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & cpatch%nrmlzd_parprof_pft_dif_z(idirect,CL,FT,iv)) + & (bc_in(s)%solai_parb(ifp,ipar) * & cpatch%nrmlzd_parprof_pft_dif_z(idiffuse,CL,FT,iv)) + end do ! iv end do ! FT end do ! CL - do CL = 1, cpatch%NCL_p - do iv = 1, maxval(cpatch%nrad(CL,:)) - cpatch%parprof_dir_z(CL,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dir_z(idirect,CL,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dir_z(idiffuse,CL,iv)) - cpatch%parprof_dif_z(CL,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dif_z(idirect,CL,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dif_z(idiffuse,CL,iv)) - end do ! iv - end do ! CL - - else + else ! Two-stream ! ----------------------------------------------------------- @@ -1339,27 +1314,77 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) cpatch%twostr%band(ib)%Rbeam_atm = bc_in(s)%solad_parb(ifp,ib) cpatch%twostr%band(ib)%Rdiff_atm = bc_in(s)%solai_parb(ifp,ib) end do + + area_vlpfcl(:,:,:) = 0._r8 + cpatch%parprof_pft_dir_z(:,:,:) = 0._r8 + cpatch%parprof_pft_dif_z(:,:,:) = 0._r8 + cpatch%f_sun(:,:,:) = 0._r8 + cpatch%ed_parsun_z(:,:,:) = 0._r8 + cpatch%ed_parsha_z(:,:,:) = 0._r8 - if(cpatch%solar_zenith_flag )then - call FatesPatchFSun(cpatch, & - bc_out(s)%fsun_pa(ifp), & - bc_out(s)%laisun_pa(ifp), & - bc_out(s)%laisha_pa(ifp)) + call FatesPatchFSun(cpatch, & + bc_out(s)%fsun_pa(ifp), & + bc_out(s)%laisun_pa(ifp), & + bc_out(s)%laisha_pa(ifp)) - call CheckPatchRadiationBalance(cpatch, sites(s)%snow_depth, ivis,bc_out(s)%fabd_parb(ifp,ivis), bc_out(s)%fabi_parb(ifp,ivis)) - call CheckPatchRadiationBalance(cpatch, sites(s)%snow_depth, inir,bc_out(s)%fabd_parb(ifp,inir), bc_out(s)%fabi_parb(ifp,inir)) - else - - bc_out(s)%fsun_pa(ifp) = 0.5_r8 - bc_out(s)%laisun_pa(ifp) = 0.5_r8*calc_areaindex(cpatch,'elai') - bc_out(s)%laisha_pa(ifp) = 0.5_r8*calc_areaindex(cpatch,'elai') - - end if + call CheckPatchRadiationBalance(cpatch, sites(s)%snow_depth, ivis,bc_out(s)%fabd_parb(ifp,ivis), bc_out(s)%fabi_parb(ifp,ivis)) + call CheckPatchRadiationBalance(cpatch, sites(s)%snow_depth, inir,bc_out(s)%fabd_parb(ifp,inir), bc_out(s)%fabi_parb(ifp,inir)) + associate(twostr => cpatch%twostr) + + do cl = 1,twostr%n_lyr + do icol = 1,twostr%n_col(cl) + + ft = twostr%scelg(cl,icol)%pft + if_notair: if (ft>0) then + area_frac = twostr%scelg(cl,icol)%area + vai = twostr%scelg(cl,icol)%sai+twostr%scelg(cl,icol)%lai + nv = minloc(dlower_vai, DIM=1, MASK=(dlower_vai>vai)) + do iv = 1, nv + + vai_top = dlower_vai(iv)-dinc_vai(iv) + vai_bot = min(dlower_vai(iv),twostr%scelg(cl,icol)%sai+twostr%scelg(cl,icol)%lai) + + cpatch%parprof_pft_dir_z(cl,ft,iv) = cpatch%parprof_pft_dir_z(cl,ft,iv) + & + area_frac*twostr%GetRb(cl,icol,ivis,vai_top) + cpatch%parprof_pft_dif_z(cl,ft,iv) = cpatch%parprof_pft_dif_z(cl,ft,iv) + & + area_frac*twostr%GetRdDn(cl,icol,ivis,vai_top) + & + area_frac*twostr%GetRdUp(cl,icol,ivis,vai_top) + + call twostr%GetAbsRad(cl,icol,ipar,vai_top,vai_bot, & + Rb_abs,Rd_abs,Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow,leaf_sun_frac) + + cpatch%f_sun(cl,ft,iv) = cpatch%f_sun(cl,ft,iv) + & + area_frac*leaf_sun_frac + cpatch%ed_parsun_z(cl,ft,iv) = cpatch%ed_parsun_z(cl,ft,iv) + & + area_frac*(rd_abs_leaf*leaf_sun_frac + rb_abs_leaf) + cpatch%ed_parsha_z(cl,ft,iv) = cpatch%ed_parsha_z(cl,ft,iv) + & + area_frac*rd_abs_leaf*(1._r8-leaf_sun_frac) + + area_vlpfcl(iv,ft,cl) = area_vlpfcl(iv,ft,cl) + area_frac + end do + end if if_notair + end do + + do ft = 1,numpft + do_iv: do iv = 1, nlevleaf + if(area_vlpfcl(iv,ft,cl) cpatch%younger enddo diff --git a/radiation/FatesRadiationMemMod.F90 b/radiation/FatesRadiationMemMod.F90 index f41a18e455..b0c208e5a6 100644 --- a/radiation/FatesRadiationMemMod.F90 +++ b/radiation/FatesRadiationMemMod.F90 @@ -16,7 +16,7 @@ Module FatesRadiationMemMod integer, parameter, public :: norman_solver = 1 integer, parameter, public :: twostr_solver = 2 - integer, parameter, public :: rad_solver = twostr_solver + integer, parameter, public :: rad_solver = norman_solver integer, parameter, public :: num_rad_stream_types = 2 ! The number of radiation streams used (direct/diffuse) diff --git a/radiation/FatesTwoStreamInterfaceMod.F90 b/radiation/FatesTwoStreamInterfaceMod.F90 index b5735540af..2da6917a66 100644 --- a/radiation/FatesTwoStreamInterfaceMod.F90 +++ b/radiation/FatesTwoStreamInterfaceMod.F90 @@ -282,7 +282,7 @@ subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) call twostr%CanopyPrep(fcansno_pa(ifp)) call twostr%ZenithPrep(coszen_pa(ifp)) - end associate + end associate @@ -294,7 +294,7 @@ subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) end subroutine FatesConstructRadElements ! ============================================================================================= - + subroutine FatesPatchFSun(patch,fsun,laisun,laisha) type(ed_patch_type) :: patch diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index 02cc71a819..00d808f803 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -210,11 +210,12 @@ Module TwoStreamMLPEMod procedure :: GetNSCel procedure :: AllocInitTwoStream procedure :: DeallocTwoStream - + procedure :: GetRdUp procedure :: GetRdDn procedure :: GetRb procedure :: GetAbsRad + end type twostream_type @@ -344,6 +345,7 @@ function GetRdDn(this,ican,icol,ib,vai) result(r_diff_dn) scelb%B2d*scelb%lambda2_diff*exp(-scelb%a*vai)) if(r_diff_dn.ne.r_diff_dn)then + print*,"GETRDN" print*,scelg%Kb print*,scelb%a print*,vai @@ -471,15 +473,15 @@ subroutine GetAbsRad(this,ican,icol,ib,vai_top,vai_bot, & dlai = dvai * scelg%lai/( scelg%lai+ scelg%sai) - !!if(dlai>nearzero)then - !! leaf_sun_frac = max(0.001_r8,min(0.999_r8,scelb%Rbeam0/(dlai*scelg%Kb_leaf/rad_params%clumping_index(ft)) & - !! *(exp(-scelg%Kb_leaf*lai_top) - exp(-scelg%Kb_leaf*lai_bot)))) - !!else - !! leaf_sun_frac = 0001._r8 - !!end if - - leaf_sun_frac = max(0.001_r8,min(0.999_r8,scelb%Rbeam0/(dvai*scelg%Kb/rad_params%clumping_index(ft)) & - *(exp(-scelg%Kb*vai_top) - exp(-scelg%Kb*vai_bot)))) + if(dlai>nearzero)then + leaf_sun_frac = max(0.001_r8,min(0.999_r8,scelb%Rbeam0/(dlai*scelg%Kb_leaf/rad_params%clumping_index(ft)) & + *(exp(-scelg%Kb_leaf*lai_top) - exp(-scelg%Kb_leaf*lai_bot)))) + else + leaf_sun_frac = 0001._r8 + end if + + !leaf_sun_frac = max(0.001_r8,min(0.999_r8,scelb%Rbeam0/(dvai*scelg%Kb/rad_params%clumping_index(ft)) & + ! *(exp(-scelg%Kb*vai_top) - exp(-scelg%Kb*vai_bot)))) if(debug) then @@ -643,6 +645,9 @@ subroutine CanopyPrep(this,frac_snow) real(r8) :: betad_om ! multiplication of diffuse backscatter and reflectance real(r8) :: area_check ! Checks to make sure each layer has 100% coverage + + print*,"CANOPY PREP" + this%frac_snow = frac_snow if(.not.this%force_prep) then @@ -766,6 +771,8 @@ subroutine ZenithPrep(this,cosz) real(r8) :: betab_om ! multiplication of beam backscatter and reflectance real(r8) :: om_veg ! scattering coefficient for vegetation (no snow) + print*,"ZENITH PREP" + if( (cosz-1.0) > nearzero ) then print*,"The cosine of the zenith angle cannot exceed 1" print*,"cosz: ",cosz @@ -863,8 +870,6 @@ subroutine ZenithPrep(this,cosz) end do do_ical end do do_ican - !this%band(ib)%albedo_grnd_beam = 1.e-36 ! Must fill this in - return end subroutine ZenithPrep @@ -1039,6 +1044,8 @@ subroutine Solve(this, ib, & ! upper canopy. ! -------------------------------------------------------------------------- + print*,"SOLVE" + if((Rbeam_atm+Rdiff_atm) Date: Mon, 5 Jun 2023 13:49:35 -0400 Subject: [PATCH 065/250] Updated error logging in twostream to use logging file units and error handling --- .../radiation/RadiationUTestDriver.py | 6 +- main/FatesGlobals.F90 | 3 + radiation/TwoStreamMLPEMod.F90 | 231 ++++++++++-------- 3 files changed, 130 insertions(+), 110 deletions(-) diff --git a/functional_unit_testing/radiation/RadiationUTestDriver.py b/functional_unit_testing/radiation/RadiationUTestDriver.py index d11432da6c..faba1c19e7 100644 --- a/functional_unit_testing/radiation/RadiationUTestDriver.py +++ b/functional_unit_testing/radiation/RadiationUTestDriver.py @@ -144,16 +144,16 @@ def main(argv): # Process the core 2Stream parameters from parameters in file iret = param_prep_call(ci(n_pft)) - if(False): + if(True): ParallelElementPerturbDist() if(True): SunFracTests() - if(False): + if(True): SingleElementPerturbTest() - if(False): + if(True): SerialParallelCanopyTest() plt.show() diff --git a/main/FatesGlobals.F90 b/main/FatesGlobals.F90 index ebc0f326ff..299fb5d5fb 100644 --- a/main/FatesGlobals.F90 +++ b/main/FatesGlobals.F90 @@ -5,6 +5,7 @@ module FatesGlobals ! immediately obvious home. use FatesConstantsMod , only : r8 => fates_r8 + use TwoStreamMLPEMod , only : TwoStreamLogInit implicit none private ! By default everything is private @@ -63,6 +64,8 @@ subroutine FatesGlobalsInit(log_unit,global_verbose) fates_log_ = log_unit fates_global_verbose_ = global_verbose + call TwoStreamLogInit(log_unit) + end subroutine FatesGlobalsInit ! ===================================================================================== diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index 00d808f803..b811f55fb4 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -24,6 +24,9 @@ Module TwoStreamMLPEMod ! 3 = thermal (not used at the moment) ! + use shr_log_mod , only: errMsg => shr_log_errMsg + use shr_sys_mod , only: shr_sys_abort + implicit none private @@ -47,7 +50,7 @@ Module TwoStreamMLPEMod integer,public, parameter :: normalized_upper_boundary = 1 integer,public, parameter :: absolute_upper_boundary = 2 - + integer :: log_unit ! fortran output unit for logging ! These are parameter constants, ie things that are specific to the plant material ! and radiation band. Not all of these need to be used. 2-stream ultimately wants @@ -221,13 +224,43 @@ Module TwoStreamMLPEMod public :: ParamPrep public :: AllocateRadParams - + public :: TwoStreamLogInit + character(len=*), parameter, private :: sourcefile = & __FILE__ contains + subroutine TwoStreamLogInit(log_unit_in) + integer,intent(in) :: log_unit_in + + log_unit = log_unit_in + + end subroutine TwoStreamLogInit + + subroutine endrun(msg) + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Abort the model for abnormal termination + ! This subroutine was derived from CLM's + ! endrun_vanilla() in abortutils.F90 + ! + ! + ! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: msg ! string to be printed + !----------------------------------------------------------------------- + + write(log_unit,*)'ENDRUN:', msg + call shr_sys_abort() + + end subroutine endrun + + + ! =============================================================================================== + subroutine AllocInitTwoStream(this,band_indices,ncan,ncol) class(twostream_type) :: this @@ -326,16 +359,6 @@ function GetRdDn(this,ican,icol,ib,vai) result(r_diff_dn) associate(scelb => this%band(ib)%scelb(ican,icol), & scelg => this%scelg(ican,icol) ) - !print*,'-----' - !print*,this%band(ib)%Rbeam_atm,this%band(ib)%Rdiff_atm - !print*,scelb%Ad,scelg%Kb,vai - !print*,scelb%B1d,scelb%lambda1_beam,scelb%a - !print*,scelb%B2d,scelb%lambda2_beam - !print*,scelb%lambda1_diff,scelb%lambda2_diff - !print*,exp(-scelg%Kb*vai) - !print*,exp(scelb%a*vai) - !print*,exp(-scelb%a*vai) - r_diff_dn = this%band(ib)%Rbeam_atm*( & scelb%Ad*exp(-scelg%Kb*vai) + & scelb%B1d*scelb%lambda1_beam*exp(scelb%a*vai) + & @@ -345,19 +368,19 @@ function GetRdDn(this,ican,icol,ib,vai) result(r_diff_dn) scelb%B2d*scelb%lambda2_diff*exp(-scelb%a*vai)) if(r_diff_dn.ne.r_diff_dn)then - print*,"GETRDN" - print*,scelg%Kb - print*,scelb%a - print*,vai - print*,scelb%Ad - print*,scelb%B1d,scelb%B2d - print*,scelb%lambda1_beam,scelb%lambda2_beam - print*,scelb%lambda1_diff,scelb%lambda2_diff - print*,this%band(ib)%Rbeam_atm - print*,this%band(ib)%Rdiff_atm - print*,exp(-scelg%Kb*vai) - print*,exp(scelb%a*vai) - stop + write(log_unit,*)"GETRDN" + write(log_unit,*)scelg%Kb + write(log_unit,*)scelb%a + write(log_unit,*)vai + write(log_unit,*)scelb%Ad + write(log_unit,*)scelb%B1d,scelb%B2d + write(log_unit,*)scelb%lambda1_beam,scelb%lambda2_beam + write(log_unit,*)scelb%lambda1_diff,scelb%lambda2_diff + write(log_unit,*)this%band(ib)%Rbeam_atm + write(log_unit,*)this%band(ib)%Rdiff_atm + write(log_unit,*)exp(-scelg%Kb*vai) + write(log_unit,*)exp(scelb%a*vai) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -486,8 +509,8 @@ subroutine GetAbsRad(this,ican,icol,ib,vai_top,vai_bot, & if(debug) then if(leaf_sun_frac>1.0_r8 .or. leaf_sun_frac<0._r8) then - print*,"impossible leaf sun fraction" - stop + write(log_unit,*)"impossible leaf sun fraction" + call endrun(msg=errMsg(sourcefile, __LINE__)) end if end if @@ -506,21 +529,21 @@ subroutine GetAbsRad(this,ican,icol,ib,vai_top,vai_bot, & if(debug) then if( (vai_bot-vai_max)>rel_err_thresh)then - print*,"During decomposition of the 2-stream radiation solution" - print*,"A vegetation area index (VAI) was requested in GetAbsRad()" - print*,"that is larger than the total integrated VAI of the " - print*,"computation element of interest." - print*,"vai_max: ",vai_max - print*,"vai_bot: ",vai_bot - stop + write(log_unit,*)"During decomposition of the 2-stream radiation solution" + write(log_unit,*)"A vegetation area index (VAI) was requested in GetAbsRad()" + write(log_unit,*)"that is larger than the total integrated VAI of the " + write(log_unit,*)"computation element of interest." + write(log_unit,*)"vai_max: ",vai_max + write(log_unit,*)"vai_bot: ",vai_bot + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if( (vai_bot-vai_top)<-rel_err_thresh ) then - print*,"During decomposition of the 2-stream radiation solution" - print*,"the vegetation area index at the lower position was set" - print*,"as greater than the value at the upper position." - print*,"vai_max: ",vai_max - print*,"vai_bot: ",vai_bot - stop + write(log_unit,*)"During decomposition of the 2-stream radiation solution" + write(log_unit,*)"the vegetation area index at the lower position was set" + write(log_unit,*)"as greater than the value at the upper position." + write(log_unit,*)"vai_max: ",vai_max + write(log_unit,*)"vai_bot: ",vai_bot + call endrun(msg=errMsg(sourcefile, __LINE__)) end if end if @@ -580,9 +603,9 @@ subroutine ParamPrep() ! just let it go, dont worry about it. if(rad_params%xl(ft)<-0.4_r8 .or. rad_params%xl(ft)>0.6_r8) then - print*,"Leaf orientation factors (xl) should be between -0.4 and 0.6" - print*,"ft: ",ft,"xl: ",rad_params%xl(ft) - stop + write(log_unit,*)"Leaf orientation factors (xl) should be between -0.4 and 0.6" + write(log_unit,*)"ft: ",ft,"xl: ",rad_params%xl(ft) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if ! There is a singularity of leaf orientation is exactly 0 @@ -645,9 +668,6 @@ subroutine CanopyPrep(this,frac_snow) real(r8) :: betad_om ! multiplication of diffuse backscatter and reflectance real(r8) :: area_check ! Checks to make sure each layer has 100% coverage - - print*,"CANOPY PREP" - this%frac_snow = frac_snow if(.not.this%force_prep) then @@ -727,17 +747,17 @@ subroutine CanopyPrep(this,frac_snow) ! RE-ENABLE THIS CHECK WHEN FATES IS BETTER AT CONSERVING AREA!! if(.false.)then - !if( abs(area_check-1._r8) > 10._r8*area_err_thresh )then - print*,"Only a partial canopy was specified" - print*,"Scattering elements must constitute 100% of the ground cover." - print*,"for open spaces, create an air element with the respective area." - print*,"total area (out of 1): ",area_check,ican - print*,"layer: ",ican," of: ",this%n_lyr + !if( abs(area_check-1._r8) > 10._r8*area_err_thresh )then + write(log_unit,*)"Only a partial canopy was specified" + write(log_unit,*)"Scattering elements must constitute 100% of the ground cover." + write(log_unit,*)"for open spaces, create an air element with the respective area." + write(log_unit,*)"total area (out of 1): ",area_check,ican + write(log_unit,*)"layer: ",ican," of: ",this%n_lyr do icol = 1,this%n_col(ican) - print*,this%scelg(ican,icol)%area,this%scelg(ican,icol)%pft + write(log_unit,*)this%scelg(ican,icol)%area,this%scelg(ican,icol)%pft end do - print*,"TwoStreamMLPEMod.F90:CanopyPrep" - stop + write(log_unit,*)"TwoStreamMLPEMod.F90:CanopyPrep" + call endrun(msg=errMsg(sourcefile, __LINE__)) end if end do do_can @@ -771,19 +791,17 @@ subroutine ZenithPrep(this,cosz) real(r8) :: betab_om ! multiplication of beam backscatter and reflectance real(r8) :: om_veg ! scattering coefficient for vegetation (no snow) - print*,"ZENITH PREP" - if( (cosz-1.0) > nearzero ) then - print*,"The cosine of the zenith angle cannot exceed 1" - print*,"cosz: ",cosz - print*,"TwoStreamMLPEMod.F90:ZenithPrep" - stop + write(log_unit,*)"The cosine of the zenith angle cannot exceed 1" + write(log_unit,*)"cosz: ",cosz + write(log_unit,*)"TwoStreamMLPEMod.F90:ZenithPrep" + call endrun(msg=errMsg(sourcefile, __LINE__)) elseif(cosz<0._r8)then - print*,"The cosine of the zenith angle should not be less than zero" - print*,"It can be exactly zero, but not less than" - print*,"cosz: ",cosz - print*,"TwoStreamMLPEMod.F90:ZenithPrep" - stop + write(log_unit,*)"The cosine of the zenith angle should not be less than zero" + write(log_unit,*)"It can be exactly zero, but not less than" + write(log_unit,*)"cosz: ",cosz + write(log_unit,*)"TwoStreamMLPEMod.F90:ZenithPrep" + call endrun(msg=errMsg(sourcefile, __LINE__)) end if cosz = max(nearzero,cosz) @@ -804,7 +822,7 @@ subroutine ZenithPrep(this,cosz) !how much direct light penetrates a singleunit of lai? scelg%Kb_leaf = min(kb_max,rad_params%clumping_index(ft) * gdir / cosz) - !print*,"Kb_leaf: ",scelg%Kb_leaf,gdir , cosz + !write(log_unit,*)"Kb_leaf: ",scelg%Kb_leaf,gdir , cosz ! RGK: My sense is that snow should be adding optical depth @@ -855,12 +873,13 @@ subroutine ZenithPrep(this,cosz) scelb%betab = betab_om / scelb%om - if( .not.(scelb%betab==scelb%betab))then - print*,"Beam backscatter fraction is NaN" - print*, betab_om,scelb%om,om_veg,this%frac_snow,betab_veg,asu,avmu,scelg%Kb - stop + if(debug)then + if( .not.(scelb%betab==scelb%betab))then + write(log_unit,*)"Beam backscatter fraction is NaN" + write(log_unit,*) betab_om,scelb%om,om_veg,this%frac_snow,betab_veg,asu,avmu,scelg%Kb + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if end if - end if @@ -1044,13 +1063,11 @@ subroutine Solve(this, ib, & ! upper canopy. ! -------------------------------------------------------------------------- - print*,"SOLVE" - if((Rbeam_atm+Rdiff_atm)100)then - print*,"NEED A BIGGER MATRIX" - stop + write(log_unit,*)"NEED A BIGGER MATRIX" + call endrun(msg=errMsg(sourcefile, __LINE__)) end if OMEGA(1:n_eq,1:n_eq) = 0._r8 @@ -1382,7 +1399,7 @@ subroutine Solve(this, ib, & end do - !print*,"TAU: ",TAU(:) + !write(log_unit,*)"TAU: ",TAU(:) LAMBDA(1:n_eq) = TAU(1:n_eq) @@ -1535,35 +1552,35 @@ subroutine Solve(this, ib, & !if( abs(rel_err) > rel_err_thresh ) then if( rel_err.ne.rel_err) then - print*,"Total canopy flux balance not closing in TwoStrteamMLPEMod:Solve" - print*,"Relative Error, delta/(Rbeam_atm+Rdiff_atm) :",rel_err - print*,"Max Error: ",rel_err_thresh - print*,"ib: ",ib - print*, beam_err,diff_err - print*,this%band(ib)%albedo_grnd_diff - print*, frac_diff_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_diff) + & + write(log_unit,*)"Total canopy flux balance not closing in TwoStrteamMLPEMod:Solve" + write(log_unit,*)"Relative Error, delta/(Rbeam_atm+Rdiff_atm) :",rel_err + write(log_unit,*)"Max Error: ",rel_err_thresh + write(log_unit,*)"ib: ",ib + write(log_unit,*) beam_err,diff_err + write(log_unit,*)this%band(ib)%albedo_grnd_diff + write(log_unit,*) frac_diff_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_diff) + & frac_beam_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_beam) - print*, frac_diff_grnd_diff*(1._r8-this%band(ib)%albedo_grnd_diff) - print*, albedo_beam,albedo_diff - print*, frac_abs_can_beam,frac_abs_can_diff - print*, frac_diff_grnd_beam,frac_beam_grnd_beam,frac_diff_grnd_diff - print*, "scattering coeff: ",(2*rad_params%om_leaf(ib,1)+0.5*rad_params%om_stem(ib,1))/2.5 - print*, "Breakdown:",this%n_lyr + write(log_unit,*) frac_diff_grnd_diff*(1._r8-this%band(ib)%albedo_grnd_diff) + write(log_unit,*) albedo_beam,albedo_diff + write(log_unit,*) frac_abs_can_beam,frac_abs_can_diff + write(log_unit,*) frac_diff_grnd_beam,frac_beam_grnd_beam,frac_diff_grnd_diff + write(log_unit,*) "scattering coeff: ",(2*rad_params%om_leaf(ib,1)+0.5*rad_params%om_stem(ib,1))/2.5 + write(log_unit,*) "Breakdown:",this%n_lyr do ican = 1,this%n_lyr do icol = 1,this%n_col(ican) scelgp => this%scelg(ican,icol) scelbp => this%band(ib)%scelb(ican,icol) - print*," ",ican,icol - print*," ",scelgp%lai+scelgp%sai,scelgp%pft,scelgp%area - print*," ",scelbp%om,scelgp%Kb,scelgp%Kd,scelbp%betab,scelbp%betad - print*," ",scelbp%om*(1.0-scelbp%betad) - print*," ",scelbp%lambda1_beam,scelbp%lambda2_beam - print*," ",scelbp%lambda1_diff,scelbp%lambda2_diff - print*,"AB TERMS: ",scelbp%Ad,scelbp%Au,scelbp%B1d,scelbp%B2d,scelbp%B2d,scelbp%B2u,scelbp%a - print*,"LAMBDA TERMS: ",scelbp%lambda1_diff,scelbp%lambda2_diff,scelbp%lambda1_beam,scelbp%lambda2_beam + write(log_unit,*)" ",ican,icol + write(log_unit,*)" ",scelgp%lai+scelgp%sai,scelgp%pft,scelgp%area + write(log_unit,*)" ",scelbp%om,scelgp%Kb,scelgp%Kd,scelbp%betab,scelbp%betad + write(log_unit,*)" ",scelbp%om*(1.0-scelbp%betad) + write(log_unit,*)" ",scelbp%lambda1_beam,scelbp%lambda2_beam + write(log_unit,*)" ",scelbp%lambda1_diff,scelbp%lambda2_diff + write(log_unit,*)"AB TERMS: ",scelbp%Ad,scelbp%Au,scelbp%B1d,scelbp%B2d,scelbp%B2d,scelbp%B2u,scelbp%a + write(log_unit,*)"LAMBDA TERMS: ",scelbp%lambda1_diff,scelbp%lambda2_diff,scelbp%lambda1_beam,scelbp%lambda2_beam end do end do - stop + call endrun(msg=errMsg(sourcefile, __LINE__)) end if From 32be05b2db97838be0e2069aae64158b49f257b2 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Mon, 5 Jun 2023 16:00:51 -0700 Subject: [PATCH 066/250] fixed units on LU transition rates --- biogeochem/EDPatchDynamicsMod.F90 | 4 ++-- biogeochem/FatesLandUseChangeMod.F90 | 22 +++++++++++----------- 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 22f27e63a4..338305e48b 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -206,14 +206,14 @@ subroutine disturbance_rates( site_in, bc_in) real(r8) :: tempsum real(r8) :: harvestable_forest_c(hlm_num_lu_harvest_cats) integer :: harvest_tag(hlm_num_lu_harvest_cats) - real(r8) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) ! [m2/m2/year] + real(r8) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) ! [m2/m2/day] real(r8) :: current_fates_landuse_state_vector(n_landuse_cats) ! [m2/m2] !---------------------------------------------------------------------------------------------- ! Calculate Mortality Rates (these were previously calculated during growth derivatives) ! And the same rates in understory plants have already been applied to %dndt !---------------------------------------------------------------------------------------------- - ! first calculate the fractino of the site that is primary land + ! first calculate the fraction of the site that is primary land call get_frac_site_primary(site_in, frac_site_primary) ! get available biomass for harvest for all patches diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index 92992d4680..89b262ac12 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -10,6 +10,7 @@ module FatesLandUseChangeMod use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue, ifalse use FatesConstantsMod , only : fates_unset_int + use FatesConstantsMod , only : years_per_day use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_use_luh use FatesInterfaceTypesMod , only : hlm_num_luh2_states @@ -67,7 +68,7 @@ subroutine get_landuse_transition_rates(bc_in, landuse_transition_matrix) ! !ARGUMENTS: type(bc_in_type) , intent(in) :: bc_in - real(r8), intent(inout) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) ! [m2/m2/year] + real(r8), intent(inout) :: landuse_transition_matrix(n_landuse_cats, n_landuse_cats) ! [m2/m2/day] ! !LOCAL VARIABLES: type(luh2_fates_lutype_map) :: lumap @@ -91,10 +92,9 @@ subroutine get_landuse_transition_rates(bc_in, landuse_transition_matrix) ! identify urban fraction so that it can be factored into the land use state output urban_fraction = bc_in%hlm_luh_states(findloc(bc_in%hlm_luh_state_names,'urban',dim=1)) end if - !!may need some logic here to ask whether or not ot perform land use cahnge on this timestep. current code occurs every day. - - ! identify urban fraction so that it can be accounted for in the fates land use aggregation - ! urban_fraction = bc_in%hlm_luh_states(findloc(bc_in%hlm_luh_state_names,'urban',dim=1)) + + !!TODO: may need some logic here to ask whether or not ot perform land use change on this timestep. current code occurs every day. + !!If not doing transition every day, need to update units. transitions_loop: do i_luh2_transitions = 1, hlm_num_luh2_transitions @@ -110,8 +110,7 @@ subroutine get_landuse_transition_rates(bc_in, landuse_transition_matrix) ! Avoid transitions with 'urban' as those are handled seperately if (.not.(i_donor .eq. fates_unset_int .or. i_receiver .eq. fates_unset_int)) then landuse_transition_matrix(i_donor,i_receiver) = & - landuse_transition_matrix(i_donor,i_receiver) + temp_vector(i_luh2_transitions) / (1._r8 - urban_fraction) - !landuse_transition_matrix(i_donor,i_receiver) + bc_in%hlm_luh_transitions(i_luh2_transitions) / (1._r8 - urban_fraction) + landuse_transition_matrix(i_donor,i_receiver) + temp_vector(i_luh2_transitions) * years_per_day / (1._r8 - urban_fraction) end if end do transitions_loop @@ -275,17 +274,18 @@ subroutine CheckLUHData(luh_vector,modified_flag) ! Check to see if the incoming luh2 vector is NaN. ! This suggests that there is a discepency where the HLM and LUH2 states - ! there is vegetated ground. In this case, states should be Nan. If so, - ! set the current state to be all primary forest. + ! there is vegetated ground. E.g. LUH2 data is missing for glacier-margin regions such as Antarctica. + ! In this case, states should be Nan. If so, + ! set the current state to be all primary forest, and all transitions to be zero. ! If only a portion of the vector is NaN, there is something amiss with ! the data, so end the run. modified_flag = .false. if (all(isnan(luh_vector))) then - luh_vector = 0._r8 + luh_vector(:) = 0._r8 ! Check if this is a state vector, otherwise leave transitions as zero if (size(luh_vector) .eq. hlm_num_luh2_states) then - luh_vector(1) = 1._r8 + luh_vector(primaryland) = 1._r8 end if modified_flag = .true. write(fates_log(),*) 'WARNING: land use state is all NaN; setting state as all primary forest.' From 12749bec22e1c03e566bdeb837fe3941364c1340 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Mon, 5 Jun 2023 16:19:00 -0700 Subject: [PATCH 067/250] adding logic to handle case where disturbance_rate is slightly greater than one. --- biogeochem/EDPatchDynamicsMod.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 338305e48b..33801d93ed 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -545,6 +545,8 @@ subroutine spawn_patches( currentSite, bc_in) write(fates_log(),*) 'patch disturbance rate > 1 ?',disturbance_rate call dump_patch(currentPatch) call endrun(msg=errMsg(sourcefile, __LINE__)) + else if (disturbance_rate > 1.0_r8) then + disturbance_rate = 1.0_r8 end if ! Only create new patches that have non-negligible amount of land From 2c8193b77f5470fa5bbac1b920c0b0254867755d Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 5 Jun 2023 17:49:22 -0700 Subject: [PATCH 068/250] update patch insertion to account for more landuse types --- biogeochem/EDPatchDynamicsMod.F90 | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 33801d93ed..5e0efabf3f 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -461,7 +461,7 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: leaf_burn_frac ! fraction of leaves burned in fire ! for both woody and grass species real(r8) :: leaf_m ! leaf mass during partial burn calculations - logical :: found_youngest_primary ! logical for finding the first primary forest patch + logical :: found_youngest_landuselabel ! logical for finding the first primary forest patch integer :: min_nocomp_pft, max_nocomp_pft, i_nocomp_pft integer :: i_disturbance_type, i_dist2 ! iterators for looping over disturbance types integer :: i_landusechange_receiverpatchlabel ! iterator for the land use change types @@ -1202,28 +1202,29 @@ subroutine spawn_patches( currentSite, bc_in) if ( site_areadis .gt. nearzero) then currentPatch => currentSite%youngest_patch -!!!CDK 3/27 need change this logic. put the new patch as younger than any patches with the same labels - ! insert new youngest primary patch after all the secondary patches, if there are any. - ! this requires first finding the current youngest primary to insert the new one ahead of - if (currentPatch%land_use_label .eq. secondaryland ) then - found_youngest_primary = .false. - do while(associated(currentPatch) .and. .not. found_youngest_primary) + ! Insert new patch as the youngest patch in the group of patches with the same land use type. + ! On a given site, the patches are grouped together by land use type. The order of the + ! groups within the site doesn't matter, except that the older patch group are primarylands. + + if (currentPatch%land_use_label .eq. new_patch%land_use_label ) then + found_youngest_landuselabel = .false. + do while(associated(currentPatch) .and. .not. found_youngest_landuselabel) currentPatch => currentPatch%older if (associated(currentPatch)) then - if (currentPatch%land_use_label .eq. primaryland) then - found_youngest_primary = .true. + if (currentPatch%land_use_label .eq. new_patch%land_use_label) then + found_youngest_landuselabel = .true. endif endif end do if (associated(currentPatch)) then - ! the case where we've found a youngest primary patch + ! the case where we've found a youngest patch type matching the new patch type new_patch%older => currentPatch new_patch%younger => currentPatch%younger currentPatch%younger%older => new_patch currentPatch%younger => new_patch else - ! the case where we haven't, because the patches are all secondaary, - ! and are putting a primary patch at the oldest end of the + ! the case where we haven't, because the patches are all non-primaryland, + ! and are putting a primaryland patch at the oldest end of the ! linked list (not sure how this could happen, but who knows...) new_patch%older => null() new_patch%younger => currentSite%oldest_patch @@ -1231,7 +1232,7 @@ subroutine spawn_patches( currentSite, bc_in) currentSite%oldest_patch => new_patch endif else - ! the case where there are no secondary patches at the start of the linked list (prior logic) + ! the case where the youngest patch on the site matches the new patch type new_patch%older => currentPatch new_patch%younger => null() currentPatch%younger => new_patch From 3b19f3d5ade174082fffdacf9e01611966c93906 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 6 Jun 2023 10:14:30 -0700 Subject: [PATCH 069/250] add fix to age indexing --- biogeochem/EDPatchDynamicsMod.F90 | 116 ++++++++++++++++++++++++++++-- 1 file changed, 109 insertions(+), 7 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 5e0efabf3f..afeff3acba 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -304,11 +304,16 @@ subroutine disturbance_rates( site_in, bc_in) dist_rate_ldist_notharvested = 0.0_r8 - ! Avoid this calculation to avoid NaN result if luh is not used + ! Avoid this calculation to avoid NaN due to division by zero result if luh is not used if (hlm_use_luh .eq. itrue) then + write(fates_log(),*) 'disturb1: max rate, lustatevec, lbl: ', & + maxval(landuse_transition_matrix(currentPatch%land_use_label,1:n_landuse_cats)), & + current_fates_landuse_state_vector(currentPatch%land_use_label), currentPatch%land_use_label currentPatch%landuse_transition_rates(1:n_landuse_cats) = min(1._r8, & landuse_transition_matrix(currentPatch%land_use_label,1:n_landuse_cats) / & current_fates_landuse_state_vector(currentPatch%land_use_label)) + else + currentPatch%landuse_transition_rates = 0.0_r8 end if currentCohort => currentPatch%shortest @@ -391,14 +396,19 @@ subroutine disturbance_rates( site_in, bc_in) ! if the sum of all disturbance rates is such that they will exceed total patch area on this day, then reduce them all proportionally. if ( (sum(currentPatch%disturbance_rates(:)) + sum(currentPatch%landuse_transition_rates(1:n_landuse_cats))) .gt. 1.0_r8 ) then tempsum = sum(currentPatch%disturbance_rates(:)) + sum(currentPatch%landuse_transition_rates(1:n_landuse_cats)) + write(fates_log(),*) 'disturb2: tempsum: ', tempsum do i_dist = 1,N_DIST_TYPES currentPatch%disturbance_rates(i_dist) = currentPatch%disturbance_rates(i_dist) / tempsum + write(fates_log(),*) 'disturb2: distrate, lbl: ', currentPatch%disturbance_rates(i_dist), currentPatch%land_use_label end do do i_dist = 1,n_landuse_cats currentPatch%landuse_transition_rates(i_dist) = currentPatch%landuse_transition_rates(i_dist) / tempsum + write(fates_log(),*) 'disturb2: landtransrate, lbl: ', currentPatch%landuse_transition_rates(i_dist), currentPatch%land_use_label end do endif + write(fates_log(),*) 'disturb3: landtransrate, lbl: ', currentPatch%landuse_transition_rates, currentPatch%land_use_label + currentPatch => currentPatch%younger enddo !patch loop @@ -524,22 +534,26 @@ subroutine spawn_patches( currentSite, bc_in) patchloop_areadis: do while(associated(currentPatch)) - write(fates_log(),*) 'indices: ncpft, dt, dplt, lcrpl: ', i_nocomp_pft, i_disturbance_type, i_donorpatch_landuse_type, i_landusechange_receiverpatchlabel - write(fates_log(),*) 'labels: lul, ncpl', currentPatch%land_use_label, currentPatch%nocomp_pft_label + !write(fates_log(),*) 'indices: ncpft, dt, dplt, lcrpl: ', i_nocomp_pft, i_disturbance_type, i_donorpatch_landuse_type, i_landusechange_receiverpatchlabel + !write(fates_log(),*) 'labels: lul, ncpl', currentPatch%land_use_label, currentPatch%nocomp_pft_label cp_nocomp_matches_1_if: if ( hlm_use_nocomp .eq. ifalse .or. & currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then patchlabel_matches_lutype_if_areadis: if (currentPatch%land_use_label .eq. i_donorpatch_landuse_type) then + disturbance_rate = 0.0_r8 if ( i_disturbance_type .ne. dtype_ilandusechange) then disturbance_rate = currentPatch%disturbance_rates(i_disturbance_type) else disturbance_rate = currentPatch%landuse_transition_rates(i_landusechange_receiverpatchlabel) endif - - write(fates_log(),*) 'patch disturbance rate: ',currentPatch%disturbance_rates(i_disturbance_type) - write(fates_log(),*) 'disturbance type: ', i_disturbance_type + + if (currentPatch%land_use_label .eq. 4) then + write(fates_log(),*) 'spawn1a: lulabel, dtype: ',currentPatch%land_use_label, i_disturbance_type + write(fates_log(),*) 'spawn1a: donor, rcvr: ', i_donorpatch_landuse_type, i_landusechange_receiverpatchlabel + write(fates_log(),*) 'spawn1a: parea, distrate: ',currentPatch%area, disturbance_rate + endif if(disturbance_rate > (1.0_r8 + rsnbl_math_prec)) then write(fates_log(),*) 'patch disturbance rate > 1 ?',disturbance_rate @@ -549,6 +563,12 @@ subroutine spawn_patches( currentSite, bc_in) disturbance_rate = 1.0_r8 end if + !if(disturbance_rate .ge. 1.0_r8) then + ! write(fates_log(),*) 'patch disturbance rate > 1 ?',disturbance_rate + ! write(fates_log(),*) 'pdistrate, dtype, label: ', disturbance_rate, i_disturbance_type, & + ! currentPatch%land_use_label + !end if + ! Only create new patches that have non-negligible amount of land if((currentPatch%area*disturbance_rate) > nearzero ) then @@ -573,6 +593,9 @@ subroutine spawn_patches( currentSite, bc_in) ! create an empty patch, to absorb newly disturbed area allocate(new_patch) + write(fates_log(),*) 'spawn1b: lulabel, dtype: ',new_patch%land_use_label, i_disturbance_type + write(fates_log(),*) 'spawn1b: donor, rcvr: ',i_donorpatch_landuse_type, i_landusechange_receiverpatchlabel + call create_patch(currentSite, new_patch, age, & site_areadis, i_landusechange_receiverpatchlabel, i_nocomp_pft) @@ -607,6 +630,7 @@ subroutine spawn_patches( currentSite, bc_in) ! This is the amount of patch area that is disturbed, and donated by the donor + disturbance_rate = 0.0_r8 if ( i_disturbance_type .ne. dtype_ilandusechange) then disturbance_rate = currentPatch%disturbance_rates(i_disturbance_type) else @@ -614,6 +638,13 @@ subroutine spawn_patches( currentSite, bc_in) endif patch_site_areadis = currentPatch%area * disturbance_rate + + if (currentPatch%land_use_label .eq. 4) then + write(fates_log(),*) 'spawn2a: lulabel, dtype: ',currentPatch%land_use_label, i_disturbance_type + write(fates_log(),*) 'spawn2a: donor, rcvr: ',i_donorpatch_landuse_type, i_landusechange_receiverpatchlabel + write(fates_log(),*) 'spawn2a: parea, disrate areadis: ',currentPatch%area, disturbance_rate, & + patch_site_areadis + endif areadis_gt_zero_if: if ( patch_site_areadis > nearzero ) then @@ -631,8 +662,19 @@ subroutine spawn_patches( currentSite, bc_in) if ( currentPatch%land_use_label .gt. primaryland .and. & (i_disturbance_type .lt. dtype_ilog) ) then + if (currentPatch%land_use_label .eq. 4) then + write(fates_log(),*) 'spawn2b: lulabel, dtype: ',currentPatch%land_use_label, i_disturbance_type + write(fates_log(),*) 'spawn2b: donor, rcvr: ',i_donorpatch_landuse_type, i_landusechange_receiverpatchlabel + write(fates_log(),*) 'spawn2b: curragedist, newagedist: ',currentPatch%age_since_anthro_disturbance, & + new_patch%age_since_anthro_disturbance + write(fates_log(),*) 'spawn2b: currage, newage: ', currentPatch%age, new_patch%age + write(fates_log(),*) 'spawn2b: currageclass, newageclass: ', currentPatch%age_class, new_patch%age_class + write(fates_log(),*) 'spawn2b: currarea, newarea: ', currentPatch%area,new_patch%area + endif + new_patch%age_since_anthro_disturbance = new_patch%age_since_anthro_disturbance + & - currentPatch%age_since_anthro_disturbance * (patch_site_areadis / site_areadis) + currentPatch%age_since_anthro_disturbance * (patch_site_areadis / site_areadis) + endif ! Transfer the litter existing already in the donor patch to the new patch @@ -1158,6 +1200,11 @@ subroutine spawn_patches( currentSite, bc_in) !update area of donor patch oldarea = currentPatch%area currentPatch%area = currentPatch%area - patch_site_areadis + if (currentPatch%land_use_label .eq. 4) then + write(fates_log(),*) 'spawnareaadj: lulabel, dtype: ',currentPatch%land_use_label, i_disturbance_type + write(fates_log(),*) 'spawnareaadj: donor, rcvr: ',i_donorpatch_landuse_type, i_landusechange_receiverpatchlabel + write(fates_log(),*) 'spawnareaadj: old, curr, areadis: ', oldarea, currentPatch%area, patch_site_areadis + endif ! for all disturbance rates that haven't been resolved yet, increase their amount so that ! they are the same amount of gridcell-scale disturbance relative to the original patch size @@ -1177,6 +1224,14 @@ subroutine spawn_patches( currentSite, bc_in) end do end if + if (currentPatch%land_use_label .eq. 4) then + write(fates_log(),*) 'spawnareaadj: lulabel, dtype: ',currentPatch%land_use_label, i_disturbance_type + write(fates_log(),*) 'spawnareaadj: donor, rcvr: ',i_donorpatch_landuse_type, i_landusechange_receiverpatchlabel + write(fates_log(),*) 'spawnareaadj: old, curr, areadis: ', oldarea, currentPatch%area, patch_site_areadis + write(fates_log(),*) 'spawnareaadj: transrates: ', currentPatch%landuse_transition_rates + write(fates_log(),*) 'spawnareaadj: distrates: ', currentPatch%disturbance_rates + endif + ! sort out the cohorts, since some of them may be so small as to need removing. ! the first call to terminate cohorts removes sparse number densities, ! the second call removes for all other reasons (sparse culling must happen @@ -2437,6 +2492,7 @@ subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) new_patch%land_use_label = label if (label .gt. primaryland) then new_patch%age_since_anthro_disturbance = age + write(fates_log(),*) 'create_patch: asad, label: ', new_patch%age_since_anthro_disturbance, new_patch%land_use_label else new_patch%age_since_anthro_disturbance = fates_unset_r8 endif @@ -2829,9 +2885,16 @@ subroutine fuse_patches( csite, bc_in ) !-----------------------! tmpptr => currentPatch%older + write(fates_log(),*) 'fuse: tmpptrlbl, tmpptrage: ', tmpptr%land_use_label, tmpptr%age + write(fates_log(),*) 'fuse: currlabel, tpplabel: ', currentPatch%land_use_label, tpp%land_use_label + write(fates_log(),*) 'fuse: currage, tppage: ', currentPatch%age, tpp%age + write(fates_log(),*) 'fuse: curragedist, tppagedist: ', currentPatch%age_since_anthro_disturbance, & + tpp%age_since_anthro_disturbance call fuse_2_patches(csite, currentPatch, tpp) + write(fates_log(),*) 'fusepost1: tppage: ', tpp%age call fuse_cohorts(csite,tpp, bc_in) call sort_cohorts(tpp) + write(fates_log(),*) 'fusepost2: tppage: ', tpp%age currentPatch => tmpptr !------------------------------------------------------------------------! @@ -2956,6 +3019,8 @@ subroutine fuse_2_patches(csite, dp, rp) inv_sum_area = 1.0_r8/(dp%area + rp%area) + write(fates_log(),*) 'fuse2: dpage,rpage: ', dp%age, rp%age + write(fates_log(),*) 'fuse2: dparea,rparea,invarea: ', dp%area, rp%area, inv_sum_area rp%age = (dp%age * dp%area + rp%age * rp%area) * inv_sum_area rp%age_since_anthro_disturbance = (dp%age_since_anthro_disturbance * dp%area & + rp%age_since_anthro_disturbance * rp%area) * inv_sum_area @@ -3055,6 +3120,7 @@ subroutine fuse_2_patches(csite, dp, rp) endif !are there any cohorts? call patch_pft_size_profile(rp) ! Recalculate the patch size profile for the resulting patch + write(fates_log(),*) 'fuse2_postprofile: dpage,rpage: ', dp%age, rp%age ! Define some aliases for the donor patches younger and older neighbors ! which may or may not exist. After we set them, we will remove the donor @@ -3077,6 +3143,7 @@ subroutine fuse_2_patches(csite, dp, rp) write(fates_log(),*) 'dealloc006: fail on deallocate(dp):'//trim(smsg) call endrun(msg=errMsg(sourcefile, __LINE__)) endif + write(fates_log(),*) 'fuse2_postdealloc: rpage: ', rp%age if(associated(youngerp))then ! Update the younger patch's new older patch (because it isn't dp anymore) @@ -3144,8 +3211,14 @@ subroutine terminate_patches(currentSite) patchpointer%land_use_label .eq. currentPatch%land_use_label .and. & .not. gotfused) then + write(fates_log(),*) 'term: currlabel, ptrlabel: ', currentPatch%land_use_label, patchpointer%land_use_label + write(fates_log(),*) 'term: currage, ptrage: ', currentPatch%age, patchpointer%age + write(fates_log(),*) 'term: curragedist, ptragedist: ', currentPatch%age_since_anthro_disturbance, & + patchpointer%age_since_anthro_disturbance + call fuse_2_patches(currentSite, patchpointer, currentPatch) + write(fates_log(),*) 'termpost: currage: ', currentPatch%age gotfused = .true. else patchpointer => patchpointer%older @@ -3185,8 +3258,14 @@ subroutine terminate_patches(currentSite) distlabel_1_if: if (currentPatch%land_use_label .eq. olderPatch%land_use_label) then + write(fates_log(),*) 'term1a: currlabel, oldlabel: ', currentPatch%land_use_label, olderPatch%land_use_label + write(fates_log(),*) 'term1a: currage, oldage: ', currentPatch%age, olderPatch%age + write(fates_log(),*) 'term1a: curragedist, oldagedist: ', currentPatch%age_since_anthro_disturbance, & + olderPatch%age_since_anthro_disturbance + call fuse_2_patches(currentSite, olderPatch, currentPatch) + write(fates_log(),*) 'term1apost: currage: ', currentPatch%age ! The fusion process has updated the "older" pointer on currentPatch ! for us. @@ -3199,8 +3278,16 @@ subroutine terminate_patches(currentSite) ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its older sibling ! and then allow them to fuse together. + ! We also assigned the age since disturbance value to be the younger (donor) patch to avoid combining a valid + ! age with fates_unset_r8 (i.e. the age for primaryland) in the fuse_2_patches procedure + write(fates_log(),*) 'term1b: currlabel, oldlabel: ', currentPatch%land_use_label, olderPatch%land_use_label + write(fates_log(),*) 'term1b: currage, oldage: ', currentPatch%age, olderPatch%age + write(fates_log(),*) 'term1b: curragedist, oldagedist: ', currentPatch%age_since_anthro_disturbance, & + olderPatch%age_since_anthro_disturbance currentPatch%land_use_label = olderPatch%land_use_label + currentPatch%age_since_anthro_disturbance = olderPatch%age_since_anthro_disturbance call fuse_2_patches(currentSite, olderPatch, currentPatch) + write(fates_log(),*) 'term1bpost: currage: ', currentPatch%age gotfused = .true. endif countcycles_if endif distlabel_1_if @@ -3216,16 +3303,31 @@ subroutine terminate_patches(currentSite) distlabel_2_if: if (currentPatch%land_use_label .eq. youngerPatch% land_use_label) then + write(fates_log(),*) 'term2a: currlabel, ynglabel: ', currentPatch%land_use_label, youngerPatch%land_use_label + write(fates_log(),*) 'term2a: currage, yngage: ', currentPatch%age, youngerPatch%age + write(fates_log(),*) 'term2a: curragedist, yngagedist: ', currentPatch%age_since_anthro_disturbance, & + youngerPatch%age_since_anthro_disturbance call fuse_2_patches(currentSite, youngerPatch, currentPatch) + write(fates_log(),*) 'term2apost: currage: ', currentPatch%age ! The fusion process has updated the "younger" pointer on currentPatch + ! GL: ADD MISSING GOTFUSED? + !gotfused = .true. else distlabel_2_if if (count_cycles .gt. 0) then ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its younger sibling + ! We also assigned the age since disturbance value to be the younger (donor) patch to avoid combining a valid + ! age with fates_unset_r8 (i.e. the age for primaryland) in the fuse_2_patches procedure + write(fates_log(),*) 'term2b: currlabel, ynglabel: ', currentPatch%land_use_label, youngerPatch%land_use_label + write(fates_log(),*) 'term2b: currage, yngage: ', currentPatch%age, youngerPatch%age + write(fates_log(),*) 'term2b: curragedist, yngagedist: ', currentPatch%age_since_anthro_disturbance, & + youngerPatch%age_since_anthro_disturbance currentPatch%land_use_label = youngerPatch%land_use_label + currentPatch%age_since_anthro_disturbance = youngerPatch%age_since_anthro_disturbance call fuse_2_patches(currentSite, youngerPatch, currentPatch) + write(fates_log(),*) 'term2bpost: currage: ', currentPatch%age gotfused = .true. endif ! count cycles endif distlabel_2_if ! anthro labels From 9c209b5a2d4b648cd1cdb3f273d9f596aad5d5f7 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 6 Jun 2023 10:20:57 -0700 Subject: [PATCH 070/250] remove old diagnostic write statements --- biogeochem/EDPatchDynamicsMod.F90 | 97 +------------------------------ 1 file changed, 1 insertion(+), 96 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index afeff3acba..0801ffdbaa 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -306,8 +306,7 @@ subroutine disturbance_rates( site_in, bc_in) ! Avoid this calculation to avoid NaN due to division by zero result if luh is not used if (hlm_use_luh .eq. itrue) then - write(fates_log(),*) 'disturb1: max rate, lustatevec, lbl: ', & - maxval(landuse_transition_matrix(currentPatch%land_use_label,1:n_landuse_cats)), & + maxval(landuse_transition_matrix(currentPatch%land_use_label,1:n_landuse_cats)), & current_fates_landuse_state_vector(currentPatch%land_use_label), currentPatch%land_use_label currentPatch%landuse_transition_rates(1:n_landuse_cats) = min(1._r8, & landuse_transition_matrix(currentPatch%land_use_label,1:n_landuse_cats) / & @@ -396,19 +395,14 @@ subroutine disturbance_rates( site_in, bc_in) ! if the sum of all disturbance rates is such that they will exceed total patch area on this day, then reduce them all proportionally. if ( (sum(currentPatch%disturbance_rates(:)) + sum(currentPatch%landuse_transition_rates(1:n_landuse_cats))) .gt. 1.0_r8 ) then tempsum = sum(currentPatch%disturbance_rates(:)) + sum(currentPatch%landuse_transition_rates(1:n_landuse_cats)) - write(fates_log(),*) 'disturb2: tempsum: ', tempsum do i_dist = 1,N_DIST_TYPES currentPatch%disturbance_rates(i_dist) = currentPatch%disturbance_rates(i_dist) / tempsum - write(fates_log(),*) 'disturb2: distrate, lbl: ', currentPatch%disturbance_rates(i_dist), currentPatch%land_use_label end do do i_dist = 1,n_landuse_cats currentPatch%landuse_transition_rates(i_dist) = currentPatch%landuse_transition_rates(i_dist) / tempsum - write(fates_log(),*) 'disturb2: landtransrate, lbl: ', currentPatch%landuse_transition_rates(i_dist), currentPatch%land_use_label end do endif - write(fates_log(),*) 'disturb3: landtransrate, lbl: ', currentPatch%landuse_transition_rates, currentPatch%land_use_label - currentPatch => currentPatch%younger enddo !patch loop @@ -484,8 +478,6 @@ subroutine spawn_patches( currentSite, bc_in) !--------------------------------------------------------------------- - ! write(fates_log(),*) 'calling spawn patches' - storesmallcohort => null() ! storage of the smallest cohort for insertion routine storebigcohort => null() ! storage of the largest cohort for insertion routine @@ -534,9 +526,6 @@ subroutine spawn_patches( currentSite, bc_in) patchloop_areadis: do while(associated(currentPatch)) - !write(fates_log(),*) 'indices: ncpft, dt, dplt, lcrpl: ', i_nocomp_pft, i_disturbance_type, i_donorpatch_landuse_type, i_landusechange_receiverpatchlabel - !write(fates_log(),*) 'labels: lul, ncpl', currentPatch%land_use_label, currentPatch%nocomp_pft_label - cp_nocomp_matches_1_if: if ( hlm_use_nocomp .eq. ifalse .or. & currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then @@ -549,12 +538,6 @@ subroutine spawn_patches( currentSite, bc_in) disturbance_rate = currentPatch%landuse_transition_rates(i_landusechange_receiverpatchlabel) endif - if (currentPatch%land_use_label .eq. 4) then - write(fates_log(),*) 'spawn1a: lulabel, dtype: ',currentPatch%land_use_label, i_disturbance_type - write(fates_log(),*) 'spawn1a: donor, rcvr: ', i_donorpatch_landuse_type, i_landusechange_receiverpatchlabel - write(fates_log(),*) 'spawn1a: parea, distrate: ',currentPatch%area, disturbance_rate - endif - if(disturbance_rate > (1.0_r8 + rsnbl_math_prec)) then write(fates_log(),*) 'patch disturbance rate > 1 ?',disturbance_rate call dump_patch(currentPatch) @@ -563,12 +546,6 @@ subroutine spawn_patches( currentSite, bc_in) disturbance_rate = 1.0_r8 end if - !if(disturbance_rate .ge. 1.0_r8) then - ! write(fates_log(),*) 'patch disturbance rate > 1 ?',disturbance_rate - ! write(fates_log(),*) 'pdistrate, dtype, label: ', disturbance_rate, i_disturbance_type, & - ! currentPatch%land_use_label - !end if - ! Only create new patches that have non-negligible amount of land if((currentPatch%area*disturbance_rate) > nearzero ) then @@ -593,9 +570,6 @@ subroutine spawn_patches( currentSite, bc_in) ! create an empty patch, to absorb newly disturbed area allocate(new_patch) - write(fates_log(),*) 'spawn1b: lulabel, dtype: ',new_patch%land_use_label, i_disturbance_type - write(fates_log(),*) 'spawn1b: donor, rcvr: ',i_donorpatch_landuse_type, i_landusechange_receiverpatchlabel - call create_patch(currentSite, new_patch, age, & site_areadis, i_landusechange_receiverpatchlabel, i_nocomp_pft) @@ -639,14 +613,6 @@ subroutine spawn_patches( currentSite, bc_in) patch_site_areadis = currentPatch%area * disturbance_rate - if (currentPatch%land_use_label .eq. 4) then - write(fates_log(),*) 'spawn2a: lulabel, dtype: ',currentPatch%land_use_label, i_disturbance_type - write(fates_log(),*) 'spawn2a: donor, rcvr: ',i_donorpatch_landuse_type, i_landusechange_receiverpatchlabel - write(fates_log(),*) 'spawn2a: parea, disrate areadis: ',currentPatch%area, disturbance_rate, & - patch_site_areadis - endif - - areadis_gt_zero_if: if ( patch_site_areadis > nearzero ) then if(.not.associated(new_patch))then @@ -662,16 +628,6 @@ subroutine spawn_patches( currentSite, bc_in) if ( currentPatch%land_use_label .gt. primaryland .and. & (i_disturbance_type .lt. dtype_ilog) ) then - if (currentPatch%land_use_label .eq. 4) then - write(fates_log(),*) 'spawn2b: lulabel, dtype: ',currentPatch%land_use_label, i_disturbance_type - write(fates_log(),*) 'spawn2b: donor, rcvr: ',i_donorpatch_landuse_type, i_landusechange_receiverpatchlabel - write(fates_log(),*) 'spawn2b: curragedist, newagedist: ',currentPatch%age_since_anthro_disturbance, & - new_patch%age_since_anthro_disturbance - write(fates_log(),*) 'spawn2b: currage, newage: ', currentPatch%age, new_patch%age - write(fates_log(),*) 'spawn2b: currageclass, newageclass: ', currentPatch%age_class, new_patch%age_class - write(fates_log(),*) 'spawn2b: currarea, newarea: ', currentPatch%area,new_patch%area - endif - new_patch%age_since_anthro_disturbance = new_patch%age_since_anthro_disturbance + & currentPatch%age_since_anthro_disturbance * (patch_site_areadis / site_areadis) @@ -1200,11 +1156,6 @@ subroutine spawn_patches( currentSite, bc_in) !update area of donor patch oldarea = currentPatch%area currentPatch%area = currentPatch%area - patch_site_areadis - if (currentPatch%land_use_label .eq. 4) then - write(fates_log(),*) 'spawnareaadj: lulabel, dtype: ',currentPatch%land_use_label, i_disturbance_type - write(fates_log(),*) 'spawnareaadj: donor, rcvr: ',i_donorpatch_landuse_type, i_landusechange_receiverpatchlabel - write(fates_log(),*) 'spawnareaadj: old, curr, areadis: ', oldarea, currentPatch%area, patch_site_areadis - endif ! for all disturbance rates that haven't been resolved yet, increase their amount so that ! they are the same amount of gridcell-scale disturbance relative to the original patch size @@ -1224,14 +1175,6 @@ subroutine spawn_patches( currentSite, bc_in) end do end if - if (currentPatch%land_use_label .eq. 4) then - write(fates_log(),*) 'spawnareaadj: lulabel, dtype: ',currentPatch%land_use_label, i_disturbance_type - write(fates_log(),*) 'spawnareaadj: donor, rcvr: ',i_donorpatch_landuse_type, i_landusechange_receiverpatchlabel - write(fates_log(),*) 'spawnareaadj: old, curr, areadis: ', oldarea, currentPatch%area, patch_site_areadis - write(fates_log(),*) 'spawnareaadj: transrates: ', currentPatch%landuse_transition_rates - write(fates_log(),*) 'spawnareaadj: distrates: ', currentPatch%disturbance_rates - endif - ! sort out the cohorts, since some of them may be so small as to need removing. ! the first call to terminate cohorts removes sparse number densities, ! the second call removes for all other reasons (sparse culling must happen @@ -2492,7 +2435,6 @@ subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) new_patch%land_use_label = label if (label .gt. primaryland) then new_patch%age_since_anthro_disturbance = age - write(fates_log(),*) 'create_patch: asad, label: ', new_patch%age_since_anthro_disturbance, new_patch%land_use_label else new_patch%age_since_anthro_disturbance = fates_unset_r8 endif @@ -2885,16 +2827,9 @@ subroutine fuse_patches( csite, bc_in ) !-----------------------! tmpptr => currentPatch%older - write(fates_log(),*) 'fuse: tmpptrlbl, tmpptrage: ', tmpptr%land_use_label, tmpptr%age - write(fates_log(),*) 'fuse: currlabel, tpplabel: ', currentPatch%land_use_label, tpp%land_use_label - write(fates_log(),*) 'fuse: currage, tppage: ', currentPatch%age, tpp%age - write(fates_log(),*) 'fuse: curragedist, tppagedist: ', currentPatch%age_since_anthro_disturbance, & - tpp%age_since_anthro_disturbance call fuse_2_patches(csite, currentPatch, tpp) - write(fates_log(),*) 'fusepost1: tppage: ', tpp%age call fuse_cohorts(csite,tpp, bc_in) call sort_cohorts(tpp) - write(fates_log(),*) 'fusepost2: tppage: ', tpp%age currentPatch => tmpptr !------------------------------------------------------------------------! @@ -3019,8 +2954,6 @@ subroutine fuse_2_patches(csite, dp, rp) inv_sum_area = 1.0_r8/(dp%area + rp%area) - write(fates_log(),*) 'fuse2: dpage,rpage: ', dp%age, rp%age - write(fates_log(),*) 'fuse2: dparea,rparea,invarea: ', dp%area, rp%area, inv_sum_area rp%age = (dp%age * dp%area + rp%age * rp%area) * inv_sum_area rp%age_since_anthro_disturbance = (dp%age_since_anthro_disturbance * dp%area & + rp%age_since_anthro_disturbance * rp%area) * inv_sum_area @@ -3120,7 +3053,6 @@ subroutine fuse_2_patches(csite, dp, rp) endif !are there any cohorts? call patch_pft_size_profile(rp) ! Recalculate the patch size profile for the resulting patch - write(fates_log(),*) 'fuse2_postprofile: dpage,rpage: ', dp%age, rp%age ! Define some aliases for the donor patches younger and older neighbors ! which may or may not exist. After we set them, we will remove the donor @@ -3143,7 +3075,6 @@ subroutine fuse_2_patches(csite, dp, rp) write(fates_log(),*) 'dealloc006: fail on deallocate(dp):'//trim(smsg) call endrun(msg=errMsg(sourcefile, __LINE__)) endif - write(fates_log(),*) 'fuse2_postdealloc: rpage: ', rp%age if(associated(youngerp))then ! Update the younger patch's new older patch (because it isn't dp anymore) @@ -3211,14 +3142,8 @@ subroutine terminate_patches(currentSite) patchpointer%land_use_label .eq. currentPatch%land_use_label .and. & .not. gotfused) then - write(fates_log(),*) 'term: currlabel, ptrlabel: ', currentPatch%land_use_label, patchpointer%land_use_label - write(fates_log(),*) 'term: currage, ptrage: ', currentPatch%age, patchpointer%age - write(fates_log(),*) 'term: curragedist, ptragedist: ', currentPatch%age_since_anthro_disturbance, & - patchpointer%age_since_anthro_disturbance - call fuse_2_patches(currentSite, patchpointer, currentPatch) - write(fates_log(),*) 'termpost: currage: ', currentPatch%age gotfused = .true. else patchpointer => patchpointer%older @@ -3258,11 +3183,6 @@ subroutine terminate_patches(currentSite) distlabel_1_if: if (currentPatch%land_use_label .eq. olderPatch%land_use_label) then - write(fates_log(),*) 'term1a: currlabel, oldlabel: ', currentPatch%land_use_label, olderPatch%land_use_label - write(fates_log(),*) 'term1a: currage, oldage: ', currentPatch%age, olderPatch%age - write(fates_log(),*) 'term1a: curragedist, oldagedist: ', currentPatch%age_since_anthro_disturbance, & - olderPatch%age_since_anthro_disturbance - call fuse_2_patches(currentSite, olderPatch, currentPatch) write(fates_log(),*) 'term1apost: currage: ', currentPatch%age @@ -3280,14 +3200,9 @@ subroutine terminate_patches(currentSite) ! and then allow them to fuse together. ! We also assigned the age since disturbance value to be the younger (donor) patch to avoid combining a valid ! age with fates_unset_r8 (i.e. the age for primaryland) in the fuse_2_patches procedure - write(fates_log(),*) 'term1b: currlabel, oldlabel: ', currentPatch%land_use_label, olderPatch%land_use_label - write(fates_log(),*) 'term1b: currage, oldage: ', currentPatch%age, olderPatch%age - write(fates_log(),*) 'term1b: curragedist, oldagedist: ', currentPatch%age_since_anthro_disturbance, & - olderPatch%age_since_anthro_disturbance currentPatch%land_use_label = olderPatch%land_use_label currentPatch%age_since_anthro_disturbance = olderPatch%age_since_anthro_disturbance call fuse_2_patches(currentSite, olderPatch, currentPatch) - write(fates_log(),*) 'term1bpost: currage: ', currentPatch%age gotfused = .true. endif countcycles_if endif distlabel_1_if @@ -3303,12 +3218,7 @@ subroutine terminate_patches(currentSite) distlabel_2_if: if (currentPatch%land_use_label .eq. youngerPatch% land_use_label) then - write(fates_log(),*) 'term2a: currlabel, ynglabel: ', currentPatch%land_use_label, youngerPatch%land_use_label - write(fates_log(),*) 'term2a: currage, yngage: ', currentPatch%age, youngerPatch%age - write(fates_log(),*) 'term2a: curragedist, yngagedist: ', currentPatch%age_since_anthro_disturbance, & - youngerPatch%age_since_anthro_disturbance call fuse_2_patches(currentSite, youngerPatch, currentPatch) - write(fates_log(),*) 'term2apost: currage: ', currentPatch%age ! The fusion process has updated the "younger" pointer on currentPatch @@ -3320,14 +3230,9 @@ subroutine terminate_patches(currentSite) ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its younger sibling ! We also assigned the age since disturbance value to be the younger (donor) patch to avoid combining a valid ! age with fates_unset_r8 (i.e. the age for primaryland) in the fuse_2_patches procedure - write(fates_log(),*) 'term2b: currlabel, ynglabel: ', currentPatch%land_use_label, youngerPatch%land_use_label - write(fates_log(),*) 'term2b: currage, yngage: ', currentPatch%age, youngerPatch%age - write(fates_log(),*) 'term2b: curragedist, yngagedist: ', currentPatch%age_since_anthro_disturbance, & - youngerPatch%age_since_anthro_disturbance currentPatch%land_use_label = youngerPatch%land_use_label currentPatch%age_since_anthro_disturbance = youngerPatch%age_since_anthro_disturbance call fuse_2_patches(currentSite, youngerPatch, currentPatch) - write(fates_log(),*) 'term2bpost: currage: ', currentPatch%age gotfused = .true. endif ! count cycles endif distlabel_2_if ! anthro labels From 1377f2d0d22a6e9353d9b07a73267e6255764541 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 6 Jun 2023 10:21:44 -0700 Subject: [PATCH 071/250] remove missed diagnostic write --- biogeochem/EDPatchDynamicsMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 0801ffdbaa..8cc7a83174 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -3185,7 +3185,6 @@ subroutine terminate_patches(currentSite) call fuse_2_patches(currentSite, olderPatch, currentPatch) - write(fates_log(),*) 'term1apost: currage: ', currentPatch%age ! The fusion process has updated the "older" pointer on currentPatch ! for us. From 71737af66edec3bd76880da2dbbf9b2825eac4e4 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 6 Jun 2023 14:14:28 -0400 Subject: [PATCH 072/250] remove tail of old write statment --- biogeochem/EDPatchDynamicsMod.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 8cc7a83174..bb002f6639 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -306,8 +306,6 @@ subroutine disturbance_rates( site_in, bc_in) ! Avoid this calculation to avoid NaN due to division by zero result if luh is not used if (hlm_use_luh .eq. itrue) then - maxval(landuse_transition_matrix(currentPatch%land_use_label,1:n_landuse_cats)), & - current_fates_landuse_state_vector(currentPatch%land_use_label), currentPatch%land_use_label currentPatch%landuse_transition_rates(1:n_landuse_cats) = min(1._r8, & landuse_transition_matrix(currentPatch%land_use_label,1:n_landuse_cats) / & current_fates_landuse_state_vector(currentPatch%land_use_label)) From feba193085c9bf97e2220999b836b72ab25374dd Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 6 Jun 2023 17:08:47 -0400 Subject: [PATCH 073/250] increasing variable character length --- main/FatesHistoryVariableType.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 index 59e5da01de..83cbdb8c1c 100644 --- a/main/FatesHistoryVariableType.F90 +++ b/main/FatesHistoryVariableType.F90 @@ -32,7 +32,7 @@ module FatesHistoryVariableType ! This type is instanteated in the HLM-FATES interface (clmfates_interfaceMod.F90) type, public :: fates_history_variable_type - character(len=32) :: vname + character(len=40) :: vname character(len=24) :: units character(len=128) :: long character(len=24) :: use_default ! States whether a variable should be turned From 47122a93d81c5bdd8a102d76616627d2e57bc28b Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 8 Jun 2023 10:15:38 -0700 Subject: [PATCH 074/250] initial commit to create insert_patch procedure --- biogeochem/EDPatchDynamicsMod.F90 | 99 +++++++++++++++++++------------ 1 file changed, 61 insertions(+), 38 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index bb002f6639..f7c4740fcd 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1196,44 +1196,6 @@ subroutine spawn_patches( currentSite, bc_in) !*************************/ if ( site_areadis .gt. nearzero) then - currentPatch => currentSite%youngest_patch - - ! Insert new patch as the youngest patch in the group of patches with the same land use type. - ! On a given site, the patches are grouped together by land use type. The order of the - ! groups within the site doesn't matter, except that the older patch group are primarylands. - - if (currentPatch%land_use_label .eq. new_patch%land_use_label ) then - found_youngest_landuselabel = .false. - do while(associated(currentPatch) .and. .not. found_youngest_landuselabel) - currentPatch => currentPatch%older - if (associated(currentPatch)) then - if (currentPatch%land_use_label .eq. new_patch%land_use_label) then - found_youngest_landuselabel = .true. - endif - endif - end do - if (associated(currentPatch)) then - ! the case where we've found a youngest patch type matching the new patch type - new_patch%older => currentPatch - new_patch%younger => currentPatch%younger - currentPatch%younger%older => new_patch - currentPatch%younger => new_patch - else - ! the case where we haven't, because the patches are all non-primaryland, - ! and are putting a primaryland patch at the oldest end of the - ! linked list (not sure how this could happen, but who knows...) - new_patch%older => null() - new_patch%younger => currentSite%oldest_patch - currentSite%oldest_patch%older => new_patch - currentSite%oldest_patch => new_patch - endif - else - ! the case where the youngest patch on the site matches the new patch type - new_patch%older => currentPatch - new_patch%younger => null() - currentPatch%younger => new_patch - currentSite%youngest_patch => new_patch - endif ! sort out the cohorts, since some of them may be so small as to need removing. ! the first call to terminate cohorts removes sparse number densities, @@ -3503,4 +3465,65 @@ subroutine get_frac_site_primary(site_in, frac_site_primary) end subroutine get_frac_site_primary + ! ===================================================================================== + + subroutine insert_patch(currentSite, newPatch) + + ! !DESCRIPTION: + ! Insert patch into linked list + ! + ! !USES: + use EDTypesMod , only : ed_site_type + use EDTypesMod , only : ed_patch_type + ! + ! !ARGUMENTS: + type (ed_site_type), intent(inout), pointer :: currentSite + type (ed_patch_type), intent(inout), pointer :: newPatch + + ! !LOCAL VARIABLES: + type (ed_patch_type), pointer :: currentPatch + + ! Start from the youngest patch and work to oldest + currentPatch => currentSite%youngest_patch + + ! Insert new patch as the youngest patch in the group of patches with the same land use type. + ! On a given site, the patches are grouped together by land use type. The order of the + ! groups within the site doesn't matter, except that the older patch group are primarylands. + + if (currentPatch%land_use_label .eq. new_patch%land_use_label ) then + found_youngest_landuselabel = .false. + do while(associated(currentPatch) .and. .not. found_youngest_landuselabel) + currentPatch => currentPatch%older + if (associated(currentPatch)) then + if (currentPatch%land_use_label .eq. new_patch%land_use_label) then + found_youngest_landuselabel = .true. + endif + endif + end do + if (associated(currentPatch)) then + ! the case where we've found a youngest patch type matching the new patch type + new_patch%older => currentPatch + new_patch%younger => currentPatch%younger + currentPatch%younger%older => new_patch + currentPatch%younger => new_patch + else + ! the case where we haven't, because the patches are all non-primaryland, + ! and are putting a primaryland patch at the oldest end of the + ! linked list (not sure how this could happen, but who knows...) + new_patch%older => null() + new_patch%younger => currentSite%oldest_patch + currentSite%oldest_patch%older => new_patch + currentSite%oldest_patch => new_patch + endif + else + ! the case where the youngest patch on the site matches the new patch type + new_patch%older => currentPatch + new_patch%younger => null() + currentPatch%younger => new_patch + currentSite%youngest_patch => new_patch + endif + + + end subroutine insert_patch + end module EDPatchDynamicsMod From 63b335d74a6e186cbd6959219176fc47f59988b6 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 8 Jun 2023 11:30:38 -0700 Subject: [PATCH 075/250] add simplest insertion method --- biogeochem/EDPatchDynamicsMod.F90 | 83 +++++++++++++++++++------------ 1 file changed, 52 insertions(+), 31 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index f7c4740fcd..3149ab5a0a 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -463,7 +463,6 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: leaf_burn_frac ! fraction of leaves burned in fire ! for both woody and grass species real(r8) :: leaf_m ! leaf mass during partial burn calculations - logical :: found_youngest_landuselabel ! logical for finding the first primary forest patch integer :: min_nocomp_pft, max_nocomp_pft, i_nocomp_pft integer :: i_disturbance_type, i_dist2 ! iterators for looping over disturbance types integer :: i_landusechange_receiverpatchlabel ! iterator for the land use change types @@ -1197,6 +1196,8 @@ subroutine spawn_patches( currentSite, bc_in) if ( site_areadis .gt. nearzero) then + call insert_patch(currentSite, new_patch) + ! sort out the cohorts, since some of them may be so small as to need removing. ! the first call to terminate cohorts removes sparse number densities, ! the second call removes for all other reasons (sparse culling must happen @@ -3482,46 +3483,66 @@ subroutine insert_patch(currentSite, newPatch) ! !LOCAL VARIABLES: type (ed_patch_type), pointer :: currentPatch + integer :: insert_method ! Temporary dev + logical :: found_landuselabel + + insert_method = 1 ! Start from the youngest patch and work to oldest currentPatch => currentSite%youngest_patch + ! TODO: Test alternate methods ! Insert new patch as the youngest patch in the group of patches with the same land use type. - ! On a given site, the patches are grouped together by land use type. The order of the - ! groups within the site doesn't matter, except that the older patch group are primarylands. - - if (currentPatch%land_use_label .eq. new_patch%land_use_label ) then - found_youngest_landuselabel = .false. - do while(associated(currentPatch) .and. .not. found_youngest_landuselabel) - currentPatch => currentPatch%older - if (associated(currentPatch)) then - if (currentPatch%land_use_label .eq. new_patch%land_use_label) then - found_youngest_landuselabel = .true. + ! On a given site, the patches are grouped together by land use type. + ! Option 1: The landuse type group order doesn't matter at all + ! Option 2: Abitrarily set the group order to numerical order with first being primaryland + ! Option 3: The order of the groups within the site doesn't matter, except that the older + ! patch group are primarylands. + ! Option 4: landuse type order doesn't matter, only age + + if (insert_method .eq. 1) then + ! Option 1 + if (currentPatch%land_use_label .ne. new_patch%land_use_label ) then + found_landuselabel = .false. + do while(associated(currentPatch) .and. .not. found_landuselabel) + currentPatch => currentPatch%older + if (associated(currentPatch)) then + if (currentPatch%land_use_label .eq. new_patch%land_use_label) then + found_landuselabel = .true. + endif endif + end do + if (associated(currentPatch)) then + ! The case where we've found a patch type matching the new patch type. + ! In this case the new_patch will be the youngest patch for that + ! land use type + new_patch%older => currentPatch + new_patch%younger => currentPatch%younger + currentPatch%younger%older => new_patch + currentPatch%younger => new_patch + else + ! The case in which we get to the end of the list and haven't found + ! a landuse type match. If this is the case, simply add the new patch + ! to the end of the list + new_patch%older => null() + new_patch%younger => currentSite%oldest_patch + currentSite%oldest_patch%older => new_patch + currentSite%oldest_patch => new_patch endif - end do - if (associated(currentPatch)) then - ! the case where we've found a youngest patch type matching the new patch type + else + ! The case in which the first patch in the list matches the new patch type new_patch%older => currentPatch - new_patch%younger => currentPatch%younger - currentPatch%younger%older => new_patch + new_patch%younger => null() currentPatch%younger => new_patch - else - ! the case where we haven't, because the patches are all non-primaryland, - ! and are putting a primaryland patch at the oldest end of the - ! linked list (not sure how this could happen, but who knows...) - new_patch%older => null() - new_patch%younger => currentSite%oldest_patch - currentSite%oldest_patch%older => new_patch - currentSite%oldest_patch => new_patch + currentSite%youngest_patch => new_patch endif - else - ! the case where the youngest patch on the site matches the new patch type - new_patch%older => currentPatch - new_patch%younger => null() - currentPatch%younger => new_patch - currentSite%youngest_patch => new_patch - endif + elseif (insert_method .eq. 2) then + ! Option 2 + elseif (insert_method .eq. 3) then + ! Option 3 + elseif (insert_method .eq. 4) then + ! Option 4 + end if end subroutine insert_patch From a3100a9ca819e4d58f7e415aa7e99f0bdce681f6 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 8 Jun 2023 12:58:53 -0700 Subject: [PATCH 076/250] adding option 1 and 4 --- biogeochem/EDPatchDynamicsMod.F90 | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 3149ab5a0a..35dc81a5f9 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -3484,7 +3484,7 @@ subroutine insert_patch(currentSite, newPatch) ! !LOCAL VARIABLES: type (ed_patch_type), pointer :: currentPatch integer :: insert_method ! Temporary dev - logical :: found_landuselabel + logical :: found_landuselabel_match insert_method = 1 @@ -3495,27 +3495,30 @@ subroutine insert_patch(currentSite, newPatch) ! Insert new patch as the youngest patch in the group of patches with the same land use type. ! On a given site, the patches are grouped together by land use type. ! Option 1: The landuse type group order doesn't matter at all - ! Option 2: Abitrarily set the group order to numerical order with first being primaryland - ! Option 3: The order of the groups within the site doesn't matter, except that the older - ! patch group are primarylands. + ! Option 2: The order of the groups within the site doesn't matter, except that the older + ! Option 3: Abitrarily set the group order to numerical order with older being primaryland (similar to previous logic) + ! patch group are primarylands (similar to the previous logic) ! Option 4: landuse type order doesn't matter, only age if (insert_method .eq. 1) then - ! Option 1 + ! Option 1 if (currentPatch%land_use_label .ne. new_patch%land_use_label ) then - found_landuselabel = .false. - do while(associated(currentPatch) .and. .not. found_landuselabel) + ! If the current site youngest patch lutype doesn't match the new patch lutype + ! work through the list until you find the matching type. If a match is not + ! found, the currentPatch will be unassociated once it hits the end of the list + found_landuselabel_match = .false. + do while(associated(currentPatch) .and. .not. found_landuselabel_match) currentPatch => currentPatch%older if (associated(currentPatch)) then if (currentPatch%land_use_label .eq. new_patch%land_use_label) then - found_landuselabel = .true. + found_landuselabel_match = .true. endif endif end do if (associated(currentPatch)) then ! The case where we've found a patch type matching the new patch type. - ! In this case the new_patch will be the youngest patch for that - ! land use type + ! In this case insert the new_patch will as the youngest patch for that + ! land use type. new_patch%older => currentPatch new_patch%younger => currentPatch%younger currentPatch%younger%older => new_patch @@ -3530,7 +3533,8 @@ subroutine insert_patch(currentSite, newPatch) currentSite%oldest_patch => new_patch endif else - ! The case in which the first patch in the list matches the new patch type + ! In the case in which the youngest patch in the site list matches the new patch type, + ! immediately add that patch as the new youngest patch for that type and the whole list new_patch%older => currentPatch new_patch%younger => null() currentPatch%younger => new_patch @@ -3542,6 +3546,10 @@ subroutine insert_patch(currentSite, newPatch) ! Option 3 elseif (insert_method .eq. 4) then ! Option 4 + new_patch%older => currentPatch + new_patch%younger => null() + currentPatch%younger => new_patch + currentSite%youngest_patch => new_patch end if From f542db614c5a06bed468d50fb54308399043b279 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 8 Jun 2023 13:58:22 -0700 Subject: [PATCH 077/250] add other patch insertion options I also accidentally updated the patch object names to camelCase, which is what we actually want --- biogeochem/EDPatchDynamicsMod.F90 | 344 ++++++++++++++++++------------ 1 file changed, 204 insertions(+), 140 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 35dc81a5f9..94474254fc 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -437,9 +437,9 @@ subroutine spawn_patches( currentSite, bc_in) type (bc_in_type), intent(in) :: bc_in ! ! !LOCAL VARIABLES: - type (ed_patch_type) , pointer :: new_patch - ! type (ed_patch_type) , pointer :: new_patch_primary - ! type (ed_patch_type) , pointer :: new_patch_secondary + type (ed_patch_type) , pointer :: newPatch + ! type (ed_patch_type) , pointer :: newPatch_primary + ! type (ed_patch_type) , pointer :: newPatch_secondary type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type), pointer :: currentCohort type (ed_cohort_type), pointer :: nc @@ -565,24 +565,24 @@ subroutine spawn_patches( currentSite, bc_in) age = 0.0_r8 ! create an empty patch, to absorb newly disturbed area - allocate(new_patch) + allocate(newPatch) - call create_patch(currentSite, new_patch, age, & + call create_patch(currentSite, newPatch, age, & site_areadis, i_landusechange_receiverpatchlabel, i_nocomp_pft) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches ! and transfering in mass do el=1,num_elements - call new_patch%litter(el)%InitConditions(init_leaf_fines=0._r8, & + call newPatch%litter(el)%InitConditions(init_leaf_fines=0._r8, & init_root_fines=0._r8, & init_ag_cwd=0._r8, & init_bg_cwd=0._r8, & init_seed=0._r8, & init_seed_germ=0._r8) end do - new_patch%tallest => null() - new_patch%shortest => null() + newPatch%tallest => null() + newPatch%shortest => null() endif @@ -612,7 +612,7 @@ subroutine spawn_patches( currentSite, bc_in) areadis_gt_zero_if: if ( patch_site_areadis > nearzero ) then - if(.not.associated(new_patch))then + if(.not.associated(newPatch))then write(fates_log(),*) 'Patch spawning has attempted to point to' write(fates_log(),*) 'an un-allocated patch' call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -625,7 +625,7 @@ subroutine spawn_patches( currentSite, bc_in) if ( currentPatch%land_use_label .gt. primaryland .and. & (i_disturbance_type .lt. dtype_ilog) ) then - new_patch%age_since_anthro_disturbance = new_patch%age_since_anthro_disturbance + & + newPatch%age_since_anthro_disturbance = newPatch%age_since_anthro_disturbance + & currentPatch%age_since_anthro_disturbance * (patch_site_areadis / site_areadis) endif @@ -639,7 +639,7 @@ subroutine spawn_patches( currentSite, bc_in) currentPatch%burnt_frac_litter(:) = 0._r8 end if - call TransLitterNewPatch( currentSite, currentPatch, new_patch, patch_site_areadis) + call TransLitterNewPatch( currentSite, currentPatch, newPatch, patch_site_areadis) ! Transfer in litter fluxes from plants in various contexts of death and destruction @@ -648,16 +648,16 @@ subroutine spawn_patches( currentSite, bc_in) select case(i_disturbance_type) case (dtype_ilog) call logging_litter_fluxes(currentSite, currentPatch, & - new_patch, patch_site_areadis,bc_in) + newPatch, patch_site_areadis,bc_in) case (dtype_ifire) call fire_litter_fluxes(currentSite, currentPatch, & - new_patch, patch_site_areadis,bc_in) + newPatch, patch_site_areadis,bc_in) case (dtype_ifall) call mortality_litter_fluxes(currentSite, currentPatch, & - new_patch, patch_site_areadis,bc_in) + newPatch, patch_site_areadis,bc_in) case (dtype_ilandusechange) call landusechange_litter_fluxes(currentSite, currentPatch, & - new_patch, patch_site_areadis,bc_in, & + newPatch, patch_site_areadis,bc_in, & clearing_matrix(i_donorpatch_landuse_type,i_landusechange_receiverpatchlabel)) case default write(fates_log(),*) 'unknown disturbance mode?' @@ -669,13 +669,13 @@ subroutine spawn_patches( currentSite, bc_in) ! Copy any means or timers from the original patch to the new patch ! These values will inherit all info from the original patch ! -------------------------------------------------------------------------- - call new_patch%tveg24%CopyFromDonor(currentPatch%tveg24) - call new_patch%tveg_lpa%CopyFromDonor(currentPatch%tveg_lpa) - call new_patch%tveg_longterm%CopyFromDonor(currentPatch%tveg_longterm) + call newPatch%tveg24%CopyFromDonor(currentPatch%tveg24) + call newPatch%tveg_lpa%CopyFromDonor(currentPatch%tveg_lpa) + call newPatch%tveg_longterm%CopyFromDonor(currentPatch%tveg_longterm) ! -------------------------------------------------------------------------- - ! The newly formed patch from disturbance (new_patch), has now been given + ! The newly formed patch from disturbance (newPatch), has now been given ! some litter from dead plants and pre-existing litter from the donor patches. ! ! Next, we loop through the cohorts in the donor patch, copy them with @@ -697,11 +697,11 @@ subroutine spawn_patches( currentSite, bc_in) ! (Keeping as an example) ! Allocate running mean functions !allocate(nc%tveg_lpa) - !call nc%tveg_lpa%InitRMean(ema_lpa,init_value=new_patch%tveg_lpa%GetMean()) + !call nc%tveg_lpa%InitRMean(ema_lpa,init_value=newPatch%tveg_lpa%GetMean()) call zero_cohort(nc) - ! nc is the new cohort that goes in the disturbed patch (new_patch)... currentCohort + ! nc is the new cohort that goes in the disturbed patch (newPatch)... currentCohort ! is the curent cohort that stays in the donor patch (currentPatch) call copy_cohort(currentCohort, nc) @@ -1112,29 +1112,29 @@ subroutine spawn_patches( currentSite, bc_in) end select disttype_case ! Select disturbance mode cohort_n_gt_zero: if (nc%n > 0.0_r8) then - storebigcohort => new_patch%tallest - storesmallcohort => new_patch%shortest - if(associated(new_patch%tallest))then + storebigcohort => newPatch%tallest + storesmallcohort => newPatch%shortest + if(associated(newPatch%tallest))then tnull = 0 else tnull = 1 - new_patch%tallest => nc + newPatch%tallest => nc nc%taller => null() endif - if(associated(new_patch%shortest))then + if(associated(newPatch%shortest))then snull = 0 else snull = 1 - new_patch%shortest => nc + newPatch%shortest => nc nc%shorter => null() endif - nc%patchptr => new_patch - call insert_cohort(nc, new_patch%tallest, new_patch%shortest, & + nc%patchptr => newPatch + call insert_cohort(nc, newPatch%tallest, newPatch%shortest, & tnull, snull, storebigcohort, storesmallcohort) - new_patch%tallest => storebigcohort - new_patch%shortest => storesmallcohort + newPatch%tallest => storebigcohort + newPatch%shortest => storesmallcohort else ! Get rid of the new temporary cohort @@ -1181,7 +1181,7 @@ subroutine spawn_patches( currentSite, bc_in) call terminate_cohorts(currentSite, currentPatch, 2,16,bc_in) call sort_cohorts(currentPatch) - end if areadis_gt_zero_if ! if ( new_patch%area > nearzero ) then + end if areadis_gt_zero_if ! if ( newPatch%area > nearzero ) then end if patchlabel_matches_lutype_if @@ -1196,17 +1196,17 @@ subroutine spawn_patches( currentSite, bc_in) if ( site_areadis .gt. nearzero) then - call insert_patch(currentSite, new_patch) + call insert_patch(currentSite, newPatch) ! sort out the cohorts, since some of them may be so small as to need removing. ! the first call to terminate cohorts removes sparse number densities, ! the second call removes for all other reasons (sparse culling must happen ! before fusion) - call terminate_cohorts(currentSite, new_patch, 1,17, bc_in) - call fuse_cohorts(currentSite,new_patch, bc_in) - call terminate_cohorts(currentSite, new_patch, 2,17, bc_in) - call sort_cohorts(new_patch) + call terminate_cohorts(currentSite, newPatch, 1,17, bc_in) + call fuse_cohorts(currentSite,newPatch, bc_in) + call terminate_cohorts(currentSite, newPatch, 2,17, bc_in) + call sort_cohorts(newPatch) endif @@ -2319,7 +2319,7 @@ end subroutine landusechange_litter_fluxes ! ============================================================================ - subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) + subroutine create_patch(currentSite, newPatch, age, areap, label,nocomp_pft) use FatesInterfaceTypesMod, only : hlm_current_tod,hlm_current_date,hlm_reference_date @@ -2331,7 +2331,7 @@ subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) ! ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: currentSite - type(ed_patch_type), intent(inout), target :: new_patch + type(ed_patch_type), intent(inout), target :: newPatch real(r8), intent(in) :: age ! notional age of this patch in years real(r8), intent(in) :: areap ! initial area of this patch in m2. integer, intent(in) :: label ! anthropogenic disturbance label @@ -2347,31 +2347,31 @@ subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) integer :: el ! element loop index - allocate(new_patch%tr_soil_dir(hlm_numSWb)) - allocate(new_patch%tr_soil_dif(hlm_numSWb)) - allocate(new_patch%tr_soil_dir_dif(hlm_numSWb)) - allocate(new_patch%fab(hlm_numSWb)) - allocate(new_patch%fabd(hlm_numSWb)) - allocate(new_patch%fabi(hlm_numSWb)) - allocate(new_patch%sabs_dir(hlm_numSWb)) - allocate(new_patch%sabs_dif(hlm_numSWb)) - allocate(new_patch%fragmentation_scaler(currentSite%nlevsoil)) - - allocate(new_patch%tveg24) - call new_patch%tveg24%InitRMean(fixed_24hr,init_value=temp_init_veg,init_offset=real(hlm_current_tod,r8) ) - allocate(new_patch%tveg_lpa) - call new_patch%tveg_lpa%InitRmean(ema_lpa,init_value=temp_init_veg) - allocate(new_patch%tveg_longterm) - call new_patch%tveg_longterm%InitRmean(ema_longterm,init_value=temp_init_veg) + allocate(newPatch%tr_soil_dir(hlm_numSWb)) + allocate(newPatch%tr_soil_dif(hlm_numSWb)) + allocate(newPatch%tr_soil_dir_dif(hlm_numSWb)) + allocate(newPatch%fab(hlm_numSWb)) + allocate(newPatch%fabd(hlm_numSWb)) + allocate(newPatch%fabi(hlm_numSWb)) + allocate(newPatch%sabs_dir(hlm_numSWb)) + allocate(newPatch%sabs_dif(hlm_numSWb)) + allocate(newPatch%fragmentation_scaler(currentSite%nlevsoil)) + + allocate(newPatch%tveg24) + call newPatch%tveg24%InitRMean(fixed_24hr,init_value=temp_init_veg,init_offset=real(hlm_current_tod,r8) ) + allocate(newPatch%tveg_lpa) + call newPatch%tveg_lpa%InitRmean(ema_lpa,init_value=temp_init_veg) + allocate(newPatch%tveg_longterm) + call newPatch%tveg_longterm%InitRmean(ema_longterm,init_value=temp_init_veg) ! Litter ! Allocate, Zero Fluxes, and Initialize to "unset" values - allocate(new_patch%litter(num_elements)) + allocate(newPatch%litter(num_elements)) do el=1,num_elements - call new_patch%litter(el)%InitAllocate(numpft,currentSite%nlevsoil,element_list(el)) - call new_patch%litter(el)%ZeroFlux() - call new_patch%litter(el)%InitConditions(init_leaf_fines = fates_unset_r8, & + call newPatch%litter(el)%InitAllocate(numpft,currentSite%nlevsoil,element_list(el)) + call newPatch%litter(el)%ZeroFlux() + call newPatch%litter(el)%InitConditions(init_leaf_fines = fates_unset_r8, & init_root_fines = fates_unset_r8, & init_ag_cwd = fates_unset_r8, & init_bg_cwd = fates_unset_r8, & @@ -2379,66 +2379,66 @@ subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) init_seed_germ = fates_unset_r8) end do - call zero_patch(new_patch) !The nan value in here is not working?? + call zero_patch(newPatch) !The nan value in here is not working?? - new_patch%tallest => null() ! pointer to patch's tallest cohort - new_patch%shortest => null() ! pointer to patch's shortest cohort - new_patch%older => null() ! pointer to next older patch - new_patch%younger => null() ! pointer to next shorter patch + newPatch%tallest => null() ! pointer to patch's tallest cohort + newPatch%shortest => null() ! pointer to patch's shortest cohort + newPatch%older => null() ! pointer to next older patch + newPatch%younger => null() ! pointer to next shorter patch ! assign known patch attributes - new_patch%age = age - new_patch%age_class = 1 - new_patch%area = areap + newPatch%age = age + newPatch%age_class = 1 + newPatch%area = areap ! assign anthropgenic disturbance category and label - new_patch%land_use_label = label + newPatch%land_use_label = label if (label .gt. primaryland) then - new_patch%age_since_anthro_disturbance = age + newPatch%age_since_anthro_disturbance = age else - new_patch%age_since_anthro_disturbance = fates_unset_r8 + newPatch%age_since_anthro_disturbance = fates_unset_r8 endif - new_patch%nocomp_pft_label = nocomp_pft + newPatch%nocomp_pft_label = nocomp_pft ! This new value will be generated when the calculate disturbance ! rates routine is called. This does not need to be remembered or in the restart file. - new_patch%f_sun = 0._r8 - new_patch%ed_laisun_z(:,:,:) = 0._r8 - new_patch%ed_laisha_z(:,:,:) = 0._r8 - new_patch%ed_parsun_z(:,:,:) = 0._r8 - new_patch%ed_parsha_z(:,:,:) = 0._r8 - new_patch%fabi = 0._r8 - new_patch%fabd = 0._r8 - new_patch%tr_soil_dir(:) = 1._r8 - new_patch%tr_soil_dif(:) = 1._r8 - new_patch%tr_soil_dir_dif(:) = 0._r8 - new_patch%fabd_sun_z(:,:,:) = 0._r8 - new_patch%fabd_sha_z(:,:,:) = 0._r8 - new_patch%fabi_sun_z(:,:,:) = 0._r8 - new_patch%fabi_sha_z(:,:,:) = 0._r8 - new_patch%scorch_ht(:) = 0._r8 - new_patch%frac_burnt = 0._r8 - new_patch%litter_moisture(:) = 0._r8 - new_patch%fuel_eff_moist = 0._r8 - new_patch%livegrass = 0._r8 - new_patch%sum_fuel = 0._r8 - new_patch%fuel_bulkd = 0._r8 - new_patch%fuel_sav = 0._r8 - new_patch%fuel_mef = 0._r8 - new_patch%ros_front = 0._r8 - new_patch%effect_wspeed = 0._r8 - new_patch%tau_l = 0._r8 - new_patch%fuel_frac(:) = 0._r8 - new_patch%tfc_ros = 0._r8 - new_patch%fi = 0._r8 - new_patch%fd = 0._r8 - new_patch%ros_back = 0._r8 - new_patch%scorch_ht(:) = 0._r8 - new_patch%burnt_frac_litter(:) = 0._r8 - new_patch%total_tree_area = 0.0_r8 - new_patch%NCL_p = 1 + newPatch%f_sun = 0._r8 + newPatch%ed_laisun_z(:,:,:) = 0._r8 + newPatch%ed_laisha_z(:,:,:) = 0._r8 + newPatch%ed_parsun_z(:,:,:) = 0._r8 + newPatch%ed_parsha_z(:,:,:) = 0._r8 + newPatch%fabi = 0._r8 + newPatch%fabd = 0._r8 + newPatch%tr_soil_dir(:) = 1._r8 + newPatch%tr_soil_dif(:) = 1._r8 + newPatch%tr_soil_dir_dif(:) = 0._r8 + newPatch%fabd_sun_z(:,:,:) = 0._r8 + newPatch%fabd_sha_z(:,:,:) = 0._r8 + newPatch%fabi_sun_z(:,:,:) = 0._r8 + newPatch%fabi_sha_z(:,:,:) = 0._r8 + newPatch%scorch_ht(:) = 0._r8 + newPatch%frac_burnt = 0._r8 + newPatch%litter_moisture(:) = 0._r8 + newPatch%fuel_eff_moist = 0._r8 + newPatch%livegrass = 0._r8 + newPatch%sum_fuel = 0._r8 + newPatch%fuel_bulkd = 0._r8 + newPatch%fuel_sav = 0._r8 + newPatch%fuel_mef = 0._r8 + newPatch%ros_front = 0._r8 + newPatch%effect_wspeed = 0._r8 + newPatch%tau_l = 0._r8 + newPatch%fuel_frac(:) = 0._r8 + newPatch%tfc_ros = 0._r8 + newPatch%fi = 0._r8 + newPatch%fd = 0._r8 + newPatch%ros_back = 0._r8 + newPatch%scorch_ht(:) = 0._r8 + newPatch%burnt_frac_litter(:) = 0._r8 + newPatch%total_tree_area = 0.0_r8 + newPatch%NCL_p = 1 return @@ -3485,6 +3485,7 @@ subroutine insert_patch(currentSite, newPatch) type (ed_patch_type), pointer :: currentPatch integer :: insert_method ! Temporary dev logical :: found_landuselabel_match + logical :: found_primaryland insert_method = 1 @@ -3500,56 +3501,119 @@ subroutine insert_patch(currentSite, newPatch) ! patch group are primarylands (similar to the previous logic) ! Option 4: landuse type order doesn't matter, only age - if (insert_method .eq. 1) then - ! Option 1 - if (currentPatch%land_use_label .ne. new_patch%land_use_label ) then - ! If the current site youngest patch lutype doesn't match the new patch lutype - ! work through the list until you find the matching type. If a match is not - ! found, the currentPatch will be unassociated once it hits the end of the list + if (currentPatch%land_use_label .eq. newPatch%land_use_label ) then + ! Regardless of method, if the land use type of the youngest patch on the site + ! is a match to the new patch land use type, simply insert it as the new youngest + newPatch%older => currentPatch + newPatch%younger => null() + currentPatch%younger => newPatch + currentSite%youngest_patch => newPatch + else + ! If the current site youngest patch lutype doesn't match the new patch lutype + ! work through the list until you find the matching type. If a match is not + ! found, the currentPatch will be unassociated once it hits the end of the list + if (insert_method .eq. 1) then + ! Option 1 - order of lutype groups does not matter found_landuselabel_match = .false. do while(associated(currentPatch) .and. .not. found_landuselabel_match) currentPatch => currentPatch%older if (associated(currentPatch)) then - if (currentPatch%land_use_label .eq. new_patch%land_use_label) then + if (currentPatch%land_use_label .eq. newPatch%land_use_label) then found_landuselabel_match = .true. endif endif end do if (associated(currentPatch)) then ! The case where we've found a patch type matching the new patch type. - ! In this case insert the new_patch will as the youngest patch for that + ! In this case insert the newPatch will as the youngest patch for that ! land use type. - new_patch%older => currentPatch - new_patch%younger => currentPatch%younger - currentPatch%younger%older => new_patch - currentPatch%younger => new_patch + newPatch%older => currentPatch + newPatch%younger => currentPatch%younger + currentPatch%younger%older => newPatch + currentPatch%younger => newPatch else ! The case in which we get to the end of the list and haven't found ! a landuse type match. If this is the case, simply add the new patch ! to the end of the list - new_patch%older => null() - new_patch%younger => currentSite%oldest_patch - currentSite%oldest_patch%older => new_patch - currentSite%oldest_patch => new_patch + newPatch%older => null() + newPatch%younger => currentSite%oldest_patch + currentSite%oldest_patch%older => newPatch + currentSite%oldest_patch => newPatch endif - else - ! In the case in which the youngest patch in the site list matches the new patch type, - ! immediately add that patch as the new youngest patch for that type and the whole list - new_patch%older => currentPatch - new_patch%younger => null() - currentPatch%younger => new_patch - currentSite%youngest_patch => new_patch - endif - elseif (insert_method .eq. 2) then - ! Option 2 - elseif (insert_method .eq. 3) then - ! Option 3 - elseif (insert_method .eq. 4) then - ! Option 4 - new_patch%older => currentPatch - new_patch%younger => null() - currentPatch%younger => new_patch - currentSite%youngest_patch => new_patch + elseif (insert_method .eq. 2) then + ! Option 2 - primaryland group must be on the oldest end + found_landuselabel_match = .false. + do while(associated(currentPatch) .and. .not. found_landuselabel_match) + currentPatch => currentPatch%older + if (associated(currentPatch)) then + if (currentPatch%land_use_label .eq. newPatch%land_use_label) then + found_landuselabel_match = .true. + endif + endif + end do + if (associated(currentPatch)) then + ! The case where we've found a patch type matching the new patch type. + ! In this case insert the newPatch will as the youngest patch for that + ! land use type. + newPatch%older => currentPatch + newPatch%younger => currentPatch%younger + currentPatch%younger%older => newPatch + currentPatch%younger => newPatch + else + if (newPatch%land_use_label .eq. primaryland) then + ! The case in which we get to the end of the list and haven't found + ! a landuse type match. If this is the case, add it to the oldest side + ! if primarland + newPatch%older => null() + newPatch%younger => currentSite%oldest_patch + currentSite%oldest_patch%older => newPatch + currentSite%oldest_patch => newPatch + else + ! If the new patch land use type is not primary land and we are at the + ! oldest end of the list, add it to the beginning + newPatch%older => currentPatch + newPatch%younger => null() + currentPatch%younger => newPatch + currentSite%youngest_patch => newPatch + endif + elseif (insert_method .eq. 3) then + ! Option 3 - groups are numerically ordered with primaryland group starting at oldest end. + ! If the youngest patch land use label number is greater than the new + ! patch land use label number, the new patch must be inserted somewhere + ! in between oldest and youngest + found_landuselabel_match = .false. + do while(associated(currentPatch) .and. .not. found_landuselabel_match) + currentPatch => currentPatch%older + if (associated(currentPatch)) then + if (newPatch%land_use_label .eq. currentPatch%land_use_label .or. & + newPatch%land_use_label .gt. currentPatch%land_use_label) then + found_landuselabel_match = .true. + endif + endif + end do + if (associated(currentPatch)) then + ! The case where we've found a patch type matching the new patch type. + ! In this case insert the newPatch will as the youngest patch for that + ! land use type. + newPatch%older => currentPatch + newPatch%younger => currentPatch%younger + currentPatch%younger%older => newPatch + currentPatch%younger => newPatch + else + ! In the case were we get to the end, the new patch + ! must be numerically the smallest, so put it at the oldest position + newPatch%older => null() + newPatch%younger => currentSite%oldest_patch + currentSite%oldest_patch%older => newPatch + currentSite%oldest_patch => newPatch + endif + elseif (insert_method .eq. 4) then + ! Option 4 - always add the new patch as the youngest regardless of lutype match + newPatch%older => currentPatch + newPatch%younger => null() + currentPatch%younger => newPatch + currentSite%youngest_patch => newPatch + end if end if From c325d72364a5787b80febc42df5963a1c70e0c4b Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 8 Jun 2023 14:29:49 -0700 Subject: [PATCH 078/250] fix missing end if --- biogeochem/EDPatchDynamicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 94474254fc..09508e90a6 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -3485,7 +3485,6 @@ subroutine insert_patch(currentSite, newPatch) type (ed_patch_type), pointer :: currentPatch integer :: insert_method ! Temporary dev logical :: found_landuselabel_match - logical :: found_primaryland insert_method = 1 @@ -3576,6 +3575,7 @@ subroutine insert_patch(currentSite, newPatch) currentPatch%younger => newPatch currentSite%youngest_patch => newPatch endif + endif elseif (insert_method .eq. 3) then ! Option 3 - groups are numerically ordered with primaryland group starting at oldest end. ! If the youngest patch land use label number is greater than the new From 68e2eff7ce477c64ecccf7cbb9e65143f0a66314 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 8 Jun 2023 19:50:46 -0400 Subject: [PATCH 079/250] remote erroneous pointer attribute from currentSite --- biogeochem/EDPatchDynamicsMod.F90 | 16 +++++++--------- biogeochem/FatesLandUseChangeMod.F90 | 2 +- 2 files changed, 8 insertions(+), 10 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 09508e90a6..2b54a9f859 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1,5 +1,5 @@ -module EDPatchDynamicsMod +module EDPatchDynamicsMod ! ============================================================================ ! Controls formation, creation, fusing and termination of patch level processes. ! ============================================================================ @@ -1196,7 +1196,7 @@ subroutine spawn_patches( currentSite, bc_in) if ( site_areadis .gt. nearzero) then - call insert_patch(currentSite, newPatch) + call InsertPatch(currentSite, newPatch) ! sort out the cohorts, since some of them may be so small as to need removing. ! the first call to terminate cohorts removes sparse number densities, @@ -3468,17 +3468,15 @@ end subroutine get_frac_site_primary ! ===================================================================================== - subroutine insert_patch(currentSite, newPatch) + subroutine InsertPatch(currentSite, newPatch) ! !DESCRIPTION: ! Insert patch into linked list ! ! !USES: - use EDTypesMod , only : ed_site_type - use EDTypesMod , only : ed_patch_type ! ! !ARGUMENTS: - type (ed_site_type), intent(inout), pointer :: currentSite + type (ed_site_type), intent(inout) :: currentSite type (ed_patch_type), intent(inout), pointer :: newPatch ! !LOCAL VARIABLES: @@ -3486,10 +3484,10 @@ subroutine insert_patch(currentSite, newPatch) integer :: insert_method ! Temporary dev logical :: found_landuselabel_match - insert_method = 1 + insert_method = 4 ! Start from the youngest patch and work to oldest - currentPatch => currentSite%youngest_patch + currentPatch => currentSite%youngest_patch ! TODO: Test alternate methods ! Insert new patch as the youngest patch in the group of patches with the same land use type. @@ -3617,6 +3615,6 @@ subroutine insert_patch(currentSite, newPatch) end if - end subroutine insert_patch + end subroutine InsertPatch end module EDPatchDynamicsMod diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index 89b262ac12..6adf6d4852 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -288,7 +288,7 @@ subroutine CheckLUHData(luh_vector,modified_flag) luh_vector(primaryland) = 1._r8 end if modified_flag = .true. - write(fates_log(),*) 'WARNING: land use state is all NaN; setting state as all primary forest.' + !write(fates_log(),*) 'WARNING: land use state is all NaN; setting state as all primary forest.' ! GL DIAG else if (any(isnan(luh_vector))) then if (any(.not. isnan(luh_vector))) then write(fates_log(),*) 'ERROR: land use vector has NaN' From f13e621adacadc2dfc226d0d0edff92368ee83e0 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 8 Jun 2023 16:59:03 -0700 Subject: [PATCH 080/250] correct insert patch option 2 --- biogeochem/EDPatchDynamicsMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 2b54a9f859..cfe0bd509e 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -3484,7 +3484,7 @@ subroutine InsertPatch(currentSite, newPatch) integer :: insert_method ! Temporary dev logical :: found_landuselabel_match - insert_method = 4 + insert_method = 2 ! Start from the youngest patch and work to oldest currentPatch => currentSite%youngest_patch @@ -3568,9 +3568,9 @@ subroutine InsertPatch(currentSite, newPatch) else ! If the new patch land use type is not primary land and we are at the ! oldest end of the list, add it to the beginning - newPatch%older => currentPatch + newPatch%older => currentSite%youngest_patch newPatch%younger => null() - currentPatch%younger => newPatch + currentSite%youngest_patch%younger => newPatch currentSite%youngest_patch => newPatch endif endif From bc91bd6ad6e5be0f454c2933947cdc6921200694 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 8 Jun 2023 17:10:11 -0700 Subject: [PATCH 081/250] initial commmit for patch termination update --- biogeochem/EDPatchDynamicsMod.F90 | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index bb002f6639..70f89c2823 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -3120,6 +3120,7 @@ subroutine terminate_patches(currentSite) ! You should had fused integer :: count_cycles logical :: gotfused + logical :: current_patch_is_youngest_lutype real(r8) areatot ! variable for checking whether the total patch area is wrong. !--------------------------------------------------------------------- @@ -3156,13 +3157,19 @@ subroutine terminate_patches(currentSite) else nocomp_if + ! Determine if the current patch is the youngest in the land use grouping + ! If the 'younger' patch is a different land use then the current is the youngest + ! per the InsertPatch subroutine. That said it could also be the only patch and + ! also the oldest. Should we handle that distinction? + current_patch_is_youngest_lutype = .false. + if (currentPatch%younger%land_use_label .ne. currentPatch%land_use_label) current_patch_is_youngest_lutype = .true. + ! Even if the patch area is small, avoid fusing it into its neighbor ! if it is the youngest of all patches. We do this in attempts to maintain ! a discrete patch for very young patches ! However, if the patch to be fused is excessivlely small, then fuse ! at all costs. If it is not fused, it will make - - notyoungest_if: if ( .not.associated(currentPatch,currentSite%youngest_patch) .or. & + notyoungest_if: if ( .not. current_patch_is_youngest_lutype .or. & currentPatch%area <= min_patch_area_forced ) then gotfused = .false. From aa7804b1555ce8ea2a371c38fb1bc82268519327 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 8 Jun 2023 22:14:40 -0700 Subject: [PATCH 082/250] add additional comments clarifying potential patch fusion --- biogeochem/EDPatchDynamicsMod.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 70f89c2823..1fac031ebc 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -3204,6 +3204,8 @@ subroutine terminate_patches(currentSite) ! and then allow them to fuse together. ! We also assigned the age since disturbance value to be the younger (donor) patch to avoid combining a valid ! age with fates_unset_r8 (i.e. the age for primaryland) in the fuse_2_patches procedure + ! Note that given the grouping of landuse types in the linked list, this could result in very small patches + ! being fused to much larger patches currentPatch%land_use_label = olderPatch%land_use_label currentPatch%age_since_anthro_disturbance = olderPatch%age_since_anthro_disturbance call fuse_2_patches(currentSite, olderPatch, currentPatch) @@ -3234,6 +3236,8 @@ subroutine terminate_patches(currentSite) ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its younger sibling ! We also assigned the age since disturbance value to be the younger (donor) patch to avoid combining a valid ! age with fates_unset_r8 (i.e. the age for primaryland) in the fuse_2_patches procedure + ! Note that given the grouping of landuse types in the linked list, this could result in very small patches + ! being fused to much larger patches currentPatch%land_use_label = youngerPatch%land_use_label currentPatch%age_since_anthro_disturbance = youngerPatch%age_since_anthro_disturbance call fuse_2_patches(currentSite, youngerPatch, currentPatch) From ad8701bc0e6e2d5052b6273c27d0f281fcf1ca33 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 9 Jun 2023 01:21:07 -0400 Subject: [PATCH 083/250] add missing gotfused flag --- biogeochem/EDPatchDynamicsMod.F90 | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index bb002f6639..5d42c154ad 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1,4 +1,4 @@ -module EDPatchDynamicsMod +odule EDPatchDynamicsMod ! ============================================================================ ! Controls formation, creation, fusing and termination of patch level processes. @@ -3218,9 +3218,7 @@ subroutine terminate_patches(currentSite) call fuse_2_patches(currentSite, youngerPatch, currentPatch) ! The fusion process has updated the "younger" pointer on currentPatch - - ! GL: ADD MISSING GOTFUSED? - !gotfused = .true. + gotfused = .true. else distlabel_2_if if (count_cycles .gt. 0) then ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, From 5a2f8188d5de1da453bc04bdbb6ef8b6968c8420 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 8 Jun 2023 23:23:34 -0700 Subject: [PATCH 084/250] correct typo --- biogeochem/EDPatchDynamicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 5d42c154ad..6dfa501d83 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1,4 +1,4 @@ -odule EDPatchDynamicsMod +module EDPatchDynamicsMod ! ============================================================================ ! Controls formation, creation, fusing and termination of patch level processes. From 6ccedd5fef3e95a55413389c32c13de28fd49637 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 12 Jun 2023 10:41:41 -0400 Subject: [PATCH 085/250] removed cold init argument for radiation driver start --- radiation/FatesRadiationDriveMod.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index 963742af16..ab9c589680 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -1146,7 +1146,7 @@ end subroutine PatchNormanRadiation ! ====================================================================================== -subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out,cold_init) +subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) implicit none @@ -1155,7 +1155,6 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out,cold_init) type(ed_site_type),intent(inout),target :: sites(nsites) type(bc_in_type),intent(in) :: bc_in(nsites) type(bc_out_type),intent(inout) :: bc_out(nsites) - logical,intent(in) :: cold_init ! If true, then we have not run the solver yet ! locals type (ed_patch_type),pointer :: cpatch ! c"urrent" patch From 783639bed48511ffddee475acd9a7ad5600b12ec Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 19 Jun 2023 09:34:49 -0600 Subject: [PATCH 086/250] bug fix related to two-stream radiation updates --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 08ba77d4cd..33d672602a 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -1326,13 +1326,17 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in gstoma = 0._r8 do sunsha = 1,2 + ! Electron transport rate for C3 plants. ! Convert par from W/m2 to umol photons/m**2/s using the factor 4.6 ! Convert from units of par absorbed per unit ground area to par ! absorbed per unit leaf area. + ! The 0.5 term here accounts for half of the light going to photosystem + ! 2, as mentioned in Biochemical models of leaf photosynthesis + ! (von Caemmerer) and Farquhar 1980 if(sunsha == 1)then !sunlit - qabs = parsun_lsl * qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 + qabs = parsun_lsl * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 else qabs = parsha_lsl * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 end if From 8e34f39f9dee0eb3a72238c6b1298e2649a46a4a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 23 Jun 2023 11:57:59 -0600 Subject: [PATCH 087/250] Various updates and fixes to two-stream, including error checking and dumping --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 12 +- main/FatesHistoryInterfaceMod.F90 | 3 +- radiation/FatesRadiationDriveMod.F90 | 60 +++++---- radiation/FatesRadiationMemMod.F90 | 2 +- radiation/FatesTwoStreamInterfaceMod.F90 | 46 ++++--- radiation/TwoStreamMLPEMod.F90 | 139 ++++++++++++++++----- 6 files changed, 177 insertions(+), 85 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 33d672602a..c38d9e553a 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -443,19 +443,17 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) cohort_vaitop(iv), & cohort_vaibot(iv), & cohort_layer_elai(iv), & - cohort_layer_esai(iv))!, & - !cohort_layer_tlai(iv), & - ! cohort_layer_tsai(iv)) + cohort_layer_esai(iv)) end do cohort_elai = sum(cohort_layer_elai(1:currentCohort%nv)) cohort_esai = sum(cohort_layer_esai(1:currentCohort%nv)) else - cohort_layer_elai(1:nv) = 0._r8 - cohort_layer_esai(1:nv) = 0._r8 - cohort_vaitop(1:nv) = 0._r8 - cohort_vaibot(1:nv) = 0._r8 + cohort_layer_elai(:) = 0._r8 + cohort_layer_esai(:) = 0._r8 + cohort_vaitop(:) = 0._r8 + cohort_vaibot(:) = 0._r8 cohort_elai = 0._r8 cohort_esai = 0._r8 end if diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index bc86b7ae45..492b8e38fe 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -4646,11 +4646,12 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep site_area_veg_inv = site_area_veg_inv + cpatch%total_canopy_area cpatch => cpatch%younger end do !patch loop - site_area_veg_inv = 1._r8/site_area_veg_inv ! If there is no vegetation, go to the next site if(site_area_veg_inv < nearzero) cycle do_sites + site_area_veg_inv = 1._r8/site_area_veg_inv + io_si = sites(s)%h_gid ipa = 0 diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index ab9c589680..834ebfb5ef 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -13,6 +13,7 @@ module FatesRadiationDriveMod use EDTypesMod , only : ed_patch_type, ed_site_type use EDTypesMod , only : maxpft use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : fates_unset_r8 use FatesConstantsMod , only : itrue use FatesConstantsMod , only : pi_const use FatesConstantsMod , only : nocomp_bareground @@ -88,13 +89,6 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) integer :: ifp ! patch loop counter integer :: ib ! radiation broad band counter type(ed_patch_type), pointer :: currentPatch ! patch pointer - real(r8) :: Rdiff_up_atm_beam ! Upwelling diffuse radiation at top from beam scattering [W/m2 ground] - real(r8) :: Rdiff_up_atm_diff ! Upwelling diffuse radiation at top from diffuse scattering [W/m2 ground] - real(r8) :: Rbeam_can_abs ! Total beam radiation absorbed by the canopy [W/m2 ground] - real(r8) :: Rdiff_can_abs ! Total diffuse radiation absorbed by the canopy [W/m2 ground] - real(r8) :: Rbeam_dn_grnd_beam ! Average beam radiation at ground [W/m2 ground] - real(r8) :: Rdiff_dn_grnd_beam ! Average downward diffuse radiation at ground due to beam sourcing [W/m2 ground] - real(r8) :: Rdiff_dn_grnd_diff ! Average downward diffuse radiation at ground from diffuse sourcing [W/m2 ground] !----------------------------------------------------------------------- ! ------------------------------------------------------------------------------- ! TODO (mv, 2014-10-29) the filter here is different than below @@ -139,32 +133,25 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) call currentPatch%twostr%CanopyPrep(bc_in(s)%fcansno_pa(ifp)) call currentPatch%twostr%ZenithPrep(bc_in(s)%coszen_pa(ifp)) end if - - if_zenith_flag: if(currentPatch%solar_zenith_flag )then - bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%fabd_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM - bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM - bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM + if_zenith_flag: if(currentPatch%solar_zenith_flag )then if_nrad: if (maxval(currentPatch%nrad(1,:))==0)then !there are no leaf layers in this patch. it is effectively bare ground. ! no radiation is absorbed - bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 - bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 + currentPatch%radiation_error = 0.0_r8 do ib = 1,hlm_numSWb bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) + bc_out(s)%fabd_parb(ifp,ib) = 0.0_r8 + bc_out(s)%fabi_parb(ifp,ib) = 0.0_r8 bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 bc_out(s)%ftid_parb(ifp,ib)= 0.0_r8 bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 enddo - + else if_solver: if(rad_solver.eq.norman_solver) then @@ -189,7 +176,7 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) twostr%band(ib)%albedo_grnd_diff = bc_in(s)%albgr_dif_rb(ib) twostr%band(ib)%albedo_grnd_beam = bc_in(s)%albgr_dir_rb(ib) - + call twostr%Solve(ib, & ! in normalized_upper_boundary, & ! in 1.0_r8,1.0_r8, & ! in @@ -201,11 +188,35 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) bc_out(s)%ftid_parb(ifp,ib), & ! out bc_out(s)%ftii_parb(ifp,ib)) + if(debug) then + currentPatch%twostr%band(ib)%Rbeam_atm = 1._r8 + currentPatch%twostr%band(ib)%Rdiff_atm = 1._r8 + call CheckPatchRadiationBalance(currentPatch, sites(s)%snow_depth, & + ib, bc_out(s)%fabd_parb(ifp,ib),bc_out(s)%fabi_parb(ifp,ib)) + currentPatch%twostr%band(ib)%Rbeam_atm = fates_unset_r8 + currentPatch%twostr%band(ib)%Rdiff_atm = fates_unset_r8 + + if(bc_out(s)%fabi_parb(ifp,ib)>1.0 .or. bc_out(s)%fabd_parb(ifp,ib)>1.0)then + write(fates_log(),*) 'absorbed fraction > 1.0?' + write(fates_log(),*) ifp,ib,bc_out(s)%fabi_parb(ifp,ib),bc_out(s)%fabd_parb(ifp,ib) + call twostr%Dump(ib,bc_in(s)%coszen_pa(ifp),lat=sites(s)%lat,lon=sites(s)%lon) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + end do end associate end if if_solver end if if_nrad + else + bc_out(s)%albd_parb(ifp,:) = 1._r8 + bc_out(s)%albi_parb(ifp,:) = 1._r8 + bc_out(s)%fabi_parb(ifp,:) = 0._r8 + bc_out(s)%fabd_parb(ifp,:) = 0._r8 + bc_out(s)%ftdd_parb(ifp,:) = 0._r8 + bc_out(s)%ftid_parb(ifp,:) = 0._r8 + bc_out(s)%ftii_parb(ifp,:) = 0._r8 endif if_zenith_flag end if if_notbareground @@ -721,14 +732,13 @@ subroutine PatchNormanRadiation (currentPatch, & tran_dif(L,ft,iv,ib) * lai_change(L,ft,iv)/ftweight(L,ft,1) Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - !nb is this the right constuction? + !nb is this the right constuction? ! the radiation that hits the empty space is not reflected. else Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * ftweight(L,ft,iv) Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * (1.0_r8-ftweight(L,ft,iv)) endif end do - weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) !instance where the first layer ftweight is used a proxy for the whole column. FTWA endif !present @@ -1189,7 +1199,6 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) ! ifp=1 is the first vegetated patch. ifp=ifp+1 - ! If there is no sun out, we have a trivial solution if_zenithflag: if( .not.cpatch%solar_zenith_flag ) then @@ -1325,10 +1334,7 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) bc_out(s)%fsun_pa(ifp), & bc_out(s)%laisun_pa(ifp), & bc_out(s)%laisha_pa(ifp)) - - call CheckPatchRadiationBalance(cpatch, sites(s)%snow_depth, ivis,bc_out(s)%fabd_parb(ifp,ivis), bc_out(s)%fabi_parb(ifp,ivis)) - call CheckPatchRadiationBalance(cpatch, sites(s)%snow_depth, inir,bc_out(s)%fabd_parb(ifp,inir), bc_out(s)%fabi_parb(ifp,inir)) - + associate(twostr => cpatch%twostr) do cl = 1,twostr%n_lyr diff --git a/radiation/FatesRadiationMemMod.F90 b/radiation/FatesRadiationMemMod.F90 index b0c208e5a6..f41a18e455 100644 --- a/radiation/FatesRadiationMemMod.F90 +++ b/radiation/FatesRadiationMemMod.F90 @@ -16,7 +16,7 @@ Module FatesRadiationMemMod integer, parameter, public :: norman_solver = 1 integer, parameter, public :: twostr_solver = 2 - integer, parameter, public :: rad_solver = norman_solver + integer, parameter, public :: rad_solver = twostr_solver integer, parameter, public :: num_rad_stream_types = 2 ! The number of radiation streams used (direct/diffuse) diff --git a/radiation/FatesTwoStreamInterfaceMod.F90 b/radiation/FatesTwoStreamInterfaceMod.F90 index 2da6917a66..bfc8a3971b 100644 --- a/radiation/FatesTwoStreamInterfaceMod.F90 +++ b/radiation/FatesTwoStreamInterfaceMod.F90 @@ -196,12 +196,19 @@ subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) site%snow_depth, & vai_top, vai_bot, & elai_cohort,esai_cohort) - - twostr%scelg(ican,n_col(ican))%pft = ft + + ! Its possible that this layer is covered by snow + ! if so, then just consider it an air layer + if((elai_cohort+esai_cohort)>nearzero)then + twostr%scelg(ican,n_col(ican))%pft = ft + else + twostr%scelg(ican,n_col(ican))%pft = air_ft + end if + twostr%scelg(ican,n_col(ican))%area = cohort%c_area/patch%total_canopy_area twostr%scelg(ican,n_col(ican))%lai = elai_cohort twostr%scelg(ican,n_col(ican))%sai = esai_cohort - + ! Cohort needs to know which column its in cohort%twostr_col = n_col(ican) @@ -238,10 +245,11 @@ subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) twostr%scelg(ican,1)%lai = twostr%scelg(ican,1)%lai / area_ratio twostr%scelg(ican,1)%sai = twostr%scelg(ican,1)%sai / area_ratio - - + write(fates_log(),*) 'overfull areas' + call twostr%Dump(1,coszen_pa(ifp),lat=site%lat,lon=site%lon) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + end do ! Go ahead an temporarily squeeze crown areas @@ -348,7 +356,6 @@ subroutine CheckPatchRadiationBalance(patch, snow_depth, ib, fabd, fabi) ! absorbed radiation, then compare the amount absorbed ! to the fraction the solver calculated - type(ed_patch_type) :: patch integer :: ib ! broadband index real(r8) :: snow_depth @@ -407,7 +414,8 @@ subroutine CheckPatchRadiationBalance(patch, snow_depth, ib, fabd, fabi) if( abs(check_fab-in_fab) > in_fab*10._r8*rel_err_thresh ) then write(fates_log(),*)'Absorbed radiation didnt balance after cohort sum' - write(fates_log(),*) ib,in_fab,check_fab + write(fates_log(),*) ib,in_fab,check_fab,snow_depth + call twostr%Dump(ib,patch%solar_zenith_angle) call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -454,12 +462,16 @@ subroutine FatesGetCohortAbsRad(patch,cohort,ib,vaitop,vaibot,cohort_elai,cohort associate(scelg => patch%twostr%scelg(cohort%canopy_layer,cohort%twostr_col), & scelb => patch%twostr%band(ib)%scelb(cohort%canopy_layer,cohort%twostr_col) ) - evai_cvai = (scelg%lai+scelg%sai)/(cohort_elai+cohort_esai) - - if(abs(evai_cvai-1._r8)>1.e-8_r8)then - print*,"EVAI_CVAI: ",evai_cvai - stop + if((cohort_elai+cohort_esai) this%scelg(ican,icol), & + scelb => this%band(ib)%scelb(ican,icol)) + write(log_unit,*) '--',ican,icol,'--' + write(log_unit,*) 'pft:',scelg%pft + write(log_unit,*) 'area: ',scelg%area + write(log_unit,*) 'lai,sai: ',scelg%lai,scelg%sai + write(log_unit,*) 'Kb: ',scelg%Kb + write(log_unit,*) 'Kb leaf: ',scelg%Kb_leaf + write(log_unit,*) 'Kd: ',scelg%Kd + write(log_unit,*) 'Rb0: ',scelb%Rbeam0 + write(log_unit,*) 'om: ',scelb%om + write(log_unit,*) 'betad: ',scelb%betad + write(log_unit,*) 'betab:',scelb%betab + write(log_unit,*) 'a: ',scelb%a + this%band(ib)%Rbeam_atm = 1.0_r8 + this%band(ib)%Rdiff_atm = 1.0_r8 + write(log_unit,*)'RDiff Down @ bottom: ',this%GetRdDn(ican,icol,ib,scelg%lai+scelg%sai) + write(log_unit,*)'RDiff Up @ bottom: ',this%GetRdUp(ican,icol,ib,scelg%lai+scelg%sai) + write(log_unit,*)'Rbeam @ bottom: ',this%GetRb(ican,icol,ib,scelg%lai+scelg%sai) + end associate + end do do_col + end do do_can + + end subroutine Dump + + ! ================================================================================================ subroutine ParamPrep() @@ -693,9 +748,17 @@ subroutine CanopyPrep(this,frac_snow) ! Mean element transmission coefficients w/o snow effects - if(ft==0) then + if(ft==air_ft) then scelg%Kd = k_air else + if(debug)then + if(vai this%band(ib)%scelb(ican,icol)) - if (ft==0) then + if (ft==air_ft) then scelb%om = om_air scelb%betad = beta_air @@ -738,6 +801,15 @@ subroutine CanopyPrep(this,frac_snow) om_snow(ib)*betad_snow(ib)*this%frac_snow scelb%betad = betad_om / scelb%om + + if(debug)then + if(scelb%betad /= scelb%betad)then + write(log_unit,*)"nans in canopy prep" + write(log_unit,*) ib,ican,icol,ft,scelb%betad,scelb%om,lai,sai,this%frac_snow,om_snow(ib),vai,om_veg + write(log_unit,*)"TwoStreamMLPEMod.F90:CanopyPrep" + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if end if end associate @@ -804,7 +876,7 @@ subroutine ZenithPrep(this,cosz) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - cosz = max(nearzero,cosz) + cosz = max(0.001,cosz) do_ican: do ican = 1,this%n_lyr do_ical: do icol = 1,this%n_col(ican) @@ -812,7 +884,7 @@ subroutine ZenithPrep(this,cosz) associate(ft => this%scelg(ican,icol)%pft, & scelg => this%scelg(ican,icol)) - if(ft==0)then + if(ft==air_ft)then ! Simple provisions for a ghost element (air) scelg%Kb_leaf = k_air scelg%Kb = k_air @@ -849,7 +921,7 @@ subroutine ZenithPrep(this,cosz) associate( scelb => this%band(ib)%scelb(ican,icol) ) - if(ft==0)then + if(ft==air_ft)then ! Simple provisions for a ghost element (air) scelb%betab = beta_air @@ -979,7 +1051,8 @@ subroutine Solve(this, ib, & real(r8) :: OMEGA(200,200) real(r8) :: TAU(200) real(r8) :: LAMBDA(200) - + integer :: ipiv(200) + integer :: isol ! Solution index loop (beam, beam+diff) integer :: ican ! Loop index for canopy layers integer :: ibot ! layer index for top side of layer divide @@ -1218,8 +1291,8 @@ subroutine Solve(this, ib, & this%band(ib)%Rdiff_atm = 1.0_r8 end if - if(n_eq>100)then - write(log_unit,*)"NEED A BIGGER MATRIX" + if(n_eq>200)then + write(log_unit,*)"NEED A BIGGER MATRIX, n_eq:",n_eq call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1406,14 +1479,22 @@ subroutine Solve(this, ib, & ! Solution borrowed from Greg Lemieux's usage during FATES canopy trimming: ! Compute the optimum size of the work array - lwork = -1 ! Ask dgels to compute optimal number of entries for work - call dgels(trans, n_eq, n_eq, 1, OMEGA(1:n_eq,1:n_eq), n_eq, LAMBDA(1:n_eq), n_eq, work, lwork, info) - lwork = int(work(1)) ! Pick the optimum. TBD, can work(1) come back with greater than work size? + + call dgesv(n_eq, 1, OMEGA(1:n_eq,1:n_eq), n_eq, ipiv(1:n_eq), LAMBDA(1:n_eq), n_eq, info) + + !lwork = -1 ! Ask dgels to compute optimal number of entries for work + !call dgels(trans, n_eq, n_eq, 1, OMEGA(1:n_eq,1:n_eq), n_eq, LAMBDA(1:n_eq), n_eq, work, lwork, info) + !lwork = int(work(1)) ! Pick the optimum. TBD, can work(1) come back with greater than work size? ! Compute the minimum of 2-norm of of the least squares fit to solve for X ! Note that dgels returns the solution by overwriting the LAMBDA array. ! The result has the form: X = [b; m] - call dgels(trans, n_eq, n_eq, 1, OMEGA(1:n_eq,1:n_eq), n_eq, LAMBDA(1:n_eq), n_eq, work, lwork, info) + !call dgels(trans, n_eq, n_eq, 1, OMEGA(1:n_eq,1:n_eq), n_eq, LAMBDA(1:n_eq), n_eq, work, lwork, info) + + if(info.ne.0)then + write(log_unit,*) 'Could not find a solution via dgesv' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if ! Save the solution terms From 521141204a1dcdce8d09db5ec4a9b3361ac5b4d6 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 23 Jun 2023 11:58:23 -0600 Subject: [PATCH 088/250] Fix to the restart order issue --- main/FatesRestartInterfaceMod.F90 | 130 +++++++++++++++--------------- 1 file changed, 65 insertions(+), 65 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index e8a67548c5..55f84857d6 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -2032,6 +2032,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_cacls= io_idx_co_1st io_idx_si_cdsc = io_idx_co_1st io_idx_si_cdpf = io_idx_co_1st + io_idx_si_scpf = io_idx_co_1st + io_idx_si_pft = io_idx_co_1st ! recruitment rate do i_pft = 1,numpft @@ -2046,6 +2048,32 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_area_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%area_pft(i_pft) end do + do i_scls = 1, nlevsclass + do i_pft = 1, numpft + rio_fmortrate_cano_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_canopy(i_scls, i_pft) + rio_fmortrate_usto_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_ustory(i_scls, i_pft) + rio_imortrate_siscpf(io_idx_si_scpf) = sites(s)%imort_rate(i_scls, i_pft) + rio_fmortrate_crown_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_crown(i_scls, i_pft) + rio_fmortrate_cambi_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_cambial(i_scls, i_pft) + rio_termnindiv_cano_siscpf(io_idx_si_scpf) = sites(s)%term_nindivs_canopy(i_scls,i_pft) + rio_termnindiv_usto_siscpf(io_idx_si_scpf) = sites(s)%term_nindivs_ustory(i_scls,i_pft) + rio_growflx_fusion_siscpf(io_idx_si_scpf) = sites(s)%growthflux_fusion(i_scls, i_pft) + rio_abg_term_flux_siscpf(io_idx_si_scpf) = sites(s)%term_abg_flux(i_scls, i_pft) + rio_abg_imort_flux_siscpf(io_idx_si_scpf) = sites(s)%imort_abg_flux(i_scls, i_pft) + rio_abg_fmort_flux_siscpf(io_idx_si_scpf) = sites(s)%fmort_abg_flux(i_scls, i_pft) + io_idx_si_scpf = io_idx_si_scpf + 1 + end do + end do + + do i_pft = 1, numpft + rio_termcflux_cano_sipft(io_idx_si_pft) = sites(s)%term_carbonflux_canopy(i_pft) + rio_termcflux_usto_sipft(io_idx_si_pft) = sites(s)%term_carbonflux_ustory(i_pft) + rio_fmortcflux_cano_sipft(io_idx_si_pft) = sites(s)%fmort_carbonflux_canopy(i_pft) + rio_fmortcflux_usto_sipft(io_idx_si_pft) = sites(s)%fmort_carbonflux_ustory(i_pft) + rio_imortcflux_sipft(io_idx_si_pft) = sites(s)%imort_carbonflux(i_pft) + io_idx_si_pft = io_idx_si_pft + 1 + end do + if(hlm_use_sp.eq.ifalse)then do el = 1, num_elements @@ -2073,6 +2101,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end do end if + + ! canopy spread term rio_spread_si(io_idx_si) = sites(s)%spread @@ -2081,7 +2111,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! new column, reset num patches patchespersite = 0 - do while(associated(cpatch)) + do_patch: do while(associated(cpatch)) ! found patch, increment patchespersite = patchespersite + 1 @@ -2356,31 +2386,12 @@ subroutine set_restart_vectors(this,nc,nsites,sites) cpatch => cpatch%younger - enddo ! cpatch do while - - io_idx_si_scpf = io_idx_co_1st + enddo do_patch ! cpatch do while ! Fill the site level diagnostics arrays do i_scls = 1, nlevsclass - do i_pft = 1, numpft - - rio_fmortrate_cano_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_canopy(i_scls, i_pft) - rio_fmortrate_usto_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_ustory(i_scls, i_pft) - rio_imortrate_siscpf(io_idx_si_scpf) = sites(s)%imort_rate(i_scls, i_pft) - rio_fmortrate_crown_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_crown(i_scls, i_pft) - rio_fmortrate_cambi_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_cambial(i_scls, i_pft) - rio_termnindiv_cano_siscpf(io_idx_si_scpf) = sites(s)%term_nindivs_canopy(i_scls,i_pft) - rio_termnindiv_usto_siscpf(io_idx_si_scpf) = sites(s)%term_nindivs_ustory(i_scls,i_pft) - rio_growflx_fusion_siscpf(io_idx_si_scpf) = sites(s)%growthflux_fusion(i_scls, i_pft) - - rio_abg_term_flux_siscpf(io_idx_si_scpf) = sites(s)%term_abg_flux(i_scls, i_pft) - rio_abg_imort_flux_siscpf(io_idx_si_scpf) = sites(s)%imort_abg_flux(i_scls, i_pft) - rio_abg_fmort_flux_siscpf(io_idx_si_scpf) = sites(s)%fmort_abg_flux(i_scls, i_pft) - io_idx_si_scpf = io_idx_si_scpf + 1 - end do - - rio_demorate_sisc(io_idx_si_sc) = sites(s)%demotion_rate(i_scls) + rio_demorate_sisc(io_idx_si_sc) = sites(s)%demotion_rate(i_scls) rio_promrate_sisc(io_idx_si_sc) = sites(s)%promotion_rate(i_scls) io_idx_si_sc = io_idx_si_sc + 1 @@ -2421,16 +2432,6 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_democflux_si(io_idx_si) = sites(s)%demotion_carbonflux rio_promcflux_si(io_idx_si) = sites(s)%promotion_carbonflux - io_idx_si_pft = io_idx_co_1st - do i_pft = 1, numpft - rio_termcflux_cano_sipft(io_idx_si_pft) = sites(s)%term_carbonflux_canopy(i_pft) - rio_termcflux_usto_sipft(io_idx_si_pft) = sites(s)%term_carbonflux_ustory(i_pft) - rio_fmortcflux_cano_sipft(io_idx_si_pft) = sites(s)%fmort_carbonflux_canopy(i_pft) - rio_fmortcflux_usto_sipft(io_idx_si_pft) = sites(s)%fmort_carbonflux_ustory(i_pft) - rio_imortcflux_sipft(io_idx_si_pft) = sites(s)%imort_carbonflux(i_pft) - io_idx_si_pft = io_idx_si_pft + 1 - end do - rio_imortcarea_si(io_idx_si) = sites(s)%imort_crownarea rio_fmortcarea_cano_si(io_idx_si) = sites(s)%fmort_crownarea_canopy rio_fmortcarea_usto_si(io_idx_si) = sites(s)%fmort_crownarea_ustory @@ -2922,6 +2923,8 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_cacls= io_idx_co_1st io_idx_si_cdsc = io_idx_co_1st io_idx_si_cdpf = io_idx_co_1st + io_idx_si_scpf = io_idx_co_1st + io_idx_si_pft = io_idx_co_1st ! read seed_bank info(site-level, but PFT-resolved) do i_pft = 1,numpft @@ -2943,6 +2946,33 @@ subroutine get_restart_vectors(this, nc, nsites, sites) endif endif + do i_scls = 1,nlevsclass + do i_pft = 1, numpft + sites(s)%fmort_rate_canopy(i_scls, i_pft) = rio_fmortrate_cano_siscpf(io_idx_si_scpf) + sites(s)%fmort_rate_ustory(i_scls, i_pft) = rio_fmortrate_usto_siscpf(io_idx_si_scpf) + sites(s)%imort_rate(i_scls, i_pft) = rio_imortrate_siscpf(io_idx_si_scpf) + sites(s)%fmort_rate_crown(i_scls, i_pft) = rio_fmortrate_crown_siscpf(io_idx_si_scpf) + sites(s)%fmort_rate_cambial(i_scls, i_pft) = rio_fmortrate_cambi_siscpf(io_idx_si_scpf) + sites(s)%term_nindivs_canopy(i_scls,i_pft) = rio_termnindiv_cano_siscpf(io_idx_si_scpf) + sites(s)%term_nindivs_ustory(i_scls,i_pft) = rio_termnindiv_usto_siscpf(io_idx_si_scpf) + sites(s)%growthflux_fusion(i_scls, i_pft) = rio_growflx_fusion_siscpf(io_idx_si_scpf) + sites(s)%term_abg_flux(i_scls,i_pft) = rio_abg_term_flux_siscpf(io_idx_si_scpf) + sites(s)%imort_abg_flux(i_scls,i_pft) = rio_abg_imort_flux_siscpf(io_idx_si_scpf) + sites(s)%fmort_abg_flux(i_scls,i_pft) = rio_abg_fmort_flux_siscpf(io_idx_si_scpf) + io_idx_si_scpf = io_idx_si_scpf + 1 + end do + end do + + do i_pft = 1, numpft + sites(s)%term_carbonflux_canopy(i_pft) = rio_termcflux_cano_sipft(io_idx_si_pft) + sites(s)%term_carbonflux_ustory(i_pft) = rio_termcflux_usto_sipft(io_idx_si_pft) + sites(s)%fmort_carbonflux_canopy(i_pft) = rio_fmortcflux_cano_sipft(io_idx_si_pft) + sites(s)%fmort_carbonflux_ustory(i_pft) = rio_fmortcflux_usto_sipft(io_idx_si_pft) + sites(s)%imort_carbonflux(i_pft) = rio_imortcflux_sipft(io_idx_si_pft) + io_idx_si_pft = io_idx_si_pft + 1 + end do + + ! Mass balance and diagnostics across elements at the site level if(hlm_use_sp.eq.ifalse)then do el = 1, num_elements @@ -2975,7 +3005,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) patchespersite = 0 cpatch => sites(s)%oldest_patch - do while(associated(cpatch)) + do_patch: do while(associated(cpatch)) patchespersite = patchespersite + 1 @@ -3244,8 +3274,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) end if cpatch => cpatch%younger - - enddo ! patch do while + enddo do_patch if(patchespersite .ne. rio_npatch_si(io_idx_si)) then write(fates_log(),*) 'Number of patches per site during retrieval does not match allocation' @@ -3299,30 +3328,11 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Fill the site level diagnostics arrays ! ----------------------------------------------------------------------------- - - io_idx_si_scpf = io_idx_co_1st - do i_scls = 1,nlevsclass - do i_pft = 1, numpft - sites(s)%fmort_rate_canopy(i_scls, i_pft) = rio_fmortrate_cano_siscpf(io_idx_si_scpf) - sites(s)%fmort_rate_ustory(i_scls, i_pft) = rio_fmortrate_usto_siscpf(io_idx_si_scpf) - sites(s)%imort_rate(i_scls, i_pft) = rio_imortrate_siscpf(io_idx_si_scpf) - sites(s)%fmort_rate_crown(i_scls, i_pft) = rio_fmortrate_crown_siscpf(io_idx_si_scpf) - sites(s)%fmort_rate_cambial(i_scls, i_pft) = rio_fmortrate_cambi_siscpf(io_idx_si_scpf) - sites(s)%term_nindivs_canopy(i_scls,i_pft) = rio_termnindiv_cano_siscpf(io_idx_si_scpf) - sites(s)%term_nindivs_ustory(i_scls,i_pft) = rio_termnindiv_usto_siscpf(io_idx_si_scpf) - sites(s)%growthflux_fusion(i_scls, i_pft) = rio_growflx_fusion_siscpf(io_idx_si_scpf) - - sites(s)%term_abg_flux(i_scls,i_pft) = rio_abg_term_flux_siscpf(io_idx_si_scpf) - sites(s)%imort_abg_flux(i_scls,i_pft) = rio_abg_imort_flux_siscpf(io_idx_si_scpf) - sites(s)%fmort_abg_flux(i_scls,i_pft) = rio_abg_fmort_flux_siscpf(io_idx_si_scpf) - - io_idx_si_scpf = io_idx_si_scpf + 1 - end do sites(s)%demotion_rate(i_scls) = rio_demorate_sisc(io_idx_si_sc) sites(s)%promotion_rate(i_scls) = rio_promrate_sisc(io_idx_si_sc) - + io_idx_si_sc = io_idx_si_sc + 1 end do @@ -3360,16 +3370,6 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%demotion_carbonflux = rio_democflux_si(io_idx_si) sites(s)%promotion_carbonflux = rio_promcflux_si(io_idx_si) - io_idx_si_pft = io_idx_co_1st - do i_pft = 1, numpft - sites(s)%term_carbonflux_canopy(i_pft) = rio_termcflux_cano_sipft(io_idx_si_pft) - sites(s)%term_carbonflux_ustory(i_pft) = rio_termcflux_usto_sipft(io_idx_si_pft) - sites(s)%fmort_carbonflux_canopy(i_pft) = rio_fmortcflux_cano_sipft(io_idx_si_pft) - sites(s)%fmort_carbonflux_ustory(i_pft) = rio_fmortcflux_usto_sipft(io_idx_si_pft) - sites(s)%imort_carbonflux(i_pft) = rio_imortcflux_sipft(io_idx_si_pft) - io_idx_si_pft = io_idx_si_pft + 1 - end do - ! Site level phenology status flags sites(s)%cstatus = rio_cd_status_si(io_idx_si) From 5b2129aea9ee1fefb09c1e9dfb056af53bb62583 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 23 Jun 2023 12:48:24 -0600 Subject: [PATCH 089/250] moved nlevsclass calculation earlier in subroutine --- main/FatesInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 9f3e3cc986..b192dab3e9 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -821,6 +821,7 @@ subroutine SetFatesGlobalElements2(use_fates) nleafage = size(prt_params%leaf_long,dim=2) end if + nlevsclass = size(ED_val_history_sizeclass_bin_edges,dim=1) ! These values are used to define the restart file allocations and general structure ! of memory for the cohort arrays @@ -884,7 +885,6 @@ subroutine SetFatesGlobalElements2(use_fates) ! Identify number of size and age class bins for history output ! assume these arrays are 1-indexed - nlevsclass = size(ED_val_history_sizeclass_bin_edges,dim=1) nlevage = size(ED_val_history_ageclass_bin_edges,dim=1) nlevheight = size(ED_val_history_height_bin_edges,dim=1) nlevcoage = size(ED_val_history_coageclass_bin_edges,dim=1) From 28eab3993e4ea0f1f92da06d86d903f9e8346f9d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 12 Jul 2023 14:42:55 -0400 Subject: [PATCH 090/250] Added site level scratch array for the 2stream solver --- main/EDTypesMod.F90 | 17 +++++ radiation/FatesRadiationDriveMod.F90 | 3 + radiation/FatesTwoStreamInterfaceMod.F90 | 32 ++++++++- radiation/TwoStreamMLPEMod.F90 | 91 ++++++++++-------------- 4 files changed, 86 insertions(+), 57 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index b700edbcc1..19cf50af0e 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -715,6 +715,23 @@ module EDTypesMod ! in FatesSoilBGCFluxMod. Used solely to inform bc_out%ema_npp ! which is used for fixation + ! Two-stream scratch arrays + real(r8), allocatable :: omega_2str(:,:) ! This is the matrix that is inverted to solve + ! the linear system of equations in the two-stream + ! radiation module. This array will grow + ! and shrink depending on how many scattering + ! elements there are. This matrix is square, + ! and needs to be larger than 2 x number-of-elements + ! for each patch on the site + + real(r8), allocatable :: taulambda_2str(:) ! These are the coefficients of the two-stream + ! linear system of equations (ie the unknowns, "lambda") + ! As well as the left-side (constants, "tau"). Since + ! the LAPACK solver dgesv uses the latter + ! as the argument and over-writes, we only + ! need one array + + integer, allocatable :: ipiv_2str(:) ! pivot indices for the lapack 2str solver ! SP mode target PFT level variables diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index 834ebfb5ef..bb3fb50c96 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -180,6 +180,9 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) call twostr%Solve(ib, & ! in normalized_upper_boundary, & ! in 1.0_r8,1.0_r8, & ! in + csite%taulambda_2str, & ! inout (scratch) + csite%omega_2str, & ! inout (scratch) + csite%ipiv_2str, & ! inout (scratch) bc_out(s)%albd_parb(ifp,ib), & ! out bc_out(s)%albi_parb(ifp,ib), & ! out bc_out(s)%fabd_parb(ifp,ib), & ! out diff --git a/radiation/FatesTwoStreamInterfaceMod.F90 b/radiation/FatesTwoStreamInterfaceMod.F90 index bfc8a3971b..8eb4e2f0eb 100644 --- a/radiation/FatesTwoStreamInterfaceMod.F90 +++ b/radiation/FatesTwoStreamInterfaceMod.F90 @@ -74,6 +74,9 @@ subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) ! applied to increase LAI and SAI in the cohorts ! and elements as well (to preserve mass and volume). + integer :: max_elements ! Maximum number of scattering elements on the site + integer :: n_scr ! The size of the scratch arrays + logical :: allocate_scratch ! Whether to re-allocate the scratch arrays ! These parameters are not used yet !real(r8) :: max_vai_diff_per_elem ! The maximum vai difference in any element @@ -86,6 +89,7 @@ subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) if(rad_solver.ne.twostr_solver)return + max_elements = -1 ifp=0 patch => site%oldest_patch do while (associated(patch)) @@ -284,6 +288,8 @@ subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) call twostr%GetNSCel() ! Total number of elements + max_elements = max(max_elements,twostr%n_scel) + twostr%force_prep = .true. ! This signals that two-stream scattering coefficients ! that are dependent on geometry need to be updated @@ -291,13 +297,33 @@ subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) call twostr%ZenithPrep(coszen_pa(ifp)) end associate - - - patch => patch%younger end do + if(allocated(site%taulambda_2str) .and. max_elements>0 )then + n_scr = ubound(site%taulambda_2str,dim=1) + allocate_scratch = .false. + if(2*max_elements > n_scr) then + allocate_scratch = .true. + deallocate(site%taulambda_2str,site%ipiv_2str,site%omega_2str) + elseif(2*max_elements < (n_scr-24)) then + allocate_scratch = .true. + deallocate(site%taulambda_2str,site%ipiv_2str,site%omega_2str) + end if + else + allocate_stratch = .true. + end if + + if(allocate_scratch)then + ! Twice as many spaces as there are elements, plus some + ! extra to prevent allocating/deallocating on the next step + n_scr = 2*max_elements+8 + allocate(site%taulambda_2str(n_scr)) + allocate(site%omega_2str(n_scr,n_scr)) + allocate(site%ipiv_2str(n_scr)) + end if + return end subroutine FatesConstructRadElements diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index ac6d9cbc72..c9a12ff240 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -988,6 +988,9 @@ subroutine Solve(this, ib, & upper_boundary_type, & Rbeam_atm, & Rdiff_atm, & + taulamb, & + omega, & + ipiv, & albedo_beam, & albedo_diff, & frac_abs_can_beam, & @@ -1024,8 +1027,9 @@ subroutine Solve(this, ib, & real(r8) :: Rbeam_atm ! Intensity of beam radiation at top of canopy [W/m2 ground] real(r8) :: Rdiff_atm ! Intensity of diffuse radiation at top of canopy [W/m2 ground] ! - - + real(r8) :: taulamb(:) ! both the coefficient vector and constant side of the linear equation + real(r8) :: omega(:) ! the square matrix to be inverted + integer :: ipiv(:) ! pivot indices for LAPACK (not optional output, we don't use) real(r8) :: albedo_beam ! Mean albedo at canopy top generated from beam radiation [-] real(r8) :: albedo_diff ! Mean albedo at canopy top generated from downwelling diffuse [-] @@ -1044,15 +1048,6 @@ subroutine Solve(this, ib, & ! ! Where, we invert to solve for the coefficients LAMBDA - !real(r8),allocatable :: OMEGA(:,:) - !real(r8),allocatable :: TAU(:) - !real(r8),allocatable :: LAMBDA(:) - - real(r8) :: OMEGA(200,200) - real(r8) :: TAU(200) - real(r8) :: LAMBDA(200) - integer :: ipiv(200) - integer :: isol ! Solution index loop (beam, beam+diff) integer :: ican ! Loop index for canopy layers integer :: ibot ! layer index for top side of layer divide @@ -1291,13 +1286,8 @@ subroutine Solve(this, ib, & this%band(ib)%Rdiff_atm = 1.0_r8 end if - if(n_eq>200)then - write(log_unit,*)"NEED A BIGGER MATRIX, n_eq:",n_eq - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - OMEGA(1:n_eq,1:n_eq) = 0._r8 - TAU(1:n_eq) = 0._r8 + omega(1:n_eq,1:n_eq) = 0._r8 + taulamb(1:n_eq) = 0._r8 ! -------------------------------------------------------------------- ! I. Flux equations with the atmospheric boundary @@ -1313,9 +1303,9 @@ subroutine Solve(this, ib, & qp = qp + 1 k1 = 2*(ilem-1)+1 k2 = k1+1 - TAU(qp) = this%band(ib)%Rdiff_atm - this%band(ib)%Rbeam_atm*scelbp%Ad - OMEGA(qp,k1) = scelbp%B1d - OMEGA(qp,k2) = scelbp%B2d + taulamb(qp) = this%band(ib)%Rdiff_atm - this%band(ib)%Rbeam_atm*scelbp%Ad + omega(qp,k1) = scelbp%B1d + omega(qp,k2) = scelbp%B2d end do @@ -1354,9 +1344,9 @@ subroutine Solve(this, ib, & ! Include the self terms for the current element ! This term is at v=0 - TAU(qp) = this%band(ib)%Rbeam_atm*this%band(ib)%scelb(ibot,jcol)%Ad - OMEGA(qp,k1) = OMEGA(qp,k1) - this%band(ib)%scelb(ibot,jcol)%B1d - OMEGA(qp,k2) = OMEGA(qp,k2) - this%band(ib)%scelb(ibot,jcol)%B2d + taulamb(qp) = this%band(ib)%Rbeam_atm*this%band(ib)%scelb(ibot,jcol)%Ad + omega(qp,k1) = omega(qp,k1) - this%band(ib)%scelb(ibot,jcol)%B1d + omega(qp,k2) = omega(qp,k2) - this%band(ib)%scelb(ibot,jcol)%B2d ! We need to include the terms from ! all elements above the current element of interest @@ -1372,9 +1362,9 @@ subroutine Solve(this, ib, & vai = scelgp%lai + scelgp%sai - TAU(qp) = TAU(qp) - scelgp%area * this%band(ib)%Rbeam_atm*scelbp%Ad *exp(-scelgp%Kb*vai) - OMEGA(qp,k1) = OMEGA(qp,k1) + scelgp%area * scelbp%B1d*exp(scelbp%a*vai) - OMEGA(qp,k2) = OMEGA(qp,k2) + scelgp%area * scelbp%B2d*exp(-scelbp%a*vai) + taulamb(qp) = taulamb(qp) - scelgp%area * this%band(ib)%Rbeam_atm*scelbp%Ad *exp(-scelgp%Kb*vai) + omega(qp,k1) = omega(qp,k1) + scelgp%area * scelbp%B1d*exp(scelbp%a*vai) + omega(qp,k2) = omega(qp,k2) + scelgp%area * scelbp%B2d*exp(-scelbp%a*vai) end do @@ -1415,9 +1405,9 @@ subroutine Solve(this, ib, & scelbp => this%band(ib)%scelb(itop,icol) vai = scelgp%lai + scelgp%sai - TAU(qp) = this%band(ib)%Rbeam_atm*scelbp%Au*exp(-scelgp%Kb*vai) - OMEGA(qp,k1) = OMEGA(qp,k1) - scelbp%B1u*exp(scelbp%a*vai) - OMEGA(qp,k2) = OMEGA(qp,k2) - scelbp%B2u*exp(-scelbp%a*vai) + taulamb(qp) = this%band(ib)%Rbeam_atm*scelbp%Au*exp(-scelgp%Kb*vai) + omega(qp,k1) = omega(qp,k1) - scelbp%B1u*exp(scelbp%a*vai) + omega(qp,k2) = omega(qp,k2) - scelbp%B2u*exp(-scelbp%a*vai) ! Terms for mean diffuse exiting lower elements (move out of this loop for efficiency) do jcol = 1,this%n_col(ibot) @@ -1427,9 +1417,9 @@ subroutine Solve(this, ib, & scelgp => this%scelg(ibot,jcol) scelbp => this%band(ib)%scelb(ibot,jcol) - TAU(qp) = TAU(qp) - this%band(ib)%Rbeam_atm*scelgp%area*scelbp%Au - OMEGA(qp,k1) = OMEGA(qp,k1) + scelgp%area*scelbp%B1u - OMEGA(qp,k2) = OMEGA(qp,k2) + scelgp%area*scelbp%B2u + taulamb(qp) = taulamb(qp) - this%band(ib)%Rbeam_atm*scelgp%area*scelbp%Au + omega(qp,k1) = omega(qp,k1) + scelgp%area*scelbp%B1u + omega(qp,k2) = omega(qp,k2) + scelgp%area*scelbp%B2u end do end do @@ -1460,36 +1450,33 @@ subroutine Solve(this, ib, & vai = scelgp%lai + scelgp%sai - TAU(qp) = this%band(ib)%Rbeam_atm*(scelbp%Au*exp(-scelgp%Kb*vai) & + taulamb(qp) = this%band(ib)%Rbeam_atm*(scelbp%Au*exp(-scelgp%Kb*vai) & - this%band(ib)%albedo_grnd_diff*scelbp%Ad*exp(-scelgp%Kb*vai) & - this%band(ib)%albedo_grnd_beam*scelbp%Rbeam0*exp(-scelgp%Kb*vai)) - OMEGA(qp,k1) = OMEGA(qp,k1) - scelbp%B1u*exp(scelbp%a*vai) - OMEGA(qp,k2) = OMEGA(qp,k2) - scelbp%B2u*exp(-scelbp%a*vai) + omega(qp,k1) = omega(qp,k1) - scelbp%B1u*exp(scelbp%a*vai) + omega(qp,k2) = omega(qp,k2) - scelbp%B2u*exp(-scelbp%a*vai) - OMEGA(qp,k1) = OMEGA(qp,k1) + this%band(ib)%albedo_grnd_diff*scelbp%B1d*exp(scelbp%a*vai) - OMEGA(qp,k2) = OMEGA(qp,k2) + this%band(ib)%albedo_grnd_diff*scelbp%B2d*exp(-scelbp%a*vai) + omega(qp,k1) = omega(qp,k1) + this%band(ib)%albedo_grnd_diff*scelbp%B1d*exp(scelbp%a*vai) + omega(qp,k2) = omega(qp,k2) + this%band(ib)%albedo_grnd_diff*scelbp%B2d*exp(-scelbp%a*vai) end do - !write(log_unit,*)"TAU: ",TAU(:) - - - LAMBDA(1:n_eq) = TAU(1:n_eq) + !LAMBDA(1:n_eq) = TAU(1:n_eq) ! Solution borrowed from Greg Lemieux's usage during FATES canopy trimming: ! Compute the optimum size of the work array - call dgesv(n_eq, 1, OMEGA(1:n_eq,1:n_eq), n_eq, ipiv(1:n_eq), LAMBDA(1:n_eq), n_eq, info) + call dgesv(n_eq, 1, omega(1:n_eq,1:n_eq), n_eq, ipiv(1:n_eq), taulamb(1:n_eq), n_eq, info) !lwork = -1 ! Ask dgels to compute optimal number of entries for work - !call dgels(trans, n_eq, n_eq, 1, OMEGA(1:n_eq,1:n_eq), n_eq, LAMBDA(1:n_eq), n_eq, work, lwork, info) + !call dgels(trans, n_eq, n_eq, 1, omega(1:n_eq,1:n_eq), n_eq, taulamb(1:n_eq), n_eq, work, lwork, info) !lwork = int(work(1)) ! Pick the optimum. TBD, can work(1) come back with greater than work size? ! Compute the minimum of 2-norm of of the least squares fit to solve for X - ! Note that dgels returns the solution by overwriting the LAMBDA array. + ! Note that dgels returns the solution by overwriting the taulamb array. ! The result has the form: X = [b; m] - !call dgels(trans, n_eq, n_eq, 1, OMEGA(1:n_eq,1:n_eq), n_eq, LAMBDA(1:n_eq), n_eq, work, lwork, info) + !call dgels(trans, n_eq, n_eq, 1, omega(1:n_eq,1:n_eq), n_eq, taulamb(1:n_eq), n_eq, work, lwork, info) if(info.ne.0)then write(log_unit,*) 'Could not find a solution via dgesv' @@ -1507,8 +1494,8 @@ subroutine Solve(this, ib, & k2 = k1 + 1 scelgp => this%scelg(ican,icol) scelbp => this%band(ib)%scelb(ican,icol) - scelbp%lambda1_beam = LAMBDA(k1) - scelbp%lambda2_beam = LAMBDA(k2) + scelbp%lambda1_beam = taulamb(k1) + scelbp%lambda2_beam = taulamb(k2) ! The lambda diff terms will be ! multiplied by zero before we use them ! but, we dont want things like nan's @@ -1526,8 +1513,8 @@ subroutine Solve(this, ib, & k2 = k1 + 1 scelgp => this%scelg(ican,icol) scelbp => this%band(ib)%scelb(ican,icol) - scelbp%lambda1_diff = LAMBDA(k1) - scelbp%lambda2_diff = LAMBDA(k2) + scelbp%lambda1_diff = taulamb(k1) + scelbp%lambda2_diff = taulamb(k2) end do ilem_off = ilem_off + this%n_col(ican) end do @@ -1608,10 +1595,6 @@ subroutine Solve(this, ib, & end do do_isol - !deallocate(OMEGA) - !deallocate(TAU) - !deallocate(LAMBDA) - ! Check the error balance ! --------------------------------------------------------------------------------------------- From 22b6b36fef27dbb7449cd4fa802f741884b61220 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 14 Jul 2023 09:27:48 -0400 Subject: [PATCH 091/250] Updated unit tests to handle scratch arrays in twostream --- .../radiation/RadiationUTestDriver.py | 3 +- .../radiation/build_radiation_f90_objects.sh | 1 + .../radiation/f90_src/RadiationWrapMod.F90 | 9 +++++- .../radiation/f90_src/WrapShrMod.F90 | 28 +++++++++++++++++++ radiation/TwoStreamMLPEMod.F90 | 2 +- 5 files changed, 40 insertions(+), 3 deletions(-) create mode 100644 functional_unit_testing/radiation/f90_src/WrapShrMod.F90 diff --git a/functional_unit_testing/radiation/RadiationUTestDriver.py b/functional_unit_testing/radiation/RadiationUTestDriver.py index faba1c19e7..a553ab3b1f 100644 --- a/functional_unit_testing/radiation/RadiationUTestDriver.py +++ b/functional_unit_testing/radiation/RadiationUTestDriver.py @@ -38,6 +38,7 @@ # Instantiate the F90 modules +f90_shr_obj = ctypes.CDLL('bld/WrapShrMod.o',mode=ctypes.RTLD_GLOBAL) f90_mem_obj = ctypes.CDLL('bld/FatesRadiationMemMod.o',mode=ctypes.RTLD_GLOBAL) f90_twostr_obj = ctypes.CDLL('bld/TwoStreamMLPEMod.o',mode=ctypes.RTLD_GLOBAL) f90_wrap_obj = ctypes.CDLL('bld/RadiationWrapMod.o',mode=ctypes.RTLD_GLOBAL) @@ -144,7 +145,7 @@ def main(argv): # Process the core 2Stream parameters from parameters in file iret = param_prep_call(ci(n_pft)) - if(True): + if(False): ParallelElementPerturbDist() if(True): diff --git a/functional_unit_testing/radiation/build_radiation_f90_objects.sh b/functional_unit_testing/radiation/build_radiation_f90_objects.sh index 5ff5f3c9ae..3b11d4c0bc 100755 --- a/functional_unit_testing/radiation/build_radiation_f90_objects.sh +++ b/functional_unit_testing/radiation/build_radiation_f90_objects.sh @@ -15,6 +15,7 @@ rm -f bld/*.mod # Build the new file with constants +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/WrapShrMod.o f90_src/WrapShrMod.F90 ${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/FatesRadiationMemMod.o ../../radiation/FatesRadiationMemMod.F90 ${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/TwoStreamMLPEMod.o ../../radiation/TwoStreamMLPEMod.F90 ${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/RadiationWrapMod.o f90_src/RadiationWrapMod.F90 diff --git a/functional_unit_testing/radiation/f90_src/RadiationWrapMod.F90 b/functional_unit_testing/radiation/f90_src/RadiationWrapMod.F90 index ed35afcc2a..596087f046 100644 --- a/functional_unit_testing/radiation/f90_src/RadiationWrapMod.F90 +++ b/functional_unit_testing/radiation/f90_src/RadiationWrapMod.F90 @@ -156,7 +156,7 @@ end subroutine WrapSetDownwelling subroutine WrapSolve(ib,boundary_type,Rbeam_atm,Rdiff_atm, & albedo_beam, & - albedo_diff, & + albedo_diff, & frac_abs_can_beam, & frac_abs_can_diff, & frac_beam_grnd_beam, & @@ -175,9 +175,16 @@ subroutine WrapSolve(ib,boundary_type,Rbeam_atm,Rdiff_atm, & real(r8) :: frac_diff_grnd_diff real(r8) :: Rbeam_atm ! Intensity of beam radiation at top of canopy [W/m2 ground] real(r8) :: Rdiff_atm ! Intensity of diffuse radiation at top of canopy [W/m2 ground] + + real(r8) :: taulamb(50) + real(r8) :: omega(50,50) + integer :: ipiv(50) call twostream%Solve(ib,boundary_type, & Rbeam_atm,Rdiff_atm, & + taulamb, & + omega, & + ipiv, & albedo_beam, & albedo_diff, & frac_abs_can_beam, & diff --git a/functional_unit_testing/radiation/f90_src/WrapShrMod.F90 b/functional_unit_testing/radiation/f90_src/WrapShrMod.F90 new file mode 100644 index 0000000000..094b3d9cbc --- /dev/null +++ b/functional_unit_testing/radiation/f90_src/WrapShrMod.F90 @@ -0,0 +1,28 @@ +module shr_log_mod + use iso_c_binding, only : c_char + use iso_c_binding, only : c_int + + public :: shr_log_errMsg + + contains + function shr_log_errMsg(source, line) result(ans) + character(kind=c_char,len=*), intent(in) :: source + integer(c_int), intent(in) :: line + character(kind=c_char,len=128) :: ans + + ans = "source: " // trim(source) // " line: " + end function shr_log_errMsg + +end module shr_log_mod + +module shr_sys_mod + + public :: shr_sys_abort + +contains + + subroutine shr_sys_abort + call exit(0) + end subroutine shr_sys_abort + +end module shr_sys_mod diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index c9a12ff240..d2e5c49925 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -1028,7 +1028,7 @@ subroutine Solve(this, ib, & real(r8) :: Rdiff_atm ! Intensity of diffuse radiation at top of canopy [W/m2 ground] ! real(r8) :: taulamb(:) ! both the coefficient vector and constant side of the linear equation - real(r8) :: omega(:) ! the square matrix to be inverted + real(r8) :: omega(:,:) ! the square matrix to be inverted integer :: ipiv(:) ! pivot indices for LAPACK (not optional output, we don't use) real(r8) :: albedo_beam ! Mean albedo at canopy top generated from beam radiation [-] From 672bae3ae636dfb65a3660d0e5c010e5f88ea241 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 9 Aug 2023 17:03:35 -0700 Subject: [PATCH 092/250] updating parameter file and archives --- ...api25.5.0_080923_fates_params_default.cdl} | 230 ++++++++++++++++-- ...223_luh2.xml => api27.0.0_080923_luh2.xml} | 6 +- parameter_files/fates_params_default.cdl | 12 +- 3 files changed, 212 insertions(+), 36 deletions(-) rename parameter_files/archive/{api25.4.0_042223_fates_paras_default.cdl => api25.5.0_080923_fates_params_default.cdl} (86%) rename parameter_files/archive/{api26.0.0_042223_luh2.xml => api27.0.0_080923_luh2.xml} (92%) diff --git a/parameter_files/archive/api25.4.0_042223_fates_paras_default.cdl b/parameter_files/archive/api25.5.0_080923_fates_params_default.cdl similarity index 86% rename from parameter_files/archive/api25.4.0_042223_fates_paras_default.cdl rename to parameter_files/archive/api25.5.0_080923_fates_params_default.cdl index d461cb6fbb..f170fe2275 100644 --- a/parameter_files/archive/api25.4.0_042223_fates_paras_default.cdl +++ b/parameter_files/archive/api25.5.0_080923_fates_params_default.cdl @@ -389,6 +389,9 @@ variables: double fates_maintresp_reduction_intercept(fates_pft) ; fates_maintresp_reduction_intercept:units = "unitless (0-1)" ; fates_maintresp_reduction_intercept:long_name = "intercept of MR reduction as f(carbon storage), 0=no throttling, 1=max throttling" ; + double fates_maintresp_reduction_upthresh(fates_pft) ; + fates_maintresp_reduction_upthresh:units = "unitless (0-1)" ; + fates_maintresp_reduction_upthresh:long_name = "upper threshold for storage biomass (relative to leaf biomass) above which MR is not reduced" ; double fates_mort_bmort(fates_pft) ; fates_mort_bmort:units = "1/yr" ; fates_mort_bmort:long_name = "background mortality rate" ; @@ -428,6 +431,9 @@ variables: double fates_mort_scalar_hydrfailure(fates_pft) ; fates_mort_scalar_hydrfailure:units = "1/yr" ; fates_mort_scalar_hydrfailure:long_name = "maximum mortality rate from hydraulic failure" ; + double fates_mort_upthresh_cstarvation(fates_pft) ; + fates_mort_upthresh_cstarvation:units = "unitless" ; + fates_mort_upthresh_cstarvation:long_name = "threshold for storage biomass (relative to target leaf biomass) above which carbon starvation is zero" ; double fates_nonhydro_smpsc(fates_pft) ; fates_nonhydro_smpsc:units = "mm" ; fates_nonhydro_smpsc:long_name = "Soil water potential at full stomatal closure" ; @@ -437,15 +443,24 @@ variables: double fates_phen_cold_size_threshold(fates_pft) ; fates_phen_cold_size_threshold:units = "cm" ; fates_phen_cold_size_threshold:long_name = "the dbh size above which will lead to phenology-related stem and leaf drop" ; + double fates_phen_drought_threshold(fates_pft) ; + fates_phen_drought_threshold:units = "m3/m3 or mm" ; + fates_phen_drought_threshold:long_name = "threshold for drought phenology (or lower threshold for semi-deciduous PFTs); the quantity depends on the sign: if positive, the threshold is volumetric soil moisture (m3/m3). If negative, the threshold is soil matric potentical (mm)" ; double fates_phen_evergreen(fates_pft) ; fates_phen_evergreen:units = "logical flag" ; fates_phen_evergreen:long_name = "Binary flag for evergreen leaf habit" ; double fates_phen_flush_fraction(fates_pft) ; fates_phen_flush_fraction:units = "fraction" ; fates_phen_flush_fraction:long_name = "Upon bud-burst, the maximum fraction of storage carbon used for flushing leaves" ; - double fates_phen_fnrt_drop_frac(fates_pft) ; - fates_phen_fnrt_drop_frac:units = "fraction" ; - fates_phen_fnrt_drop_frac:long_name = "fraction of fine roots to drop during drought or cold" ; + double fates_phen_fnrt_drop_fraction(fates_pft) ; + fates_phen_fnrt_drop_fraction:units = "fraction" ; + fates_phen_fnrt_drop_fraction:long_name = "fraction of fine roots to drop during drought/cold" ; + double fates_phen_mindaysoff(fates_pft) ; + fates_phen_mindaysoff:units = "days" ; + fates_phen_mindaysoff:long_name = "day threshold compared against days since leaves abscised (shed)" ; + double fates_phen_moist_threshold(fates_pft) ; + fates_phen_moist_threshold:units = "m3/m3 or mm" ; + fates_phen_moist_threshold:long_name = "upper threshold for drought phenology (only for drought semi-deciduous PFTs); the quantity depends on the sign: if positive, the threshold is volumetric soil moisture (m3/m3). If negative, the threshold is soil matric potentical (mm)" ; double fates_phen_season_decid(fates_pft) ; fates_phen_season_decid:units = "logical flag" ; fates_phen_season_decid:long_name = "Binary flag for seasonal-deciduous leaf habit" ; @@ -515,6 +530,18 @@ variables: double fates_recruit_seed_supplement(fates_pft) ; fates_recruit_seed_supplement:units = "KgC/m2/yr" ; fates_recruit_seed_supplement:long_name = "Supplemental external seed rain source term (non-mass conserving)" ; + double fates_seed_dispersal_fraction(fates_pft) ; + fates_seed_dispersal_fraction:units = "fraction" ; + fates_seed_dispersal_fraction:long_name = "fraction of seed rain to be dispersed to other grid cells" ; + double fates_seed_dispersal_max_dist(fates_pft) ; + fates_seed_dispersal_max_dist:units = "m" ; + fates_seed_dispersal_max_dist:long_name = "maximum seed dispersal distance for a given pft" ; + double fates_seed_dispersal_pdf_scale(fates_pft) ; + fates_seed_dispersal_pdf_scale:units = "unitless" ; + fates_seed_dispersal_pdf_scale:long_name = "seed dispersal probability density function scale parameter, A, Table 1 Bullock et al 2016" ; + double fates_seed_dispersal_pdf_shape(fates_pft) ; + fates_seed_dispersal_pdf_shape:units = "unitless" ; + fates_seed_dispersal_pdf_shape:long_name = "seed dispersal probability density function shape parameter, B, Table 1 Bullock et al 2016" ; double fates_stoich_nitr(fates_plant_organs, fates_pft) ; fates_stoich_nitr:units = "gN/gC" ; fates_stoich_nitr:long_name = "target nitrogen concentration (ratio with carbon) of organs" ; @@ -527,6 +554,60 @@ variables: double fates_trim_limit(fates_pft) ; fates_trim_limit:units = "m2/m2" ; fates_trim_limit:long_name = "Arbitrary limit to reductions in leaf area with stress" ; + double fates_trs_repro_alloc_a(fates_pft) ; + fates_trs_repro_alloc_a:units = "fraction" ; + fates_trs_repro_alloc_a:long_name = "shape parameter for sigmoidal function relating dbh to reproductive allocation" ; + double fates_trs_repro_alloc_b(fates_pft) ; + fates_trs_repro_alloc_b:units = "fraction" ; + fates_trs_repro_alloc_b:long_name = "intercept parameter for sigmoidal function relating dbh to reproductive allocation" ; + double fates_trs_repro_frac_seed(fates_pft) ; + fates_trs_repro_frac_seed:units = "fraction" ; + fates_trs_repro_frac_seed:long_name = "fraction of reproductive mass that is seed" ; + double fates_trs_seedling_a_emerg(fates_pft) ; + fates_trs_seedling_a_emerg:units = "day -1" ; + fates_trs_seedling_a_emerg:long_name = "mean fraction of seed bank emerging" ; + double fates_trs_seedling_b_emerg(fates_pft) ; + fates_trs_seedling_b_emerg:units = "day -1" ; + fates_trs_seedling_b_emerg:long_name = "seedling emergence sensitivity to soil moisture" ; + double fates_trs_seedling_background_mort(fates_pft) ; + fates_trs_seedling_background_mort:units = "yr-1" ; + fates_trs_seedling_background_mort:long_name = "background seedling mortality rate" ; + double fates_trs_seedling_h2o_mort_a(fates_pft) ; + fates_trs_seedling_h2o_mort_a:units = "-" ; + fates_trs_seedling_h2o_mort_a:long_name = "coefficient in moisture-based seedling mortality" ; + double fates_trs_seedling_h2o_mort_b(fates_pft) ; + fates_trs_seedling_h2o_mort_b:units = "-" ; + fates_trs_seedling_h2o_mort_b:long_name = "coefficient in moisture-based seedling mortality" ; + double fates_trs_seedling_h2o_mort_c(fates_pft) ; + fates_trs_seedling_h2o_mort_c:units = "-" ; + fates_trs_seedling_h2o_mort_c:long_name = "coefficient in moisture-based seedling mortality" ; + double fates_trs_seedling_light_mort_a(fates_pft) ; + fates_trs_seedling_light_mort_a:units = "-" ; + fates_trs_seedling_light_mort_a:long_name = "light-based seedling mortality coefficient" ; + double fates_trs_seedling_light_mort_b(fates_pft) ; + fates_trs_seedling_light_mort_b:units = "-" ; + fates_trs_seedling_light_mort_b:long_name = "light-based seedling mortality coefficient" ; + double fates_trs_seedling_light_rec_a(fates_pft) ; + fates_trs_seedling_light_rec_a:units = "-" ; + fates_trs_seedling_light_rec_a:long_name = "coefficient in light-based seedling to sapling transition" ; + double fates_trs_seedling_light_rec_b(fates_pft) ; + fates_trs_seedling_light_rec_b:units = "-" ; + fates_trs_seedling_light_rec_b:long_name = "coefficient in light-based seedling to sapling transition" ; + double fates_trs_seedling_mdd_crit(fates_pft) ; + fates_trs_seedling_mdd_crit:units = "mm H2O day" ; + fates_trs_seedling_mdd_crit:long_name = "critical moisture deficit (suction) day accumulation for seedling moisture-based seedling mortality to begin" ; + double fates_trs_seedling_par_crit_germ(fates_pft) ; + fates_trs_seedling_par_crit_germ:units = "MJ m-2 day-1" ; + fates_trs_seedling_par_crit_germ:long_name = "critical light level for germination" ; + double fates_trs_seedling_psi_crit(fates_pft) ; + fates_trs_seedling_psi_crit:units = "mm H2O" ; + fates_trs_seedling_psi_crit:long_name = "critical soil moisture (suction) for seedling stress" ; + double fates_trs_seedling_psi_emerg(fates_pft) ; + fates_trs_seedling_psi_emerg:units = "mm h20 suction" ; + fates_trs_seedling_psi_emerg:long_name = "critical soil moisture for seedling emergence" ; + double fates_trs_seedling_root_depth(fates_pft) ; + fates_trs_seedling_root_depth:units = "m" ; + fates_trs_seedling_root_depth:long_name = "rooting depth of seedlings" ; double fates_turb_displar(fates_pft) ; fates_turb_displar:units = "unitless" ; fates_turb_displar:long_name = "Ratio of displacement height to canopy top height" ; @@ -544,7 +625,7 @@ variables: fates_turnover_fnrt:long_name = "root longevity (alternatively, turnover time)" ; double fates_turnover_leaf(fates_leafage_class, fates_pft) ; fates_turnover_leaf:units = "yr" ; - fates_turnover_leaf:long_name = "Leaf longevity (ie turnover timescale)" ; + fates_turnover_leaf:long_name = "Leaf longevity (ie turnover timescale). For drought-deciduous PFTs, this also indicates the maximum length of the growing (i.e., leaves on) season." ; double fates_turnover_senleaf_fdrought(fates_pft) ; fates_turnover_senleaf_fdrought:units = "unitless[0-1]" ; fates_turnover_senleaf_fdrought:long_name = "multiplication factor for leaf longevity of senescent leaves during drought" ; @@ -755,12 +836,6 @@ variables: double fates_phen_coldtemp ; fates_phen_coldtemp:units = "degrees C" ; fates_phen_coldtemp:long_name = "vegetation temperature exceedance that flags a cold-day for leaf-drop" ; - double fates_phen_drought_model ; - fates_phen_drought_model:units = "unitless" ; - fates_phen_drought_model:long_name = "which method to use for drought phenology: 0 - FATES default; 1 - Semi-deciduous (ED2-like)" ; - double fates_phen_drought_threshold ; - fates_phen_drought_threshold:units = "m3/m3 or mm" ; - fates_phen_drought_threshold:long_name = "threshold for drought phenology (or lower threshold when fates_phen_drought_model = 1); the quantity depends on the sign: if positive, the threshold is volumetric soil moisture (m3/m3). If negative, the threshold is soil matric potentical (mm)" ; double fates_phen_gddthresh_a ; fates_phen_gddthresh_a:units = "none" ; fates_phen_gddthresh_a:long_name = "GDD accumulation function, intercept parameter: gdd_thesh = a + b exp(c*ncd)" ; @@ -770,15 +845,9 @@ variables: double fates_phen_gddthresh_c ; fates_phen_gddthresh_c:units = "none" ; fates_phen_gddthresh_c:long_name = "GDD accumulation function, exponent parameter: gdd_thesh = a + b exp(c*ncd)" ; - double fates_phen_mindaysoff ; - fates_phen_mindaysoff:units = "days" ; - fates_phen_mindaysoff:long_name = "day threshold compared against days since leaves became off-allometry" ; double fates_phen_mindayson ; fates_phen_mindayson:units = "days" ; fates_phen_mindayson:long_name = "day threshold compared against days since leaves became on-allometry" ; - double fates_phen_moist_threshold ; - fates_phen_moist_threshold:units = "m3/m3 or mm" ; - fates_phen_moist_threshold:long_name = "upper threshold for drought phenology (only for fates_phen_drought_model=1); the quantity depends on the sign: if positive, the threshold is volumetric soil moisture (m3/m3). If negative, the threshold is soil matric potentical (mm)" ; double fates_phen_ncolddayslim ; fates_phen_ncolddayslim:units = "days" ; fates_phen_ncolddayslim:long_name = "day threshold exceedance for temperature leaf-drop" ; @@ -788,9 +857,27 @@ variables: double fates_q10_mr ; fates_q10_mr:units = "unitless" ; fates_q10_mr:long_name = "Q10 for maintenance respiration" ; + double fates_rad_model ; + fates_rad_model:units = "unitless" ; + fates_rad_model:long_name = "switch designating the model for canopy radiation, 1 = Norman, 2 = Two-stream (experimental)" ; + double fates_regeneration_model ; + fates_regeneration_model:units = "-" ; + fates_regeneration_model:long_name = "switch for choosing between FATES\'s: 1) default regeneration scheme , 2) the Tree Recruitment Scheme (Hanbury-Brown et al., 2022), or (3) the Tree Recruitment Scheme without seedling dynamics" ; double fates_soil_salinity ; fates_soil_salinity:units = "ppt" ; fates_soil_salinity:long_name = "soil salinity used for model when not coupled to dynamic soil salinity" ; + double fates_trs_seedling2sap_par_timescale ; + fates_trs_seedling2sap_par_timescale:units = "days" ; + fates_trs_seedling2sap_par_timescale:long_name = "Length of the window for the exponential moving average of par at the seedling layer used to calculate seedling to sapling transition rates" ; + double fates_trs_seedling_emerg_h2o_timescale ; + fates_trs_seedling_emerg_h2o_timescale:units = "days" ; + fates_trs_seedling_emerg_h2o_timescale:long_name = "Length of the window for the exponential moving average of smp used to calculate seedling emergence" ; + double fates_trs_seedling_mdd_timescale ; + fates_trs_seedling_mdd_timescale:units = "days" ; + fates_trs_seedling_mdd_timescale:long_name = "Length of the window for the exponential moving average of moisture deficit days used to calculate seedling mortality" ; + double fates_trs_seedling_mort_par_timescale ; + fates_trs_seedling_mort_par_timescale:units = "days" ; + fates_trs_seedling_mort_par_timescale:long_name = "Length of the window for the exponential moving average of par at the seedling layer used to calculate seedling mortality" ; double fates_vai_top_bin_width ; fates_vai_top_bin_width:units = "m2/m2" ; fates_vai_top_bin_width:long_name = "width in VAI units of uppermost leaf+stem layer scattering element in each canopy layer" ; @@ -857,7 +944,7 @@ data: 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 ; - fates_alloc_storage_cushion = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, + fates_alloc_storage_cushion = 1.2, 1.2, 1.2, 1.2, 2.4, 1.2, 1.2, 2.4, 1.2, 1.2, 1.2, 1.2 ; fates_alloc_store_priority_frac = 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, @@ -1197,7 +1284,7 @@ data: 4.7, 2.2, 5.3, 1.6 ; fates_leaf_vcmax25top = - 50, 62, 39, 61, 41, 58, 62, 54, 54, 78, 78, 78 ; + 50, 62, 39, 61, 58, 58, 62, 54, 54, 78, 78, 78 ; fates_leaf_vcmaxha = 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330 ; @@ -1220,6 +1307,8 @@ data: fates_maintresp_reduction_intercept = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + fates_maintresp_reduction_upthresh = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + fates_mort_bmort = 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014 ; @@ -1254,6 +1343,8 @@ data: fates_mort_scalar_hydrfailure = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6 ; + fates_mort_upthresh_cstarvation = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + fates_nonhydro_smpsc = -255000, -255000, -255000, -255000, -255000, -255000, -255000, -255000, -255000, -255000, -255000, -255000 ; @@ -1262,12 +1353,23 @@ data: fates_phen_cold_size_threshold = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + fates_phen_drought_threshold = -152957.4, -152957.4, -152957.4, -152957.4, + -152957.4, -152957.4, -152957.4, -152957.4, -152957.4, -152957.4, + -152957.4, -152957.4 ; + fates_phen_evergreen = 1, 1, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0 ; fates_phen_flush_fraction = _, _, 0.5, _, 0.5, 0.5, _, 0.5, 0.5, 0.5, 0.5, 0.5 ; - fates_phen_fnrt_drop_frac = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + fates_phen_fnrt_drop_fraction = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_phen_mindaysoff = 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100 ; + + fates_phen_moist_threshold = -122365.9, -122365.9, -122365.9, -122365.9, + -122365.9, -122365.9, -122365.9, -122365.9, -122365.9, -122365.9, + -122365.9, -122365.9 ; fates_phen_season_decid = 0, 0, 1, 0, 0, 1, 0, 0, 1, 1, 0, 0 ; @@ -1334,6 +1436,14 @@ data: fates_recruit_seed_supplement = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + fates_seed_dispersal_fraction = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_seed_dispersal_max_dist = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_seed_dispersal_pdf_scale = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_seed_dispersal_pdf_shape = _, _, _, _, _, _, _, _, _, _, _, _ ; + fates_stoich_nitr = 0.033, 0.029, 0.04, 0.033, 0.04, 0.04, 0.033, 0.04, 0.04, 0.04, 0.04, 0.04, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, @@ -1358,6 +1468,68 @@ data: fates_trim_limit = 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3 ; + fates_trs_repro_alloc_a = 0.0049, 0.0049, 0.0049, 0.0049, 0.0049, 0.0049, + 0.0049, 0.0049, 0.0049, 0.0049, 0.0049, 0.0049 ; + + fates_trs_repro_alloc_b = -2.6171, -2.6171, -2.6171, -2.6171, -2.6171, + -2.6171, -2.6171, -2.6171, -2.6171, -2.6171, -2.6171, -2.6171 ; + + fates_trs_repro_frac_seed = 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, 0.24, + 0.24, 0.24, 0.24, 0.24 ; + + fates_trs_seedling_a_emerg = 0.0003, 0.0003, 0.0003, 0.0003, 0.0003, 0.0003, + 0.0003, 0.0003, 0.0003, 0.0003, 0.0003, 0.0003 ; + + fates_trs_seedling_b_emerg = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, + 1.2, 1.2, 1.2 ; + + fates_trs_seedling_background_mort = 0.1085371, 0.1085371, 0.1085371, + 0.1085371, 0.1085371, 0.1085371, 0.1085371, 0.1085371, 0.1085371, + 0.1085371, 0.1085371, 0.1085371 ; + + fates_trs_seedling_h2o_mort_a = 4.070565e-17, 4.070565e-17, 4.070565e-17, + 4.070565e-17, 4.070565e-17, 4.070565e-17, 4.070565e-17, 4.070565e-17, + 4.070565e-17, 4.070565e-17, 4.070565e-17, 4.070565e-17 ; + + fates_trs_seedling_h2o_mort_b = -6.390757e-11, -6.390757e-11, -6.390757e-11, + -6.390757e-11, -6.390757e-11, -6.390757e-11, -6.390757e-11, + -6.390757e-11, -6.390757e-11, -6.390757e-11, -6.390757e-11, -6.390757e-11 ; + + fates_trs_seedling_h2o_mort_c = 1.268992e-05, 1.268992e-05, 1.268992e-05, + 1.268992e-05, 1.268992e-05, 1.268992e-05, 1.268992e-05, 1.268992e-05, + 1.268992e-05, 1.268992e-05, 1.268992e-05, 1.268992e-05 ; + + fates_trs_seedling_light_mort_a = -0.009897694, -0.009897694, -0.009897694, + -0.009897694, -0.009897694, -0.009897694, -0.009897694, -0.009897694, + -0.009897694, -0.009897694, -0.009897694, -0.009897694 ; + + fates_trs_seedling_light_mort_b = -7.154063, -7.154063, -7.154063, + -7.154063, -7.154063, -7.154063, -7.154063, -7.154063, -7.154063, + -7.154063, -7.154063, -7.154063 ; + + fates_trs_seedling_light_rec_a = 0.007, 0.007, 0.007, 0.007, 0.007, 0.007, + 0.007, 0.007, 0.007, 0.007, 0.007, 0.007 ; + + fates_trs_seedling_light_rec_b = 0.8615, 0.8615, 0.8615, 0.8615, 0.8615, + 0.8615, 0.8615, 0.8615, 0.8615, 0.8615, 0.8615, 0.8615 ; + + fates_trs_seedling_mdd_crit = 1400000, 1400000, 1400000, 1400000, 1400000, + 1400000, 1400000, 1400000, 1400000, 1400000, 1400000, 1400000 ; + + fates_trs_seedling_par_crit_germ = 0.656, 0.656, 0.656, 0.656, 0.656, 0.656, + 0.656, 0.656, 0.656, 0.656, 0.656, 0.656 ; + + fates_trs_seedling_psi_crit = -251995.7, -251995.7, -251995.7, -251995.7, + -251995.7, -251995.7, -251995.7, -251995.7, -251995.7, -251995.7, + -251995.7, -251995.7 ; + + fates_trs_seedling_psi_emerg = -15744.65, -15744.65, -15744.65, -15744.65, + -15744.65, -15744.65, -15744.65, -15744.65, -15744.65, -15744.65, + -15744.65, -15744.65 ; + + fates_trs_seedling_root_depth = 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, + 0.06, 0.06, 0.06, 0.06, 0.06 ; + fates_turb_displar = 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67 ; @@ -1529,30 +1701,34 @@ data: fates_phen_coldtemp = 7.5 ; - fates_phen_drought_model = 0 ; - - fates_phen_drought_threshold = 0.15 ; - fates_phen_gddthresh_a = -68 ; fates_phen_gddthresh_b = 638 ; fates_phen_gddthresh_c = -0.01 ; - fates_phen_mindaysoff = 100 ; - fates_phen_mindayson = 90 ; - fates_phen_moist_threshold = 0.18 ; - fates_phen_ncolddayslim = 5 ; fates_q10_froz = 1.5 ; fates_q10_mr = 1.5 ; + fates_rad_model = 1 ; + + fates_regeneration_model = 1 ; + fates_soil_salinity = 0.4 ; + fates_trs_seedling2sap_par_timescale = 32 ; + + fates_trs_seedling_emerg_h2o_timescale = 7 ; + + fates_trs_seedling_mdd_timescale = 126 ; + + fates_trs_seedling_mort_par_timescale = 32 ; + fates_vai_top_bin_width = 1 ; fates_vai_width_increase_factor = 1 ; diff --git a/parameter_files/archive/api26.0.0_042223_luh2.xml b/parameter_files/archive/api27.0.0_080923_luh2.xml similarity index 92% rename from parameter_files/archive/api26.0.0_042223_luh2.xml rename to parameter_files/archive/api27.0.0_080923_luh2.xml index 8b2afe7655..43b78ed11a 100644 --- a/parameter_files/archive/api26.0.0_042223_luh2.xml +++ b/parameter_files/archive/api27.0.0_080923_luh2.xml @@ -6,10 +6,10 @@ - + - + - archive/api25.4.0_042223_fates_params_default.cdl + archive/api25.5.0_080923_fates_params_default.cdl fates_params_default.cdl 1,2,3,4,5,6,7,8,9,10,11,12 diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 3c9f91b9a5..a9198319d0 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -817,19 +817,19 @@ variables: fates_maxcohort:long_name = "maximum number of cohorts per patch. Actual number of cohorts also depend on cohort fusion tolerances" ; double fates_maxpatch_cropland ; fates_maxpatch_cropland:units = "count" ; - fates_maxpatch_cropland:long_name = "maximum number of crop patches per site" ; + fates_maxpatch_cropland:long_name = "maximum number of cropland patches per site" ; double fates_maxpatch_pastureland ; fates_maxpatch_pastureland:units = "count" ; - fates_maxpatch_pastureland:long_name = "maximum number of pasture patches per site" ; - double fates_maxpatch_rangeland ; - fates_maxpatch_rangeland:units = "count" ; - fates_maxpatch_rangeland:long_name = "maximum number of rangeland patches per site" ; + fates_maxpatch_pastureland:long_name = "maximum number of pastureland patches per site" ; double fates_maxpatch_primaryland ; fates_maxpatch_primaryland:units = "count" ; fates_maxpatch_primaryland:long_name = "maximum number of primary vegetation patches per site" ; + double fates_maxpatch_rangeland ; + fates_maxpatch_rangeland:units = "count" ; + fates_maxpatch_rangeland:long_name = "maximum number of rangeland patches per site" ; double fates_maxpatch_secondaryland ; fates_maxpatch_secondaryland:units = "count" ; - fates_maxpatch_secondaryland:long_name = "maximum number of secondaryland vegetation patches per site" ; + fates_maxpatch_secondaryland:long_name = "maximum number of secondary vegetation patches per site" ; double fates_mort_disturb_frac ; fates_mort_disturb_frac:units = "fraction" ; fates_mort_disturb_frac:long_name = "fraction of canopy mortality that results in disturbance (i.e. transfer of area from new to old patch)" ; From 7ba2e79df2e70f8a346653c8e1f59908b6966ebd Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 10 Aug 2023 16:29:04 -0700 Subject: [PATCH 093/250] correct refactor merge issues --- biogeochem/EDPatchDynamicsMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index fa3a61bdc7..b45dd213a3 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -714,18 +714,18 @@ subroutine spawn_patches( currentSite, bc_in) ! correct boundary condition fields nc%prt => null() call InitPRTObject(nc%prt) - call InitPRTBoundaryConditions(nc) + call nc%InitPRTBoundaryConditions() ! (Keeping as an example) ! Allocate running mean functions !allocate(nc%tveg_lpa) !call nc%tveg_lpa%InitRMean(ema_lpa,init_value=new_patch%tveg_lpa%GetMean()) - call zero_cohort(nc) + call nc%ZeroValues() ! nc is the new cohort that goes in the disturbed patch (new_patch)... currentCohort ! is the curent cohort that stays in the donor patch (currentPatch) - call copy_cohort(currentCohort, nc) + call currentCohort%Copy(nc) !this is the case as the new patch probably doesn't have a closed canopy, and ! even if it does, that will be sorted out in canopy_structure. From 150271047867f54ac83e1569db41fb78b33e1986 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 10 Aug 2023 17:15:07 -0700 Subject: [PATCH 094/250] correcting additonal bad refactor merge --- biogeochem/EDPatchDynamicsMod.F90 | 24 ++++++++++++------------ biogeochem/FatesPatchMod.F90 | 5 +++-- main/EDMainMod.F90 | 2 +- 3 files changed, 16 insertions(+), 15 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index b45dd213a3..9454c58d8f 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -29,13 +29,13 @@ module EDPatchDynamicsMod use EDTypesMod , only : site_fluxdiags_type use EDTypesMod , only : min_patch_area use EDTypesMod , only : min_patch_area_forced - use EDTypesMod , only : dtype_ilandusechange use EDParamsMod , only : nclmax use EDParamsMod , only : regeneration_model use FatesInterfaceTypesMod, only : numpft use FatesConstantsMod , only : dtype_ifall use FatesConstantsMod , only : dtype_ilog use FatesConstantsMod , only : dtype_ifire + use FatesConstantsMod , only : dtype_ilandusechange use FatesConstantsMod , only : ican_upper use PRTGenericMod , only : num_elements use PRTGenericMod , only : element_list @@ -577,7 +577,7 @@ subroutine spawn_patches( currentSite, bc_in) allocate(new_patch) call new_patch%Create(age, site_areadis, i_landusechange_receiverpatchlabel, i_nocomp_pft, & - hlm_numSWb, numpft, sites(s)%nlevsoil, hlm_current_tod, & + hlm_numSWb, numpft, currentSite%nlevsoil, hlm_current_tod, & regeneration_model) ! Initialize the litter pools to zero, these @@ -1157,8 +1157,8 @@ subroutine spawn_patches( currentSite, bc_in) new_patch%shortest => nc nc%shorter => null() endif - nc%patchptr => new_patch - call insert_cohort(nc, new_patch%tallest, new_patch%shortest, & + !nc%patchptr => new_patch + call insert_cohort(new_patch, nc, new_patch%tallest, new_patch%shortest, & tnull, snull, storebigcohort, storesmallcohort) new_patch%tallest => storebigcohort @@ -1166,7 +1166,7 @@ subroutine spawn_patches( currentSite, bc_in) else ! Get rid of the new temporary cohort - call DeallocateCohort(nc) + call nc%FreeMemory() deallocate(nc, stat=istat, errmsg=smsg) if (istat/=0) then write(fates_log(),*) 'dealloc005: fail on deallocate(nc):'//trim(smsg) @@ -2140,17 +2140,17 @@ subroutine landusechange_litter_fluxes(currentSite, currentPatch, & use SFParamsMod, only : SF_VAL_CWD_FRAC ! ! !ARGUMENTS: - type(ed_site_type) , intent(inout), target :: currentSite - type(ed_patch_type) , intent(inout), target :: currentPatch ! Donor Patch - type(ed_patch_type) , intent(inout), target :: newPatch ! New Patch - real(r8) , intent(in) :: patch_site_areadis ! Area being donated - type(bc_in_type) , intent(in) :: bc_in - logical , intent(in) :: clearing_matrix_element ! whether or not to clear vegetation + type(ed_site_type) , intent(inout), target :: currentSite + type(fates_patch_type) , intent(inout), target :: currentPatch ! Donor Patch + type(fates_patch_type) , intent(inout), target :: newPatch ! New Patch + real(r8) , intent(in) :: patch_site_areadis ! Area being donated + type(bc_in_type) , intent(in) :: bc_in + logical , intent(in) :: clearing_matrix_element ! whether or not to clear vegetation ! ! !LOCAL VARIABLES: - type(ed_cohort_type), pointer :: currentCohort + type(fates_cohort_type), pointer :: currentCohort type(litter_type), pointer :: new_litt type(litter_type), pointer :: curr_litt type(site_massbal_type), pointer :: site_mass diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index b44c762fee..839021ca0c 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -3,7 +3,8 @@ module FatesPatchMod use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : fates_unset_r8 use FatesConstantsMod, only : fates_unset_int - use FatesConstantsMod, only : primaryforest, secondaryforest + use FatesConstantsMod, only : primaryland, secondaryland + use FatesConstantsMod, only : n_landuse_cats use FatesConstantsMod, only : TRS_regeneration use FatesGlobals, only : fates_log use FatesGlobals, only : endrun => fates_endrun @@ -592,7 +593,7 @@ subroutine Create(this, age, area, label, nocomp_pft, num_swb, num_pft, & ! assign anthropgenic disturbance category and label this%land_use_label = label - if (label .eq. secondaryforest) then + if (label .eq. secondaryland) then this%age_since_anthro_disturbance = age else this%age_since_anthro_disturbance = fates_unset_r8 diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 2c8c411581..39b425a9ee 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -470,7 +470,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) mean_temp = currentPatch%tveg24%GetMean() call Mortality_Derivative(currentSite, currentCohort, bc_in, & currentPatch%btran_ft, mean_temp, & - currentPatch%anthro_disturbance_label, & + currentPatch%land_use_label, & currentPatch%age_since_anthro_disturbance, frac_site_primary, & harvestable_forest_c, harvest_tag) From 698b91c3b04f64920c6ca6b19c91c690a376427b Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 15 Aug 2023 11:11:54 -0700 Subject: [PATCH 095/250] Add landuse to initialization procedures --- biogeochem/FatesPatchMod.F90 | 12 +++++++++--- main/FatesInterfaceMod.F90 | 7 ++++++- 2 files changed, 15 insertions(+), 4 deletions(-) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index 839021ca0c..fbef6dcfc4 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -365,7 +365,10 @@ subroutine NanValues(this) ! DISTURBANCE this%disturbance_rates(:) = nan - this%fract_ldist_not_harvested = nan + this%fract_ldist_not_harvested = nan + + ! LAND USE + this%landuse_transition_rates(:) = nan ! LITTER AND COARSE WOODY DEBRIS this%fragmentation_scaler(:) = nan @@ -389,8 +392,8 @@ subroutine NanValues(this) this%scorch_ht(:) = nan this%frac_burnt = nan this%tfc_ros = nan - this%burnt_frac_litter(:) = nan - + this%burnt_frac_litter(:) = nan + end subroutine NanValues !=========================================================================== @@ -443,6 +446,9 @@ subroutine ZeroValues(this) this%disturbance_rates(:) = 0.0_r8 this%fract_ldist_not_harvested = 0.0_r8 + ! LAND USE + this%landuse_transition_rates(:) = 0.0_r8 + ! LITTER AND COARSE WOODY DEBRIS this%fragmentation_scaler(:) = 0.0_r8 diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index d42f8badf4..7693e738a8 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -388,7 +388,12 @@ subroutine zero_bcs(fates,s) fates%bc_out(s)%ar_site = 0.0_r8 fates%bc_out(s)%hrv_deadstemc_to_prod10c = 0.0_r8 fates%bc_out(s)%hrv_deadstemc_to_prod100c = 0.0_r8 - + + if (hlm_use_luh .gt. 0) then + fates%bc_in(s)%hlm_luh_states = 0.0_r8 + fates%bc_in(s)%hlm_luh_transitions = 0.0_r8 + end if + return end subroutine zero_bcs From c55d7aebfb255aa05cf32c01f9d1be34c2b33bdb Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 15 Aug 2023 12:55:33 -0700 Subject: [PATCH 096/250] convert insert patch else if to case select --- biogeochem/EDPatchDynamicsMod.F90 | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index afda13de76..17a82c5e2d 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -3196,14 +3196,19 @@ subroutine InsertPatch(currentSite, newPatch) ! !USES: ! ! !ARGUMENTS: - type (ed_site_type), intent(inout) :: currentSite - type (ed_patch_type), intent(inout), pointer :: newPatch + type (ed_site_type), intent(inout) :: currentSite + type (fates_patch_type), intent(inout), pointer :: newPatch ! !LOCAL VARIABLES: - type (ed_patch_type), pointer :: currentPatch + type (fates_patch_type), pointer :: currentPatch integer :: insert_method ! Temporary dev logical :: found_landuselabel_match + integer, parameter :: unordered_lu_type = 1 + integer, parameter :: primaryland_oldest_type = 2 + integer, parameter :: numerical_order_lu_type = 3 + integer, parameter :: new_is_youngest_lu_type = 4 + ! Temporary hardcoded value for development testing insert_method = 2 ! Start from the youngest patch and work to oldest @@ -3229,7 +3234,8 @@ subroutine InsertPatch(currentSite, newPatch) ! If the current site youngest patch lutype doesn't match the new patch lutype ! work through the list until you find the matching type. If a match is not ! found, the currentPatch will be unassociated once it hits the end of the list - if (insert_method .eq. 1) then + select case(insert_method) + case (unordered_lu_type) then ! Option 1 - order of lutype groups does not matter found_landuselabel_match = .false. do while(associated(currentPatch) .and. .not. found_landuselabel_match) @@ -3257,7 +3263,7 @@ subroutine InsertPatch(currentSite, newPatch) currentSite%oldest_patch%older => newPatch currentSite%oldest_patch => newPatch endif - elseif (insert_method .eq. 2) then + case (primaryland_oldest_type) then ! Option 2 - primaryland group must be on the oldest end found_landuselabel_match = .false. do while(associated(currentPatch) .and. .not. found_landuselabel_match) @@ -3294,7 +3300,7 @@ subroutine InsertPatch(currentSite, newPatch) currentSite%youngest_patch => newPatch endif endif - elseif (insert_method .eq. 3) then + case (numerical_order_lu_type) then ! Option 3 - groups are numerically ordered with primaryland group starting at oldest end. ! If the youngest patch land use label number is greater than the new ! patch land use label number, the new patch must be inserted somewhere @@ -3325,13 +3331,13 @@ subroutine InsertPatch(currentSite, newPatch) currentSite%oldest_patch%older => newPatch currentSite%oldest_patch => newPatch endif - elseif (insert_method .eq. 4) then + case (new_is_youngest_lu_type) then ! Option 4 - always add the new patch as the youngest regardless of lutype match newPatch%older => currentPatch newPatch%younger => null() currentPatch%younger => newPatch currentSite%youngest_patch => newPatch - end if + end select end if From ae880a8150d2c5d8077c3d64b6b93890bd54fa4a Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 17 Aug 2023 15:42:34 -0700 Subject: [PATCH 097/250] update case names for InsertPatch and clarify comments --- biogeochem/EDPatchDynamicsMod.F90 | 189 ++++++++++++++++-------------- 1 file changed, 99 insertions(+), 90 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 17a82c5e2d..22c215e976 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -3203,144 +3203,153 @@ subroutine InsertPatch(currentSite, newPatch) type (fates_patch_type), pointer :: currentPatch integer :: insert_method ! Temporary dev logical :: found_landuselabel_match - integer, parameter :: unordered_lu_type = 1 - integer, parameter :: primaryland_oldest_type = 2 - integer, parameter :: numerical_order_lu_type = 3 - integer, parameter :: new_is_youngest_lu_type = 4 - - ! Temporary hardcoded value for development testing - insert_method = 2 - - ! Start from the youngest patch and work to oldest + integer, parameter :: unordered_lul_groups= 1 + integer, parameter :: primaryland_oldest_group = 2 + integer, parameter :: numerical_order_lul_groups = 3 + integer, parameter :: age_order_only = 4 + + ! Insert new patch case options: + ! Option 1: Group the landuse types together, but the group order doesn't matter + ! Option 2: Option 1, but primarylands are forced to be the oldest group + ! Option 3: Option 1, but groups are in numerical order according to land use label index integer + ! (i.e. primarylands=1, secondarylands=2, ..., croplands=5) + ! Option 4: Don't group the patches by land use label. Simply add new patches to the youngest end. + + ! Hardcode the default insertion method. The options developed during FATES V1 land use are + ! currently being held for potential future usage. + insert_method = primaryland_oldest_group + + ! Start from the youngest patch and work to oldest, regarless of insertion_method currentPatch => currentSite%youngest_patch - ! TODO: Test alternate methods - ! Insert new patch as the youngest patch in the group of patches with the same land use type. - ! On a given site, the patches are grouped together by land use type. - ! Option 1: The landuse type group order doesn't matter at all - ! Option 2: The order of the groups within the site doesn't matter, except that the older - ! Option 3: Abitrarily set the group order to numerical order with older being primaryland (similar to previous logic) - ! patch group are primarylands (similar to the previous logic) - ! Option 4: landuse type order doesn't matter, only age - + ! For the three grouped cases, if the land use label of the youngest patch on the site + ! is a match to the new patch land use label, simply insert it as the new youngest. + ! This is applicable to the non-grouped option 4 method as well. if (currentPatch%land_use_label .eq. newPatch%land_use_label ) then - ! Regardless of method, if the land use type of the youngest patch on the site - ! is a match to the new patch land use type, simply insert it as the new youngest newPatch%older => currentPatch newPatch%younger => null() currentPatch%younger => newPatch currentSite%youngest_patch => newPatch else - ! If the current site youngest patch lutype doesn't match the new patch lutype - ! work through the list until you find the matching type. If a match is not - ! found, the currentPatch will be unassociated once it hits the end of the list + + ! If the current site youngest patch land use label doesn't match the new patch + ! land use label then work through the list until you find the matching type. + ! Since we've just checked the youngest patch, move to the next patch and + ! initialize the match flag to false. + found_landuselabel_match = .false. + currentPatch => currentPatch%older select case(insert_method) - case (unordered_lu_type) then - ! Option 1 - order of lutype groups does not matter - found_landuselabel_match = .false. + + ! Option 1 - order of land use label groups does not matter + case (unordered_lul_groups) then + do while(associated(currentPatch) .and. .not. found_landuselabel_match) - currentPatch => currentPatch%older - if (associated(currentPatch)) then - if (currentPatch%land_use_label .eq. newPatch%land_use_label) then - found_landuselabel_match = .true. - endif - endif + if (currentPatch%land_use_label .eq. newPatch%land_use_label) then + found_landuselabel_match = .true. + else + currentPatch => currentPatch%older + end if end do + + ! In the case where we've found a land use label matching the new patch label, + ! insert the newPatch will as the youngest patch for that land use type. if (associated(currentPatch)) then - ! The case where we've found a patch type matching the new patch type. - ! In this case insert the newPatch will as the youngest patch for that - ! land use type. - newPatch%older => currentPatch - newPatch%younger => currentPatch%younger + newPatch%older => currentPatch + newPatch%younger => currentPatch%younger currentPatch%younger%older => newPatch currentPatch%younger => newPatch else - ! The case in which we get to the end of the list and haven't found - ! a landuse type match. If this is the case, simply add the new patch - ! to the end of the list - newPatch%older => null() - newPatch%younger => currentSite%oldest_patch - currentSite%oldest_patch%older => newPatch - currentSite%oldest_patch => newPatch + ! In the case in which we get to the end of the list and haven't found + ! a landuse label match simply add the new patch to the youngest end. + newPatch%older => currentSite%youngest_patch + newPatch%younger => null() + currentSite%youngest_patch%younger => newPatch + currentSite%youngest_patch => newPatch endif - case (primaryland_oldest_type) then - ! Option 2 - primaryland group must be on the oldest end - found_landuselabel_match = .false. + + ! Option 2 - primaryland group must be on the oldest end + case (primaryland_oldest_group) then + do while(associated(currentPatch) .and. .not. found_landuselabel_match) - currentPatch => currentPatch%older - if (associated(currentPatch)) then - if (currentPatch%land_use_label .eq. newPatch%land_use_label) then - found_landuselabel_match = .true. - endif - endif + if (currentPatch%land_use_label .eq. newPatch%land_use_label) then + found_landuselabel_match = .true. + else + currentPatch => currentPatch%older + end if end do + + ! In the case where we've found a land use label matching the new patch label, + ! insert the newPatch will as the youngest patch for that land use type. if (associated(currentPatch)) then - ! The case where we've found a patch type matching the new patch type. - ! In this case insert the newPatch will as the youngest patch for that - ! land use type. - newPatch%older => currentPatch - newPatch%younger => currentPatch%younger + newPatch%older => currentPatch + newPatch%younger => currentPatch%younger currentPatch%younger%older => newPatch currentPatch%younger => newPatch else + ! In the case in which we get to the end of the list and haven't found + ! a landuse label match. + + ! If the new patch is primarylands add it to the oldest end of the list if (newPatch%land_use_label .eq. primaryland) then - ! The case in which we get to the end of the list and haven't found - ! a landuse type match. If this is the case, add it to the oldest side - ! if primarland - newPatch%older => null() - newPatch%younger => currentSite%oldest_patch - currentSite%oldest_patch%older => newPatch - currentSite%oldest_patch => newPatch + newPatch%older => null() + newPatch%younger => currentSite%oldest_patch + currentSite%oldest_patch%older => newPatch + currentSite%oldest_patch => newPatch else - ! If the new patch land use type is not primary land and we are at the - ! oldest end of the list, add it to the beginning - newPatch%older => currentSite%youngest_patch - newPatch%younger => null() + ! If the new patch land use type is not primaryland and we are at the + ! oldest end of the list, add it to the youngest end + newPatch%older => currentSite%youngest_patch + newPatch%younger => null() currentSite%youngest_patch%younger => newPatch - currentSite%youngest_patch => newPatch + currentSite%youngest_patch => newPatch endif endif - case (numerical_order_lu_type) then - ! Option 3 - groups are numerically ordered with primaryland group starting at oldest end. - ! If the youngest patch land use label number is greater than the new + + ! Option 3 - groups are numerically ordered with primaryland group starting at oldest end. + case (numerical_order_lul_groups) then + + ! If the youngest patch landuse label number is greater than the new ! patch land use label number, the new patch must be inserted somewhere ! in between oldest and youngest - found_landuselabel_match = .false. do while(associated(currentPatch) .and. .not. found_landuselabel_match) - currentPatch => currentPatch%older - if (associated(currentPatch)) then - if (newPatch%land_use_label .eq. currentPatch%land_use_label .or. & - newPatch%land_use_label .gt. currentPatch%land_use_label) then - found_landuselabel_match = .true. - endif + if (currentPatch%land_use_label .eq. newPatch%land_use_label .or. & + currentPatch%land_use_label .lt. newPatch%land_use_label) then + found_landuselabel_match = .true. + else + currentPatch => currentPatch%older endif end do + + ! In the case where we've found a landuse label matching the new patch label + ! insert the newPatch will as the youngest patch for that land use type. if (associated(currentPatch)) then - ! The case where we've found a patch type matching the new patch type. - ! In this case insert the newPatch will as the youngest patch for that - ! land use type. + newPatch%older => currentPatch newPatch%younger => currentPatch%younger currentPatch%younger%older => newPatch currentPatch%younger => newPatch + else + ! In the case were we get to the end, the new patch ! must be numerically the smallest, so put it at the oldest position newPatch%older => null() newPatch%younger => currentSite%oldest_patch currentSite%oldest_patch%older => newPatch currentSite%oldest_patch => newPatch + endif - case (new_is_youngest_lu_type) then - ! Option 4 - always add the new patch as the youngest regardless of lutype match - newPatch%older => currentPatch - newPatch%younger => null() - currentPatch%younger => newPatch - currentSite%youngest_patch => newPatch + + ! Option 4 - always add the new patch as the youngest regardless of land use label + case (age_order_only) then + ! Set the current patch to the youngest patch + newPatch%older => currentSite%youngest_patch + newPatch%younger => null() + currentSite%youngest_patch%younger => newPatch + currentSite%youngest_patch => newPatch end select end if - end subroutine InsertPatch end module EDPatchDynamicsMod From b640df07132617ffab5d2932941274139602f8b5 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 17 Aug 2023 17:05:22 -0700 Subject: [PATCH 098/250] Update the terminate patch process for fusion of different landuse labels Use a simple scheme in which we fuse the very young patch into the largest patch in the list --- biogeochem/EDPatchDynamicsMod.F90 | 175 ++++++++++++++++-------------- 1 file changed, 91 insertions(+), 84 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 900c69bed4..43bb532244 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2917,6 +2917,7 @@ subroutine terminate_patches(currentSite) type(fates_patch_type), pointer :: olderPatch type(fates_patch_type), pointer :: youngerPatch type(fates_patch_type), pointer :: patchpointer + type(fates_patch_type), pointer :: largestPatch integer, parameter :: max_cycles = 10 ! After 10 loops through ! You should had fused integer :: count_cycles @@ -2925,16 +2926,21 @@ subroutine terminate_patches(currentSite) real(r8) areatot ! variable for checking whether the total patch area is wrong. !--------------------------------------------------------------------- - + + ! Initialize the count cycles count_cycles = 0 + ! Start at the youngest patch in the list and assume that the largest patch is this patch currentPatch => currentSite%youngest_patch + largestPatch => currentPatch do while(associated(currentPatch)) lessthan_min_patcharea_if: if(currentPatch%area <= min_patch_area)then - + + ! Initialize gotfused flag for both nocomp and all other cases + gotfused = .false. + nocomp_if: if (hlm_use_nocomp .eq. itrue) then - gotfused = .false. patchpointer => currentSite%youngest_patch do while(associated(patchpointer)) if ( .not.associated(currentPatch,patchpointer) .and. & @@ -2958,93 +2964,94 @@ subroutine terminate_patches(currentSite) else nocomp_if - ! Determine if the current patch is the youngest in the land use grouping - ! If the 'younger' patch is a different land use then the current is the youngest - ! per the InsertPatch subroutine. That said it could also be the only patch and - ! also the oldest. Should we handle that distinction? - current_patch_is_youngest_lutype = .false. - if (currentPatch%younger%land_use_label .ne. currentPatch%land_use_label) current_patch_is_youngest_lutype = .true. - - ! Even if the patch area is small, avoid fusing it into its neighbor - ! if it is the youngest of all patches. We do this in attempts to maintain - ! a discrete patch for very young patches - ! However, if the patch to be fused is excessivlely small, then fuse - ! at all costs. If it is not fused, it will make - notyoungest_if: if ( .not. current_patch_is_youngest_lutype .or. & - currentPatch%area <= min_patch_area_forced ) then - - gotfused = .false. - - associated_older_if: if(associated(currentPatch%older) )then - - if(debug) & - write(fates_log(),*) 'fusing to older patch because this one is too small',& - currentPatch%area, & - currentPatch%older%area - - ! We set a pointer to this patch, because - ! it will be returned by the subroutine as de-referenced - - olderPatch => currentPatch%older - - distlabel_1_if: if (currentPatch%land_use_label .eq. olderPatch%land_use_label) then - - call fuse_2_patches(currentSite, olderPatch, currentPatch) - - ! The fusion process has updated the "older" pointer on currentPatch - ! for us. - - ! This logic checks to make sure that the younger patch is not the youngest - ! patch. As mentioned earlier, we try not to fuse it. - - gotfused = .true. - else distlabel_1_if !i.e. anthro labels of two patches are not the same - countcycles_if: if (count_cycles .gt. 0) then - ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, - ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its older sibling - ! and then allow them to fuse together. - ! We also assigned the age since disturbance value to be the younger (donor) patch to avoid combining a valid - ! age with fates_unset_r8 (i.e. the age for primaryland) in the fuse_2_patches procedure - ! Note that given the grouping of landuse types in the linked list, this could result in very small patches - ! being fused to much larger patches - currentPatch%land_use_label = olderPatch%land_use_label - currentPatch%age_since_anthro_disturbance = olderPatch%age_since_anthro_disturbance + ! Check to see if the current patch is the largest patch so far and update if it is + if (currentPatch%area .gt. largestPatch%area) then largestPatch => currentPatch + + ! Determine if the current patch is the youngest in the land use grouping + ! If the 'younger' patch has a different landuse label then the current is the youngest + ! per the InsertPatch subroutine. That said it could also be the only patch and + ! also the oldest. Should we handle that distinction? + current_patch_is_youngest_lutype = .false. + if (currentPatch%younger%land_use_label .ne. currentPatch%land_use_label) current_patch_is_youngest_lutype = .true. + + ! Even if the patch area is small, avoid fusing it into its neighbor + ! if it is the youngest of all patches. We do this in attempts to maintain + ! a discrete patch for very young patches. + ! However, if the patch to be fused is excessively small, then fuse at all costs. + notyoungest_if: if ( .not. current_patch_is_youngest_lutype .or. currentPatch%area <= min_patch_area_forced ) then + + ! Determine if there is an older patch available + associated_older_if: if(associated(currentPatch%older)) then + + if(debug) & + write(fates_log(),*) 'fusing to older patch because this one is too small',& + currentPatch%area, & + currentPatch%older%area + + olderPatch => currentPatch%older + + ! If the older patch has the same landuse label fuse the older (donor) patch into the current patch + distlabel_1_if: if (currentPatch%land_use_label .eq. olderPatch%land_use_label) then + call fuse_2_patches(currentSite, olderPatch, currentPatch) gotfused = .true. - endif countcycles_if - endif distlabel_1_if - endif associated_older_if - - not_gotfused_if: if( .not. gotfused .and. associated(currentPatch%younger) ) then - - if(debug) & - write(fates_log(),*) 'fusing to younger patch because oldest one is too small', & - currentPatch%area - youngerPatch => currentPatch%younger + else distlabel_1_if + + ! If we're having an incredibly hard time fusing patches because of their differing + ! landuse labels (i.e. the count_cycles is more than zero), then fuse the current + ! patch with the largest patch regardless of landuse label. + countcycles_if: if (count_cycles .gt. 0) then + + ! Work through the rest of the list to find the largest patch + do while (associated(olderPatch)) + if (olderPatch%area .gt. largestPatch%area) then largestPatch => olderPatch + olderPatch => olderPatch%older + end do + + ! Set the donor patch label to match the reciever patch label to avoid an error + ! due to a label check inside fuse_2_patches + currentPatch%land_use_label = largestPatch%land_use_label + + ! We also assign the age since disturbance value to be the younger (donor) patch to avoid combining a valid + ! age with fates_unset_r8 (i.e. the age for primaryland) in the fuse_2_patches procedure + currentPatch%age_since_anthro_disturbance = largestPatch%age_since_anthro_disturbance + call fuse_2_patches(currentSite, currentPatch, largestPatch) + gotfused = .true. + endif countcycles_if + endif distlabel_1_if + endif associated_older_if + + not_gotfused_if: if( .not. gotfused .and. associated(currentPatch%younger) ) then + + if(debug) & + write(fates_log(),*) 'fusing to younger patch because oldest one is too small', & + currentPatch%area + + youngerPatch => currentPatch%younger + + distlabel_2_if: if (currentPatch%land_use_label .eq. youngerPatch% land_use_label) then - distlabel_2_if: if (currentPatch%land_use_label .eq. youngerPatch% land_use_label) then - - call fuse_2_patches(currentSite, youngerPatch, currentPatch) - - ! The fusion process has updated the "younger" pointer on currentPatch - gotfused = .true. - else distlabel_2_if - if (count_cycles .gt. 0) then - ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, - ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its younger sibling - ! We also assigned the age since disturbance value to be the younger (donor) patch to avoid combining a valid - ! age with fates_unset_r8 (i.e. the age for primaryland) in the fuse_2_patches procedure - ! Note that given the grouping of landuse types in the linked list, this could result in very small patches - ! being fused to much larger patches - currentPatch%land_use_label = youngerPatch%land_use_label - currentPatch%age_since_anthro_disturbance = youngerPatch%age_since_anthro_disturbance call fuse_2_patches(currentSite, youngerPatch, currentPatch) + + ! The fusion process has updated the "younger" pointer on currentPatch gotfused = .true. - endif ! count cycles - endif distlabel_2_if ! anthro labels - endif not_gotfused_if ! has an older patch - endif notyoungest_if ! is not the youngest patch + else distlabel_2_if + if (count_cycles .gt. 0) then + ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, + ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its younger sibling + ! We also assigned the age since disturbance value to be the younger (donor) patch to avoid combining a valid + ! age with fates_unset_r8 (i.e. the age for primaryland) in the fuse_2_patches procedure + ! Note that given the grouping of landuse types in the linked list, this could result in very small patches + ! being fused to much larger patches + currentPatch%land_use_label = largestPatch%land_use_label + currentPatch%age_since_anthro_disturbance = largestPatch%age_since_anthro_disturbance + call fuse_2_patches(currentSite, currentPatch, largestPatch) + gotfused = .true. + endif ! count cycles + endif distlabel_2_if ! anthro labels + endif not_gotfused_if ! has an older patch + endif notyoungest_if ! is not the youngest patch endif nocomp_if endif lessthan_min_patcharea_if ! very small patch From 0da2f9246e88250d58f5f7851a5bb30c62ec13cd Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 18 Aug 2023 15:52:38 -0700 Subject: [PATCH 099/250] correct case statements and variable name mismatch --- biogeochem/EDPatchDynamicsMod.F90 | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 22c215e976..ef9f3aa7b6 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -444,7 +444,7 @@ subroutine spawn_patches( currentSite, bc_in) type (bc_in_type), intent(in) :: bc_in ! ! !LOCAL VARIABLES: - type (fates_patch_type) , pointer :: new_patch + type (fates_patch_type) , pointer :: newPatch ! type (fates_patch_type) , pointer :: new_patch_primary ! type (fates_patch_type) , pointer :: new_patch_secondary type (fates_patch_type) , pointer :: currentPatch @@ -575,7 +575,7 @@ subroutine spawn_patches( currentSite, bc_in) ! create an empty patch, to absorb newly disturbed area allocate(newPatch) - call new_patch%Create(age, site_areadis, i_landusechange_receiverpatchlabel, i_nocomp_pft, & + call newPatch%Create(age, site_areadis, i_landusechange_receiverpatchlabel, i_nocomp_pft, & hlm_numSWb, numpft, currentSite%nlevsoil, hlm_current_tod, & regeneration_model) @@ -684,16 +684,16 @@ subroutine spawn_patches( currentSite, bc_in) if ( regeneration_model == TRS_regeneration ) then - call new_patch%seedling_layer_par24%CopyFromDonor(currentPatch%seedling_layer_par24) - call new_patch%sdlng_mort_par%CopyFromDonor(currentPatch%sdlng_mort_par) - call new_patch%sdlng2sap_par%CopyFromDonor(currentPatch%sdlng2sap_par) + call newPatch%seedling_layer_par24%CopyFromDonor(currentPatch%seedling_layer_par24) + call newPatch%sdlng_mort_par%CopyFromDonor(currentPatch%sdlng_mort_par) + call newPatch%sdlng2sap_par%CopyFromDonor(currentPatch%sdlng2sap_par) do pft = 1,numpft - call new_patch%sdlng_emerg_smp(pft)%p%CopyFromDonor(currentPatch%sdlng_emerg_smp(pft)%p) - call new_patch%sdlng_mdd(pft)%p%CopyFromDonor(currentPatch%sdlng_mdd(pft)%p) + call newPatch%sdlng_emerg_smp(pft)%p%CopyFromDonor(currentPatch%sdlng_emerg_smp(pft)%p) + call newPatch%sdlng_mdd(pft)%p%CopyFromDonor(currentPatch%sdlng_mdd(pft)%p) enddo end if - call new_patch%tveg_longterm%CopyFromDonor(currentPatch%tveg_longterm) + call newPatch%tveg_longterm%CopyFromDonor(currentPatch%tveg_longterm) ! -------------------------------------------------------------------------- ! The newly formed patch from disturbance (newPatch), has now been given @@ -1157,7 +1157,7 @@ subroutine spawn_patches( currentSite, bc_in) nc%shorter => null() endif !nc%patchptr => new_patch - call insert_cohort(new_patch, nc, new_patch%tallest, new_patch%shortest, & + call insert_cohort(newPatch, nc, newPatch%tallest, newPatch%shortest, & tnull, snull, storebigcohort, storesmallcohort) newPatch%tallest => storebigcohort @@ -3241,7 +3241,7 @@ subroutine InsertPatch(currentSite, newPatch) select case(insert_method) ! Option 1 - order of land use label groups does not matter - case (unordered_lul_groups) then + case (unordered_lul_groups) do while(associated(currentPatch) .and. .not. found_landuselabel_match) if (currentPatch%land_use_label .eq. newPatch%land_use_label) then @@ -3268,7 +3268,7 @@ subroutine InsertPatch(currentSite, newPatch) endif ! Option 2 - primaryland group must be on the oldest end - case (primaryland_oldest_group) then + case (primaryland_oldest_group) do while(associated(currentPatch) .and. .not. found_landuselabel_match) if (currentPatch%land_use_label .eq. newPatch%land_use_label) then @@ -3306,7 +3306,7 @@ subroutine InsertPatch(currentSite, newPatch) endif ! Option 3 - groups are numerically ordered with primaryland group starting at oldest end. - case (numerical_order_lul_groups) then + case (numerical_order_lul_groups) ! If the youngest patch landuse label number is greater than the new ! patch land use label number, the new patch must be inserted somewhere @@ -3341,7 +3341,7 @@ subroutine InsertPatch(currentSite, newPatch) endif ! Option 4 - always add the new patch as the youngest regardless of land use label - case (age_order_only) then + case (age_order_only) ! Set the current patch to the youngest patch newPatch%older => currentSite%youngest_patch newPatch%younger => null() From cc967cfc4a07aadc456e11c4b634d3d1e3ea01b2 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 18 Aug 2023 16:02:22 -0700 Subject: [PATCH 100/250] fix single line if statements --- biogeochem/EDPatchDynamicsMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 43bb532244..32bef38c25 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2965,7 +2965,7 @@ subroutine terminate_patches(currentSite) else nocomp_if ! Check to see if the current patch is the largest patch so far and update if it is - if (currentPatch%area .gt. largestPatch%area) then largestPatch => currentPatch + if (currentPatch%area .gt. largestPatch%area) largestPatch => currentPatch ! Determine if the current patch is the youngest in the land use grouping ! If the 'younger' patch has a different landuse label then the current is the youngest @@ -3005,7 +3005,7 @@ subroutine terminate_patches(currentSite) ! Work through the rest of the list to find the largest patch do while (associated(olderPatch)) - if (olderPatch%area .gt. largestPatch%area) then largestPatch => olderPatch + if (olderPatch%area .gt. largestPatch%area) largestPatch => olderPatch olderPatch => olderPatch%older end do From f6687de661dfdbc524620e4be2d22f7acd4211cb Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 18 Aug 2023 16:36:25 -0700 Subject: [PATCH 101/250] adjust patch termination comments --- biogeochem/EDPatchDynamicsMod.F90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 031ecda667..31133093db 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -3002,11 +3002,15 @@ subroutine terminate_patches(currentSite) if (count_cycles .gt. 0) then ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its younger sibling - ! We also assigned the age since disturbance value to be the younger (donor) patch to avoid combining a valid - ! age with fates_unset_r8 (i.e. the age for primaryland) in the fuse_2_patches procedure ! Note that given the grouping of landuse types in the linked list, this could result in very small patches + ! being fused to much larger patches + ! Set the donor patch label to match the reciever patch label to avoid an error + ! due to a label check inside fuse_2_patches currentPatch%land_use_label = largestPatch%land_use_label + + ! We also assigned the age since disturbance value to be the younger (donor) patch to avoid combining a valid + ! age with fates_unset_r8 (i.e. the age for primaryland) in the fuse_2_patches procedure currentPatch%age_since_anthro_disturbance = largestPatch%age_since_anthro_disturbance call fuse_2_patches(currentSite, currentPatch, largestPatch) gotfused = .true. From 0dce77f0a00ab5165ca2bd62fb80a5261f03c57f Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 18 Aug 2023 22:45:27 -0700 Subject: [PATCH 102/250] correct logic for checking youngest landuse type patch --- biogeochem/EDPatchDynamicsMod.F90 | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 31133093db..d986e9f47a 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2934,7 +2934,16 @@ subroutine terminate_patches(currentSite) ! per the InsertPatch subroutine. That said it could also be the only patch and ! also the oldest. Should we handle that distinction? current_patch_is_youngest_lutype = .false. - if (currentPatch%younger%land_use_label .ne. currentPatch%land_use_label) current_patch_is_youngest_lutype = .true. + + ! Check if the current patch is already the youngest patch on the site + if (associated(currentPatch,currentSite%youngest_patch)) then + current_patch_is_youngest_lutype = .true. + else + ! Otherwise check to see if the younger patch is a different landuse label + if (currentPatch%younger%land_use_label .ne. currentPatch%land_use_label) then + current_patch_is_youngest_lutype = .true. + end if + end if ! Even if the patch area is small, avoid fusing it into its neighbor ! if it is the youngest of all patches. We do this in attempts to maintain @@ -2955,6 +2964,7 @@ subroutine terminate_patches(currentSite) ! If the older patch has the same landuse label fuse the older (donor) patch into the current patch distlabel_1_if: if (currentPatch%land_use_label .eq. olderPatch%land_use_label) then + write(fates_log(),*) 'terminate: fused to older patch, same label: ', currentPatch%land_use_label, olderPatch%land_use_label call fuse_2_patches(currentSite, olderPatch, currentPatch) gotfused = .true. @@ -2971,6 +2981,8 @@ subroutine terminate_patches(currentSite) olderPatch => olderPatch%older end do + write(fates_log(),*) 'terminate: fuse to largest patch, diff label: ', currentPatch%land_use_label, largestPatch%land_use_label + ! Set the donor patch label to match the reciever patch label to avoid an error ! due to a label check inside fuse_2_patches currentPatch%land_use_label = largestPatch%land_use_label @@ -2980,6 +2992,7 @@ subroutine terminate_patches(currentSite) currentPatch%age_since_anthro_disturbance = largestPatch%age_since_anthro_disturbance call fuse_2_patches(currentSite, currentPatch, largestPatch) gotfused = .true. + endif countcycles_if endif distlabel_1_if endif associated_older_if @@ -2994,19 +3007,22 @@ subroutine terminate_patches(currentSite) distlabel_2_if: if (currentPatch%land_use_label .eq. youngerPatch% land_use_label) then + write(fates_log(),*) 'terminate: fused to younger patch, same label: ', currentPatch%land_use_label, youngerPatch%land_use_label call fuse_2_patches(currentSite, youngerPatch, currentPatch) ! The fusion process has updated the "younger" pointer on currentPatch gotfused = .true. + else distlabel_2_if if (count_cycles .gt. 0) then ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its younger sibling ! Note that given the grouping of landuse types in the linked list, this could result in very small patches - ! being fused to much larger patches + ! Set the donor patch label to match the reciever patch label to avoid an error ! due to a label check inside fuse_2_patches + write(fates_log(),*) 'terminate: fuse to largest patch, diff label: ', currentPatch%land_use_label, largestPatch%land_use_label currentPatch%land_use_label = largestPatch%land_use_label ! We also assigned the age since disturbance value to be the younger (donor) patch to avoid combining a valid @@ -3014,6 +3030,7 @@ subroutine terminate_patches(currentSite) currentPatch%age_since_anthro_disturbance = largestPatch%age_since_anthro_disturbance call fuse_2_patches(currentSite, currentPatch, largestPatch) gotfused = .true. + endif ! count cycles endif distlabel_2_if ! anthro labels endif not_gotfused_if ! has an older patch From f0e8aa14bc6cd695857d093513b6b9f7f18bfeac Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 21 Aug 2023 09:12:48 -0700 Subject: [PATCH 103/250] add debug check to write statements in fusion --- biogeochem/EDPatchDynamicsMod.F90 | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index d986e9f47a..da9296a8d7 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2964,7 +2964,9 @@ subroutine terminate_patches(currentSite) ! If the older patch has the same landuse label fuse the older (donor) patch into the current patch distlabel_1_if: if (currentPatch%land_use_label .eq. olderPatch%land_use_label) then - write(fates_log(),*) 'terminate: fused to older patch, same label: ', currentPatch%land_use_label, olderPatch%land_use_label + if(debug) & + write(fates_log(),*) 'terminate: fused to older patch, same label: ', currentPatch%land_use_label, olderPatch%land_use_label + call fuse_2_patches(currentSite, olderPatch, currentPatch) gotfused = .true. @@ -2981,7 +2983,8 @@ subroutine terminate_patches(currentSite) olderPatch => olderPatch%older end do - write(fates_log(),*) 'terminate: fuse to largest patch, diff label: ', currentPatch%land_use_label, largestPatch%land_use_label + if(debug) & + write(fates_log(),*) 'terminate: fuse to largest patch, diff label: ', currentPatch%land_use_label, largestPatch%land_use_label ! Set the donor patch label to match the reciever patch label to avoid an error ! due to a label check inside fuse_2_patches @@ -3007,7 +3010,9 @@ subroutine terminate_patches(currentSite) distlabel_2_if: if (currentPatch%land_use_label .eq. youngerPatch% land_use_label) then - write(fates_log(),*) 'terminate: fused to younger patch, same label: ', currentPatch%land_use_label, youngerPatch%land_use_label + if(debug) & + write(fates_log(),*) 'terminate: fused to younger patch, same label: ', currentPatch%land_use_label, youngerPatch%land_use_label + call fuse_2_patches(currentSite, youngerPatch, currentPatch) ! The fusion process has updated the "younger" pointer on currentPatch @@ -3019,10 +3024,11 @@ subroutine terminate_patches(currentSite) ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its younger sibling ! Note that given the grouping of landuse types in the linked list, this could result in very small patches ! being fused to much larger patches + if(debug) & + write(fates_log(),*) 'terminate: fuse to largest patch, diff label: ', currentPatch%land_use_label, largestPatch%land_use_label ! Set the donor patch label to match the reciever patch label to avoid an error ! due to a label check inside fuse_2_patches - write(fates_log(),*) 'terminate: fuse to largest patch, diff label: ', currentPatch%land_use_label, largestPatch%land_use_label currentPatch%land_use_label = largestPatch%land_use_label ! We also assigned the age since disturbance value to be the younger (donor) patch to avoid combining a valid From 6782b4ae70b6df4009b2ddf029d95ad9e83824a4 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 24 Aug 2023 11:26:00 -0400 Subject: [PATCH 104/250] removing layer height profile, for now --- biogeochem/FatesPatchMod.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index 2c185d55a1..36323e527a 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -111,7 +111,6 @@ module FatesPatchMod real(r8) :: c_lblayer ! mean boundary layer conductance of all leaves in the patch [umol/m2/s] !TODO - can we delete these? - real(r8) :: layer_height_profile(nclmax,maxpft,nlevleaf) real(r8) :: psn_z(nclmax,maxpft,nlevleaf) real(r8) :: nrmlzd_parprof_pft_dir_z(n_rad_stream_types,nclmax,maxpft,nlevleaf) real(r8) :: nrmlzd_parprof_pft_dif_z(n_rad_stream_types,nclmax,maxpft,nlevleaf) @@ -309,7 +308,6 @@ subroutine NanValues(this) this%ncan(:,:) = fates_unset_int this%c_stomata = nan this%c_lblayer = nan - this%layer_height_profile(:,:,:) = nan this%psn_z(:,:,:) = nan this%nrmlzd_parprof_pft_dir_z(:,:,:,:) = nan From b1f36bc8ab296b287ea32c25db3e22e028c9be55 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 5 Sep 2023 16:08:45 -0700 Subject: [PATCH 105/250] add landuse x pft dimension --- main/FatesHistoryInterfaceMod.F90 | 41 ++++++++++++++++++++++++++++--- main/FatesIODimensionsMod.F90 | 8 +++++- main/FatesIOVariableKindMod.F90 | 1 + 3 files changed, 45 insertions(+), 5 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 381d967231..7daee7ae2c 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -766,7 +766,7 @@ module FatesHistoryInterfaceMod integer, private :: levelcwd_index_, levelage_index_ integer, private :: levcacls_index_, levcapf_index_ integer, private :: levclscpf_index_ - integer, private :: levlanduse_index_, levlulu_index_ + integer, private :: levlanduse_index_, levlulu_index_, levlupft_index_ contains @@ -811,6 +811,7 @@ module FatesHistoryInterfaceMod procedure :: levclscpf_index procedure :: levlanduse_index procedure :: levlulu_index + procedure :: levlupft_index ! private work functions procedure, private :: define_history_vars @@ -841,6 +842,7 @@ module FatesHistoryInterfaceMod procedure, private :: set_levclscpf_index procedure, private :: set_levlanduse_index procedure, private :: set_levlulu_index + procedure, private :: set_levlupft_index procedure, private :: set_levelem_index procedure, private :: set_levelpft_index @@ -879,7 +881,7 @@ subroutine Init(this, num_threads, fates_bounds) use FatesIODimensionsMod, only : levelem, levelpft use FatesIODimensionsMod, only : levelcwd, levelage, levclscpf use FatesIODimensionsMod, only : levcdpf, levcdsc, levcdam - use FatesIODimensionsMod, only : levlanduse, levlulu + use FatesIODimensionsMod, only : levlanduse, levlulu, levlupft implicit none @@ -1029,6 +1031,11 @@ subroutine Init(this, num_threads, fates_bounds) call this%dim_bounds(dim_count)%Init(levlulu, num_threads, & fates_bounds%lulu_begin, fates_bounds%lulu_end) + dim_count = dim_count + 1 + call this%set_levlupft_index(dim_count) + call this%dim_bounds(dim_count)%Init(levlupft, num_threads, & + fates_bounds%lupft_begin, fates_bounds%lupft_end) + end subroutine Init ! ====================================================================== @@ -1157,6 +1164,10 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%lulu_begin, thread_bounds%lulu_end) + index = this%levlupft_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%lupft_begin, thread_bounds%lupft_end) + end subroutine SetThreadBoundsEach ! =================================================================================== @@ -1172,7 +1183,7 @@ subroutine assemble_history_output_types(this) use FatesIOVariableKindMod, only : site_elem_r8, site_elpft_r8 use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8, site_clscpf_r8 use FatesIOVariableKindMod, only : site_cdpf_r8, site_cdsc_r8, site_cdam_r8 - use FatesIOVariableKindMod, only : site_landuse_r8, site_lulu_r8 + use FatesIOVariableKindMod, only : site_landuse_r8, site_lulu_r8, site_lupft_r8 implicit none @@ -1263,6 +1274,9 @@ subroutine assemble_history_output_types(this) call this%set_dim_indices(site_lulu_r8, 1, this%column_index()) call this%set_dim_indices(site_lulu_r8, 2, this%levlulu_index()) + call this%set_dim_indices(site_lupft_r8, 1, this%column_index()) + call this%set_dim_indices(site_lupft_r8, 2, this%levlupft_index()) + end subroutine assemble_history_output_types ! =================================================================================== @@ -1706,6 +1720,21 @@ end function levlulu_index ! ====================================================================================== + subroutine set_levlupft_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levlupft_index_ = index + end subroutine set_levlupft_index + + integer function levlupft_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levlupft_index = this%levlupft_index_ + end function levlupft_index + + ! ====================================================================================== + subroutine zero_site_hvars(this, currentSite, upfreq_in) ! This routine zero's a history diagnostic variable @@ -1852,7 +1881,7 @@ subroutine init_dim_kinds_maps(this) use FatesIOVariableKindMod, only : site_elem_r8, site_elpft_r8 use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8, site_clscpf_r8 use FatesIOVariableKindMod, only : site_cdpf_r8, site_cdsc_r8, site_cdam_r8 - use FatesIOVariableKindMod, only : site_landuse_r8, site_lulu_r8 + use FatesIOVariableKindMod, only : site_landuse_r8, site_lulu_r8, site_lupft_r8 implicit none @@ -1974,6 +2003,10 @@ subroutine init_dim_kinds_maps(this) index = index + 1 call this%dim_kinds(index)%Init(site_lulu_r8, 2) + ! site x land use x pft + index = index + 1 + call this%dim_kinds(index)%Init(site_lupft_r8, 2) + ! FIXME(bja, 2016-10) assert(index == fates_history_num_dim_kinds) end subroutine init_dim_kinds_maps diff --git a/main/FatesIODimensionsMod.F90 b/main/FatesIODimensionsMod.F90 index 4aa9b4cada..ed487d7eed 100644 --- a/main/FatesIODimensionsMod.F90 +++ b/main/FatesIODimensionsMod.F90 @@ -37,6 +37,7 @@ module FatesIODimensionsMod character(*), parameter, public :: levelage = 'fates_levelage' character(*), parameter, public :: levlanduse = 'fates_levlanduse' character(*), parameter, public :: levlulu = 'fates_levlulu' + character(*), parameter, public :: levlupft = 'fates_levlupft' ! column = This is a structure that records where FATES column boundaries ! on each thread point to in the host IO array, this structure @@ -123,7 +124,10 @@ module FatesIODimensionsMod ! levlulu = this is the structure that records the boundaries for the ! (land use class) x (land use class) dimension - + + ! levlupft = this is the structure that records the boundaries for the + ! (land use class) x pft dimension + type, public :: fates_bounds_type integer :: cohort_begin integer :: cohort_end @@ -183,6 +187,8 @@ module FatesIODimensionsMod integer :: landuse_end integer :: lulu_begin integer :: lulu_end + integer :: lupft_begin + integer :: lupft_end end type fates_bounds_type diff --git a/main/FatesIOVariableKindMod.F90 b/main/FatesIOVariableKindMod.F90 index 37c5c34448..2455939e6f 100644 --- a/main/FatesIOVariableKindMod.F90 +++ b/main/FatesIOVariableKindMod.F90 @@ -43,6 +43,7 @@ module FatesIOVariableKindMod character(*), parameter, public :: site_clscpf_r8 = 'SI_CLSCPF_R8' character(*), parameter, public :: site_landuse_r8 = 'SI_LANDUSE_R8' character(*), parameter, public :: site_lulu_r8 = 'SI_LULU_R8' + character(*), parameter, public :: site_lupft_r8 = 'SI_LUPFT_R8' ! Element, and multiplexed element dimensions character(*), parameter, public :: site_elem_r8 = 'SI_ELEM_R8' From 7dc7c47234ecc08a67ce5bbe0bb673c550f6b0f7 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 12 Sep 2023 12:06:13 -0400 Subject: [PATCH 106/250] conflict resolutions for two-stream --- biogeochem/EDCanopyStructureMod.F90 | 1 + biogeochem/FatesAllometryMod.F90 | 6 ++--- biogeochem/FatesCohortMod.F90 | 4 +++- biogeochem/FatesPatchMod.F90 | 25 ++++++++++++-------- biogeophys/FatesPlantRespPhotosynthMod.F90 | 17 +++++--------- main/EDTypesMod.F90 | 27 +++++++++++----------- main/FatesConstantsMod.F90 | 2 -- main/FatesHistoryInterfaceMod.F90 | 2 +- main/FatesRestartInterfaceMod.F90 | 3 +++ radiation/FatesRadiationDriveMod.F90 | 6 ++--- radiation/FatesTwoStreamInterfaceMod.F90 | 24 ++++++++++--------- 11 files changed, 60 insertions(+), 57 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index cc59d4fba6..92e5845129 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -19,6 +19,7 @@ module EDCanopyStructureMod use EDCohortDynamicsMod , only : InitPRTObject use FatesAllometryMod , only : tree_lai use FatesAllometryMod , only : tree_sai + use EDTypesMod , only : ed_site_type use FatesAllometryMod , only : VegAreaLayer use FatesPatchMod, only : fates_patch_type use FatesCohortMod, only : fates_cohort_type diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index a6d4d8df4f..b9b20f2f7e 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -96,10 +96,8 @@ module FatesAllometryMod use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : FatesWarn,N2S,A2S,I2S - use EDTypesMod , only : nlevleaf - use EDTypesMod , only : nclmax - use EDTypesMod , only : dinc_vai - use EDTypesMod , only : dlower_vai + use EDParamsMod , only : nlevleaf,dinc_vai,dlower_vai + use EDParamsMod , only : nclmax use DamageMainMod , only : GetCrownReduction implicit none diff --git a/biogeochem/FatesCohortMod.F90 b/biogeochem/FatesCohortMod.F90 index 71685a869e..18e5d5df55 100644 --- a/biogeochem/FatesCohortMod.F90 +++ b/biogeochem/FatesCohortMod.F90 @@ -200,6 +200,8 @@ module FatesCohortMod !--------------------------------------------------------------------------- + integer :: twostr_col ! The column index in the two-stream solution that this cohort is part of + ! RESPIRATION COMPONENTS real(r8) :: rdark ! dark respiration [kgC/indiv/s] real(r8) :: resp_g_tstep ! growth respiration [kgC/indiv/timestep] @@ -1087,4 +1089,4 @@ end subroutine Dump !=========================================================================== -end module FatesCohortMod \ No newline at end of file +end module FatesCohortMod diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index 36323e527a..443ee19474 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -15,14 +15,15 @@ module FatesPatchMod use FatesLitterMod, only : litter_type use PRTGenericMod, only : num_elements use PRTGenericMod, only : element_list - use EDParamsMod, only : maxSWb, nlevleaf, nclmax, maxpft + use EDParamsMod, only : nlevleaf, nclmax, maxpft use FatesConstantsMod, only : n_dbh_bins, n_dist_types - use FatesConstantsMod, only : n_rad_stream_types use FatesConstantsMod, only : t_water_freeze_k_1atm use FatesRunningMeanMod, only : ema_24hr, fixed_24hr, ema_lpa, ema_longterm use FatesRunningMeanMod, only : ema_sdlng_emerg_h2o, ema_sdlng_mort_par use FatesRunningMeanMod, only : ema_sdlng2sap_par, ema_sdlng_mdd - + use TwoStreamMLPEMod, only : twostream_type + use FatesRadiationMemMod,only : num_swb + use FatesRadiationMemMod,only : num_rad_stream_types use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) use shr_log_mod, only : errMsg => shr_log_errMsg @@ -112,8 +113,8 @@ module FatesPatchMod !TODO - can we delete these? real(r8) :: psn_z(nclmax,maxpft,nlevleaf) - real(r8) :: nrmlzd_parprof_pft_dir_z(n_rad_stream_types,nclmax,maxpft,nlevleaf) - real(r8) :: nrmlzd_parprof_pft_dif_z(n_rad_stream_types,nclmax,maxpft,nlevleaf) + real(r8) :: nrmlzd_parprof_pft_dir_z(num_rad_stream_types,nclmax,maxpft,nlevleaf) + real(r8) :: nrmlzd_parprof_pft_dif_z(num_rad_stream_types,nclmax,maxpft,nlevleaf) !--------------------------------------------------------------------------- @@ -122,8 +123,8 @@ module FatesPatchMod real(r8) :: fcansno ! fraction of canopy covered in snow [0-1] logical :: solar_zenith_flag ! integer flag specifying daylight (based on zenith angle) real(r8) :: solar_zenith_angle ! solar zenith angle [radians] - real(r8) :: gnd_alb_dif(maxSWb) ! ground albedo for diffuse rad, both bands [0-1] - real(r8) :: gnd_alb_dir(maxSWb) ! ground albedo for direct rad, both bands [0-1] + real(r8) :: gnd_alb_dif(num_swb) ! ground albedo for diffuse rad, both bands [0-1] + real(r8) :: gnd_alb_dir(num_swb) ! ground albedo for direct rad, both bands [0-1] ! organized by canopy layer, pft, and leaf layer real(r8) :: fabd_sun_z(nclmax,maxpft,nlevleaf) ! sun fraction of direct light absorbed [0-1] @@ -147,6 +148,10 @@ module FatesPatchMod real(r8), allocatable :: sabs_dir(:) ! fraction of incoming direct radiation that is absorbed by the canopy real(r8), allocatable :: sabs_dif(:) ! fraction of incoming diffuse radiation that is absorbed by the canopy + ! Twostream data structures + type(twostream_type) :: twostr ! This holds all two-stream data for the patch + + !--------------------------------------------------------------------------- ! ROOTS @@ -565,9 +570,9 @@ subroutine Create(this, age, area, label, nocomp_pft, num_swb, num_pft, & ! initialize litter call this%InitLitter(num_pft, num_levsoil) - new_patch%twostr%scelg => null() ! The radiation module will check if this - ! is associated, since it is not, then it will - ! initialize and allocate + this%twostr%scelg => null() ! The radiation module will check if this + ! is associated, since it is not, it will then + ! initialize and allocate ! assign known patch attributes this%age = age diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index ad57b15e41..c666c5f4ce 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -444,14 +444,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) cohort_elai = sum(cohort_layer_elai(1:currentCohort%nv)) cohort_esai = sum(cohort_layer_esai(1:currentCohort%nv)) - - ! MLO. Assuming target to be related to leaf biomass when leaves are fully - ! flushed. But unsure whether this call is correct or not, shouldn't we get - ! the target value directly from the bstore_allom? - call bleaf(currentCohort%dbh,currentCohort%pft,& - currentCohort%crowndamage,currentCohort%canopy_trim,1.0_r8,store_c_target) - ! call bstore_allom(currentCohort%dbh,currentCohort%pft, & - ! currentCohort%canopy_trim,store_c_target) + else cohort_layer_elai(:) = 0._r8 @@ -462,12 +455,14 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) cohort_esai = 0._r8 end if - + ! MLO. Assuming target to be related to leaf biomass when leaves are fully + ! flushed. But unsure whether this call is correct or not, shouldn't we get + ! the target value directly from the bstore_allom? call bleaf(currentCohort%dbh,currentCohort%pft,& - currentCohort%crowndamage,currentCohort%canopy_trim,store_c_target) + currentCohort%crowndamage,currentCohort%canopy_trim,1.0_r8,store_c_target) ! call bstore_allom(currentCohort%dbh,currentCohort%pft, & ! currentCohort%canopy_trim,store_c_target) - + call storage_fraction_of_target(store_c_target, & currentCohort%prt%GetState(store_organ, carbon12_element), & frac) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index f2296c6173..56cb70fcb6 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -265,20 +265,6 @@ module EDTypesMod ! which is used for fixation - - ! SP mode target PFT level variables - real(r8), allocatable :: sp_tlai(:) ! target TLAI per FATES pft - real(r8), allocatable :: sp_tsai(:) ! target TSAI per FATES pft - real(r8), allocatable :: sp_htop(:) ! target HTOP per FATES pft - - ! Mass Balance (allocation for each element) - - type(site_massbal_type), pointer :: mass_balance(:) - - ! Flux diagnostics (allocation for each element) - - type(site_fluxdiags_type), pointer :: flux_diags(:) - ! Two-stream scratch arrays real(r8), allocatable :: omega_2str(:,:) ! This is the matrix that is inverted to solve ! the linear system of equations in the two-stream @@ -296,7 +282,20 @@ module EDTypesMod ! need one array integer, allocatable :: ipiv_2str(:) ! pivot indices for the lapack 2str solver + + ! SP mode target PFT level variables + real(r8), allocatable :: sp_tlai(:) ! target TLAI per FATES pft + real(r8), allocatable :: sp_tsai(:) ! target TSAI per FATES pft + real(r8), allocatable :: sp_htop(:) ! target HTOP per FATES pft + ! Mass Balance (allocation for each element) + + type(site_massbal_type), pointer :: mass_balance(:) + + ! Flux diagnostics (allocation for each element) + + type(site_fluxdiags_type), pointer :: flux_diags(:) + ! PHENOLOGY real(r8) :: grow_deg_days ! Phenology growing degree days real(r8) :: snow_depth ! site-level snow depth (used for ELAI/TLAI calcs) diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index c73483fe67..a371c8bffb 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -34,8 +34,6 @@ module FatesConstantsMod ! are used, but this helps allocate scratch ! space and output arrays. - integer, parameter, public :: n_rad_stream_types = 2 ! The number of radiation streams used (direct/diffuse) - integer , parameter, public :: N_DBH_BINS = 6 ! no. of dbh bins used when comparing patches real(fates_r8), parameter, public :: patchfusion_dbhbin_loweredges(N_DBH_BINS) = & (/0._fates_r8, 5._fates_r8, 20._fates_r8, 50._fates_r8, 100._fates_r8, 150._fates_r8/) ! array of bin lower edges for comparing patches diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index cfca8e7ec9..2fd0845b56 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -47,6 +47,7 @@ module FatesHistoryInterfaceMod use FatesInterfaceTypesMod , only : hlm_parteh_mode use EDParamsMod , only : ED_val_comp_excln use EDParamsMod , only : ED_val_phen_coldtemp + use EDParamsMod , only : nlevleaf use FatesInterfaceTypesMod , only : nlevsclass, nlevage use FatesInterfaceTypesMod , only : nlevheight use FatesInterfaceTypesMod , only : bc_in_type @@ -2127,7 +2128,6 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) use FatesSizeAgeTypeIndicesMod, only : get_cdamagesizepft_class_index use FatesSizeAgeTypeIndicesMod, only : coagetype_class_index - use EDParamsMod , only : nlevleaf use EDParamsMod , only : ED_val_history_height_bin_edges use FatesInterfaceTypesMod , only : nlevdamage diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 1f122c60b7..f48209e08e 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -3656,6 +3656,9 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) call twostr%Solve(ib, & ! in normalized_upper_boundary, & ! in 1.0_r8,1.0_r8, & ! in + sites(s)%taulambda_2str, & ! inout (scratch) + sites(s)%omega_2str, & ! inout (scratch) + sites(s)%ipiv_2str, & ! inout (scratch) bc_out(s)%albd_parb(ifp,ib), & ! out bc_out(s)%albi_parb(ifp,ib), & ! out bc_out(s)%fabd_parb(ifp,ib), & ! out diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index c96f8f7014..dbe394ea30 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -178,9 +178,9 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) call twostr%Solve(ib, & ! in normalized_upper_boundary, & ! in 1.0_r8,1.0_r8, & ! in - csite%taulambda_2str, & ! inout (scratch) - csite%omega_2str, & ! inout (scratch) - csite%ipiv_2str, & ! inout (scratch) + sites(s)%taulambda_2str, & ! inout (scratch) + sites(s)%omega_2str, & ! inout (scratch) + sites(s)%ipiv_2str, & ! inout (scratch) bc_out(s)%albd_parb(ifp,ib), & ! out bc_out(s)%albi_parb(ifp,ib), & ! out bc_out(s)%fabd_parb(ifp,ib), & ! out diff --git a/radiation/FatesTwoStreamInterfaceMod.F90 b/radiation/FatesTwoStreamInterfaceMod.F90 index 8eb4e2f0eb..c9dc41c528 100644 --- a/radiation/FatesTwoStreamInterfaceMod.F90 +++ b/radiation/FatesTwoStreamInterfaceMod.F90 @@ -17,8 +17,10 @@ Module FatesTwoStreamInterfaceMod use FatesRadiationMemMod , only : ivis, inir use FatesRadiationMemMod , only : rho_snow,tau_snow use TwoStreamMLPEMod , only : air_ft, AllocateRadParams, rad_params - use EDTypesMod , only : ed_patch_type, ed_cohort_type, ed_site_type - use EDTypesMod , only : nclmax + use FatesCohortMod , only : fates_cohort_type + use FatesPatchMod , only : fates_patch_type + use EDTypesMod , only : ed_site_type + use EDParamsMod , only : nclmax use TwoStreamMLPEMod , only : twostream_type use TwoStreamMLPEMod , only : ParamPrep use TwoStreamMLPEMod , only : AllocateRadParams @@ -46,11 +48,11 @@ Module FatesTwoStreamInterfaceMod subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) type(ed_site_type) :: site - type(ed_patch_type),pointer :: patch + type(fates_patch_type),pointer :: patch real(r8) :: fcansno_pa(:) real(r8) :: coszen_pa(:) - type(ed_cohort_type), pointer :: cohort + type(fates_cohort_type), pointer :: cohort integer :: n_col(nclmax) ! Number of parallel column elements per layer integer :: ican,ft,icol type(twostream_type), pointer :: twostr @@ -84,7 +86,7 @@ subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) ! ! cohorts. THe objective is to reduce this. !integer, parameter :: max_el_per_layer = 10 !real(r8), parameter :: init_max_vai_diff_per_elem = 0.2_r8 - !type(ed_cohort_type), pointer :: elem_co_ptrs(ncl*max_el_per_layer,100) + !type(fates_cohort_type), pointer :: elem_co_ptrs(ncl*max_el_per_layer,100) if(rad_solver.ne.twostr_solver)return @@ -312,7 +314,7 @@ subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) deallocate(site%taulambda_2str,site%ipiv_2str,site%omega_2str) end if else - allocate_stratch = .true. + allocate_scratch = .true. end if if(allocate_scratch)then @@ -331,7 +333,7 @@ end subroutine FatesConstructRadElements subroutine FatesPatchFSun(patch,fsun,laisun,laisha) - type(ed_patch_type) :: patch + type(fates_patch_type) :: patch real(r8) :: fsun ! Patch average sunlit fraction real(r8) :: laisun ! Patch average LAI of leaves in sun real(r8) :: laisha ! Patch average LAI of leaves in shade @@ -382,13 +384,13 @@ subroutine CheckPatchRadiationBalance(patch, snow_depth, ib, fabd, fabi) ! absorbed radiation, then compare the amount absorbed ! to the fraction the solver calculated - type(ed_patch_type) :: patch + type(fates_patch_type) :: patch integer :: ib ! broadband index real(r8) :: snow_depth real(r8) :: fabd ! Fraction of absorbed direct radiation by vegetation real(r8) :: fabi ! Fraction of absorbed indirect radiation by vegetation - type(ed_cohort_type), pointer :: cohort + type(fates_cohort_type), pointer :: cohort integer :: iv,ican,icol real(r8),dimension(50) :: cohort_vaitop real(r8),dimension(50) :: cohort_vaibot @@ -461,8 +463,8 @@ subroutine FatesGetCohortAbsRad(patch,cohort,ib,vaitop,vaibot,cohort_elai,cohort ! over a specified interval of VAI (vegetation area index) ! VAI is exposed leaf + stem area index - type(ed_patch_type) :: patch - type(ed_cohort_type) :: cohort + type(fates_patch_type) :: patch + type(fates_cohort_type) :: cohort integer,intent(in) :: ib real(r8),intent(in) :: vaitop real(r8),intent(in) :: vaibot From 800136dae29f3c9c16dfa7d2c8e200182ae78829 Mon Sep 17 00:00:00 2001 From: Charles D Koven Date: Thu, 10 Aug 2023 16:24:51 -0700 Subject: [PATCH 107/250] pasted code from grazing branch for adding land use dimension to paramter file --- main/FatesParametersInterface.F90 | 1 + parameter_files/fates_params_default.cdl | 11 +++++++++++ tools/modify_fates_paramfile.py | 2 +- tools/ncvarsort.py | 7 +++++-- 4 files changed, 18 insertions(+), 3 deletions(-) diff --git a/main/FatesParametersInterface.F90 b/main/FatesParametersInterface.F90 index b19817a091..297bd58c1d 100644 --- a/main/FatesParametersInterface.F90 +++ b/main/FatesParametersInterface.F90 @@ -38,6 +38,7 @@ module FatesParametersInterface character(len=*), parameter, public :: dimension_name_hlm_pftno = 'fates_hlm_pftno' character(len=*), parameter, public :: dimension_name_history_damage_bins = 'fates_history_damage_bins' character(len=*), parameter, public :: dimension_name_damage = 'fates_damage_class' + character(len=*), parameter, public :: dimension_name_landuse = 'fates_landuseclass' ! Dimensions in the host namespace: character(len=*), parameter, public :: dimension_name_host_allpfts = 'allpfts' diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index a9198319d0..79d05c7999 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -8,6 +8,7 @@ dimensions: fates_history_size_bins = 13 ; fates_hlm_pftno = 14 ; fates_hydr_organs = 4 ; + fates_landuseclass = 5 ; fates_leafage_class = 1 ; fates_litterclass = 6 ; fates_pft = 12 ; @@ -47,6 +48,9 @@ variables: char fates_litterclass_name(fates_litterclass, fates_string_length) ; fates_litterclass_name:units = "unitless - string" ; fates_litterclass_name:long_name = "Name of the litter classes, for variables associated with dimension fates_litterclass" ; + char fates_landuseclass_name(fates_landuseclass, fates_string_length) ; + fates_landuseclass_name:units = "unitless - string" ; + fates_landuseclass_name:long_name = "Name of the land use classes, for variables associated with dimension fates_landuseclass" ; double fates_alloc_organ_priority(fates_plant_organs, fates_pft) ; fates_alloc_organ_priority:units = "index" ; fates_alloc_organ_priority:long_name = "Priority level for allocation, 1: replaces turnover from storage, 2: same priority as storage use/replacement, 3: ascending in order of least importance" ; @@ -947,6 +951,13 @@ data: "dead leaves ", "live grass " ; + fates_landuseclass_name = + "primaryland ", + "secondaryland ", + "rangeland ", + "pastureland ", + "cropland " ; + fates_alloc_organ_priority = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, diff --git a/tools/modify_fates_paramfile.py b/tools/modify_fates_paramfile.py index adacb2457b..85f7c449ea 100755 --- a/tools/modify_fates_paramfile.py +++ b/tools/modify_fates_paramfile.py @@ -141,7 +141,7 @@ def main(): 'fates_history_damage_bins', 'fates_NCWD','fates_litterclass','fates_leafage_class', \ 'fates_plant_organs','fates_hydr_organs','fates_hlm_pftno', \ - 'fates_leafage_class']: + 'fates_leafage_class','fates_landuse_class']: otherdimpresent = True otherdimname = var.dimensions[i] otherdimlength = var.shape[i] diff --git a/tools/ncvarsort.py b/tools/ncvarsort.py index 327dd84a96..6583700ae3 100755 --- a/tools/ncvarsort.py +++ b/tools/ncvarsort.py @@ -30,7 +30,7 @@ def main(): # make empty lists to hold the variable names in. the first of these is a list of sub-lists, # one for each type of variable (based on dimensionality). # the second is the master list that will contain all variables. - varnames_list = [[],[],[],[],[],[],[],[],[],[],[],[],[]] + varnames_list = [[],[],[],[],[],[],[],[],[],[],[],[],[],[]] varnames_list_sorted = [] # # sort the variables by dimensionality, but mix the PFT x other dimension in with the regular PFT-indexed variables @@ -48,6 +48,7 @@ def main(): (u'fates_prt_organs', u'fates_string_length'):7, (u'fates_plant_organs', u'fates_string_length'):7, (u'fates_litterclass', u'fates_string_length'):7, + (u'fates_landuseclass', u'fates_string_length'):7, (u'fates_pft',):8, (u'fates_hydr_organs', u'fates_pft'):8, (u'fates_leafage_class', u'fates_pft'):8, @@ -56,7 +57,9 @@ def main(): (u'fates_hlm_pftno', u'fates_pft'):9, (u'fates_litterclass',):10, (u'fates_NCWD',):11, - ():12} + (u'fates_landuseclass',):12, + (u'fates_landuseclass', u'fates_pft'):12, + ():13} # # go through each of the variables and assign it to one of the sub-lists based on its dimensionality for v_name, varin in dsin.variables.items(): From e2378fb641546b782992e34a5c4c00411cd30c3b Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Tue, 12 Sep 2023 12:15:04 -0700 Subject: [PATCH 108/250] changing parameter read infrastructure for maxpatches by landuse consolidation --- main/EDParamsMod.F90 | 76 ++++++++++---------------------------------- 1 file changed, 16 insertions(+), 60 deletions(-) diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 879ae2f10e..88260168e3 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -10,6 +10,7 @@ module EDParamsMod use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod, only : fates_unset_r8 + use FatesConstantsMod, only : n_landuse_cats ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -247,22 +248,9 @@ module EDParamsMod ! The number of patches specified in the parameter file may be over-written. ! For instance, in SP mode, we want the same number of primary patches as the number of PFTs ! in the fates parameter file, and zero secondary. + ! thus they are not protected here. - integer, public :: maxpatch_primaryland - character(len=param_string_length), parameter, public :: maxpatch_primaryland_name = "fates_maxpatch_primaryland" - - integer, public :: maxpatch_secondaryland - character(len=param_string_length), parameter, public :: maxpatch_secondaryland_name = "fates_maxpatch_secondaryland" - - integer, public :: maxpatch_pastureland - character(len=param_string_length), parameter, public :: maxpatch_pastureland_name = "fates_maxpatch_pastureland" - - integer, public :: maxpatch_rangeland - character(len=param_string_length), parameter, public :: maxpatch_rangeland_name = "fates_maxpatch_rangeland" - - integer, public :: maxpatch_cropland - character(len=param_string_length), parameter, public :: maxpatch_cropland_name = "fates_maxpatch_cropland" - + integer, public :: maxpatches_by_landuse(n_landuse_cats) integer, public :: maxpatch_total ! Maximum allowable cohorts per patch @@ -368,11 +356,6 @@ subroutine FatesParamsInit() stomatal_model = -9 regeneration_model = -9 stomatal_assim_model = -9 - maxpatch_primaryland = -9 - maxpatch_secondaryland = -9 - maxpatch_pastureland = -9 - maxpatch_rangeland = -9 - maxpatch_cropland = -9 max_cohort_per_patch = -9 hydr_kmax_rsurf1 = nan hydr_kmax_rsurf2 = nan @@ -409,7 +392,7 @@ subroutine FatesRegisterParams(fates_params) use FatesParametersInterface, only : dimension_name_history_size_bins, dimension_name_history_age_bins use FatesParametersInterface, only : dimension_name_history_height_bins, dimension_name_hydr_organs use FatesParametersInterface, only : dimension_name_history_coage_bins, dimension_name_history_damage_bins - use FatesParametersInterface, only : dimension_shape_scalar + use FatesParametersInterface, only : dimension_shape_scalar, dimension_name_landuse implicit none @@ -423,6 +406,7 @@ subroutine FatesRegisterParams(fates_params) character(len=param_string_length), parameter :: dim_names_coageclass(1) = (/dimension_name_history_coage_bins/) character(len=param_string_length), parameter :: dim_names_hydro_organs(1) = (/dimension_name_hydr_organs/) character(len=param_string_length), parameter :: dim_names_damageclass(1)= (/dimension_name_history_damage_bins/) + character(len=param_string_length), parameter :: dim_names_landuse(1)= (/dimension_name_landuse/) call FatesParamsInit() @@ -528,21 +512,6 @@ subroutine FatesRegisterParams(fates_params) call fates_params%RegisterParameter(name=stomatal_assim_name, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) - call fates_params%RegisterParameter(name=maxpatch_primaryland_name, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) - - call fates_params%RegisterParameter(name=maxpatch_secondaryland_name, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) - - call fates_params%RegisterParameter(name=maxpatch_pastureland_name, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) - - call fates_params%RegisterParameter(name=maxpatch_rangeland_name, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) - - call fates_params%RegisterParameter(name=maxpatch_cropland_name, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) - call fates_params%RegisterParameter(name=maxcohort_name, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) @@ -638,6 +607,9 @@ subroutine FatesRegisterParams(fates_params) call fates_params%RegisterParameter(name=ED_name_history_damage_bin_edges, dimension_shape=dimension_shape_1d, & dimension_names=dim_names_damageclass) + call fates_params%RegisterParameter(name=ED_name_maxpatches_by_landuse, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names_landuse) + end subroutine FatesRegisterParams @@ -645,6 +617,7 @@ end subroutine FatesRegisterParams subroutine FatesReceiveParams(fates_params) use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar + use FatesConstantsMod, only: primaryland, secondaryland, rangeland, pastureland, cropland implicit none @@ -652,6 +625,7 @@ subroutine FatesReceiveParams(fates_params) real(r8) :: tmpreal ! local real variable for changing type on read real(r8), allocatable :: hydr_htftype_real(:) + real(r8) :: tmp_vector_by_landuse(n_landuse_cats) ! local real vector for changing type on read call fates_params%RetrieveParameter(name=ED_name_photo_temp_acclim_timescale, & data=photo_temp_acclim_timescale) @@ -754,30 +728,6 @@ subroutine FatesReceiveParams(fates_params) call fates_params%RetrieveParameter(name=stomatal_assim_name, & data=tmpreal) stomatal_assim_model = nint(tmpreal) - - call fates_params%RetrieveParameter(name=maxpatch_primaryland_name, & - data=tmpreal) - maxpatch_primaryland = nint(tmpreal) - - call fates_params%RetrieveParameter(name=maxpatch_secondaryland_name, & - data=tmpreal) - maxpatch_secondaryland = nint(tmpreal) - - call fates_params%RetrieveParameter(name=maxpatch_pastureland_name, & - data=tmpreal) - maxpatch_pastureland = nint(tmpreal) - - call fates_params%RetrieveParameter(name=maxpatch_rangeland_name, & - data=tmpreal) - maxpatch_rangeland = nint(tmpreal) - - call fates_params%RetrieveParameter(name=maxpatch_cropland_name, & - data=tmpreal) - maxpatch_cropland = nint(tmpreal) - - maxpatch_total = maxpatch_primaryland + maxpatch_secondaryland + & - maxpatch_pastureland + maxpatch_rangeland + & - maxpatch_cropland call fates_params%RetrieveParameter(name=maxcohort_name, & data=tmpreal) @@ -881,6 +831,12 @@ subroutine FatesReceiveParams(fates_params) call fates_params%RetrieveParameterAllocate(name=ED_name_history_damage_bin_edges, & data=ED_val_history_damage_bin_edges) + call fates_params%RetrieveParameter(name=ED_name_maxpatches_by_landuse, & + data=tmp_vector_by_landuse) + + maxpatches_by_landuse(:) = nint(tmp_vector_by_landuse(:)) + maxpatch_total = sum(maxpatches_by_landuse(:)) + call fates_params%RetrieveParameterAllocate(name=ED_name_hydr_htftype_node, & data=hydr_htftype_real) allocate(hydr_htftype_node(size(hydr_htftype_real))) From 4392c39ae312e853050e28fa5a0da10fd6ac1be9 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Tue, 12 Sep 2023 13:13:29 -0700 Subject: [PATCH 109/250] more changes for maxpatches by landuse consolidation --- biogeochem/EDPatchDynamicsMod.F90 | 39 ++++-------------------- main/FatesInterfaceMod.F90 | 16 +++------- parameter_files/fates_params_default.cdl | 30 +++--------------- 3 files changed, 16 insertions(+), 69 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index da9296a8d7..ae20ba9057 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -102,9 +102,7 @@ module EDPatchDynamicsMod use SFParamsMod, only : SF_VAL_CWD_FRAC use EDParamsMod, only : logging_event_code use EDParamsMod, only : logging_export_frac - use EDParamsMod, only : maxpatch_primaryland, maxpatch_secondaryland - use EDParamsMod, only : maxpatch_pastureland, maxpatch_rangeland, maxpatch_cropland - use EDParamsMod, only : maxpatch_total + use EDParamsMod, only : maxpatches_bylanduse use FatesRunningMeanMod, only : ema_sdlng_mdd use FatesRunningMeanMod, only : ema_sdlng_emerg_h2o, ema_sdlng_mort_par, ema_sdlng2sap_par use FatesRunningMeanMod, only : ema_24hr, fixed_24hr, ema_lpa, ema_longterm @@ -2378,7 +2376,6 @@ subroutine fuse_patches( csite, bc_in ) integer :: i_pftlabel !nocomp pft iterator real(r8) :: primary_land_fraction_beforefusion,primary_land_fraction_afterfusion integer :: pftlabelmin, pftlabelmax - real(r8) :: maxpatches(n_landuse_cats) ! !--------------------------------------------------------------------- @@ -2391,30 +2388,6 @@ subroutine fuse_patches( csite, bc_in ) nopatches(1:n_landuse_cats) = 0 - ! Its possible that, in nocomp modes, there are more categorically distinct patches than we allow as - ! primary patches in non-nocomp mode. So if this is the case, bump up the maximum number of primary patches - ! to let there be one for each type of nocomp PFT on the site. this is likely to lead to problems - ! if anthropogenic disturance is enabled. - if (hlm_use_nocomp.eq.itrue) then - !!cdk this logic for how many patcehs to allow in nocomp will need to be changed - maxpatches(primaryland) = max(maxpatch_primaryland, sum(csite%use_this_pft)) - maxpatches(cropland) = maxpatch_cropland - maxpatches(pastureland) = maxpatch_pastureland - maxpatches(rangeland) = maxpatch_rangeland - maxpatches(secondaryland) = maxpatch_total - maxpatches(primaryland) - maxpatches(cropland) - maxpatches(pastureland) - maxpatches(rangeland) - if (maxpatch_total .lt. maxpatches(primaryland)) then - write(fates_log(),*) 'too many PFTs and not enough patches for nocomp w/o fixed biogeog' - write(fates_log(),*) 'maxpatch_total,numpft',maxpatch_total,numpft, sum(csite%use_this_pft) - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - else - maxpatches(primaryland) = maxpatch_primaryland - maxpatches(secondaryland) = maxpatch_secondaryland - maxpatches(cropland) = maxpatch_cropland - maxpatches(pastureland) = maxpatch_pastureland - maxpatches(rangeland) = maxpatch_rangeland - endif - currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) nopatches(currentPatch%land_use_label) = & @@ -2448,7 +2421,7 @@ subroutine fuse_patches( csite, bc_in ) iterate = 1 !---------------------------------------------------------------------! - ! Keep doing this until nopatches <= maxpatch_total ! + ! Keep doing this until nopatches <= maxpatches_by_landuse(i_lulabel)! !---------------------------------------------------------------------! iterate_eq_1_loop: do while(iterate == 1) @@ -2585,10 +2558,10 @@ subroutine fuse_patches( csite, bc_in ) ! a patch x patch loop, reset the patch fusion tolerance to the starting ! ! value so that any subsequent fusions in this loop are done with that ! ! value. otherwise we can end up in a situation where we've loosened the ! - ! fusion tolerance to get nopatches <= maxpatch_total, but then, ! + ! fusion tolerance to get nopatches <= maxpatches_by_landuse(i_lulabel), but then, ! ! having accomplished that, we continue through all the patch x patch ! ! combinations and then all the patches get fused, ending up with ! - ! nopatches << maxpatch_total and losing all heterogeneity. ! + ! nopatches << maxpatches_by_landuse(i_lulabel) and losing all heterogeneity. ! !------------------------------------------------------------------------! profiletol = ED_val_patch_fusion_tol @@ -2624,7 +2597,7 @@ subroutine fuse_patches( csite, bc_in ) currentPatch => currentPatch%older enddo - if(nopatches(i_lulabel) > maxpatches(i_lulabel))then + if(nopatches(i_lulabel) > maxpatches_by_landuse(i_lulabel))then iterate = 1 profiletol = profiletol * patch_fusion_tolerance_relaxation_increment @@ -2647,7 +2620,7 @@ subroutine fuse_patches( csite, bc_in ) iterate = 0 endif - enddo iterate_eq_1_loop ! iterate .eq. 1 ==> nopatches>maxpatch_total + enddo iterate_eq_1_loop ! iterate .eq. 1 ==> nopatches>maxpatches_by_landuse(i_lulabel) end do lulabel_loop diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 7693e738a8..bf37898b54 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -16,8 +16,7 @@ module FatesInterfaceMod use EDParamsMod , only : ED_val_vai_width_increase_factor use EDParamsMod , only : ED_val_history_damage_bin_edges use EDParamsMod , only : maxpatch_total - use EDParamsMod , only : maxpatch_primaryland, maxpatch_secondaryland - use EDParamsMod , only : maxpatch_pastureland, maxpatch_rangeland, maxpatch_cropland + use EDParamsMod , only : maxpatches_bylanduse use EDParamsMod , only : max_cohort_per_patch use EDParamsMod , only : regeneration_model use EDParamsMod , only : maxSWb @@ -765,11 +764,8 @@ subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft) ! to hold all PFTs. So create the same number of ! patches as the number of PFTs - maxpatch_primaryland = fates_numpft - maxpatch_secondaryland = 0 - maxpatch_pastureland = 0 - maxpatch_rangeland = 0 - maxpatch_cropland = 0 + maxpatches_bylanduse(primaryland) = fates_numpft + maxpatches_bylanduse(secondaryland:n_landuse_cats) = 0 maxpatch_total = fates_numpft ! If this is an SP run, we actually need enough patches on the @@ -789,10 +785,8 @@ subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft) if(hlm_use_nocomp==itrue) then - maxpatch_primaryland = max(maxpatch_primaryland,fates_numpft) - maxpatch_total = maxpatch_primaryland + maxpatch_secondaryland + & - maxpatch_pastureland + maxpatch_rangeland + & - maxpatch_cropland + maxpatches_bylanduse(primaryland) = max(maxpatches_bylanduse(primaryland),fates_numpft) + maxpatch_total = sum(maxpatches_bylanduse(:)) !if(maxpatch_primary Date: Tue, 12 Sep 2023 14:40:22 -0700 Subject: [PATCH 110/250] fixed/updated clearing matrix logic --- biogeochem/FatesLandUseChangeMod.F90 | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index 6adf6d4852..a92eebcb8f 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -136,7 +136,10 @@ subroutine get_landusechange_rules(clearing_matrix) ! the purpose of this is to define a ruleset for when to clear the vegetation in transitioning from one land use type to another logical, intent(out) :: clearing_matrix(n_landuse_cats,n_landuse_cats) - integer, parameter :: ruleset = 1 ! ruleset to apply from table 1 of Ma et al (2020) https://doi.org/10.5194/gmd-13-3203-2020 + + ! default value of ruleset 4 above means that plants are not cleared during land use change transitions to rangeland, whereas plants are + ! cleared in transitions to pasturelands and croplands. + integer, parameter :: ruleset = 4 ! ruleset to apply from table 1 of Ma et al (2020) https://doi.org/10.5194/gmd-13-3203-2020 ! clearing matrix applies from the donor to the receiver land use type of the newly-transferred patch area ! values of clearing matrix: false => do not clear; true => clear @@ -147,18 +150,21 @@ subroutine get_landusechange_rules(clearing_matrix) case(1) + ! note that this ruleset isnt exactly what is in Ma et al. rulesets 1 and 2, because FATES does not make the distinction + ! between forested and non-forested lands from a land use/land cover perspective. clearing_matrix(:,cropland) = .true. clearing_matrix(:,pastureland) = .true. - clearing_matrix(pastureland,rangeland) = .true. - clearing_matrix(cropland,rangeland) = .true. + clearing_matrix(primaryland,rangeland) = .true. + clearing_matrix(secondaryland,rangeland) = .true. case(2) + ! see comment on number 1 above clearing_matrix(:,cropland) = .true. - clearing_matrix(rangeland,pastureland) = .true. - clearing_matrix(cropland,pastureland) = .true. - clearing_matrix(pastureland,rangeland) = .true. - clearing_matrix(cropland,rangeland) = .true. + clearing_matrix(primaryland,pastureland) = .true. + clearing_matrix(secondaryland,pastureland) = .true. + clearing_matrix(primaryland,rangeland) = .true. + clearing_matrix(secondaryland,rangeland) = .true. case(3) From ffdbb8601ff37269cacd9fe84017fce774fd3652 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 13 Sep 2023 14:26:13 -0700 Subject: [PATCH 111/250] update patch xml with combined maxpatch variable --- .../archive/api27.0.0_080923_luh2.xml | 39 +++++++++---------- parameter_files/fates_params_default.cdl | 22 +++++------ tools/UpdateParamAPI.py | 32 ++++++++------- 3 files changed, 47 insertions(+), 46 deletions(-) diff --git a/parameter_files/archive/api27.0.0_080923_luh2.xml b/parameter_files/archive/api27.0.0_080923_luh2.xml index 43b78ed11a..8cc028956d 100644 --- a/parameter_files/archive/api27.0.0_080923_luh2.xml +++ b/parameter_files/archive/api27.0.0_080923_luh2.xml @@ -26,32 +26,29 @@ fates_params_default.cdl 1,2,3,4,5,6,7,8,9,10,11,12 - - fates_maxpatch_cropland - scalar - count - maximum number of cropland patches per site - 1 + + fates_maxpatch_primary - - fates_maxpatch_pastureland - scalar - count - maximum number of pastureland patches per site - 1 + + fates_maxpatch_secondary + + + fates_landuseclass + 5 - fates_maxpatch_rangeland - scalar + fates_maxpatches_bylanduse + fates_landuseclass count - maximum number of rangeland patches per site - 1 - - - fates_maxpatch_primaryland + maximum number of patches per site on each land use type + 10, 4, 1, 1, 1 - - fates_maxpatch_secondaryland + + fates_landuseclass_name + fates_landuseclass, fates_string_length + unitless - string + Name of the land use classes, for variables associated with dimension fates_landuseclass + primaryland, secondaryland, rangeland, pastureland, cropland diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 1fbc27390c..ed9fe8c3db 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -8,12 +8,12 @@ dimensions: fates_history_size_bins = 13 ; fates_hlm_pftno = 14 ; fates_hydr_organs = 4 ; - fates_landuseclass = 5 ; fates_leafage_class = 1 ; fates_litterclass = 6 ; fates_pft = 12 ; fates_plant_organs = 4 ; fates_string_length = 60 ; + fates_landuseclass = 5 ; variables: double fates_history_ageclass_bin_edges(fates_history_age_bins) ; fates_history_ageclass_bin_edges:units = "yr" ; @@ -45,12 +45,12 @@ variables: char fates_alloc_organ_name(fates_plant_organs, fates_string_length) ; fates_alloc_organ_name:units = "unitless - string" ; fates_alloc_organ_name:long_name = "Name of plant organs (with alloc_organ_id, must match PRTGenericMod.F90)" ; + char fates_landuseclass_name(fates_landuseclass, fates_string_length) ; + fates_landuseclass_name:units = "unitless - string" ; + fates_landuseclass_name:long_name = "Name of the land use classes, for variables associated with dimension fates_landuseclass" ; char fates_litterclass_name(fates_litterclass, fates_string_length) ; fates_litterclass_name:units = "unitless - string" ; fates_litterclass_name:long_name = "Name of the litter classes, for variables associated with dimension fates_litterclass" ; - char fates_landuseclass_name(fates_landuseclass, fates_string_length) ; - fates_landuseclass_name:units = "unitless - string" ; - fates_landuseclass_name:long_name = "Name of the land use classes, for variables associated with dimension fates_landuseclass" ; double fates_alloc_organ_priority(fates_plant_organs, fates_pft) ; fates_alloc_organ_priority:units = "index" ; fates_alloc_organ_priority:long_name = "Priority level for allocation, 1: replaces turnover from storage, 2: same priority as storage use/replacement, 3: ascending in order of least importance" ; @@ -931,6 +931,13 @@ data: "sapwood", "structure" ; + fates_landuseclass_name = + "primaryland", + "secondaryland", + "rangeland", + "pastureland", + "cropland" ; + fates_litterclass_name = "twig ", "small branch ", @@ -939,13 +946,6 @@ data: "dead leaves ", "live grass " ; - fates_landuseclass_name = - "primaryland ", - "secondaryland ", - "rangeland ", - "pastureland ", - "cropland " ; - fates_alloc_organ_priority = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, diff --git a/tools/UpdateParamAPI.py b/tools/UpdateParamAPI.py index f23ef5d24c..7f49412eff 100755 --- a/tools/UpdateParamAPI.py +++ b/tools/UpdateParamAPI.py @@ -298,16 +298,19 @@ def main(): # print("no data type (dt), exiting");exit(2) try: + # print("trying dimnames: {}".format(paramname)) dimnames = tuple(mod.find('di').text.replace(" ","").split(',')) except: print("no data type (di), exiting");exit(2) try: + # print("trying units: {}".format(paramname)) units = mod.find('un').text.strip() except: print("no units (un), exiting");exit(2) try: + # print("trying ln: {}".format(paramname)) longname = mod.find('ln').text.strip() except: print("no long-name (ln), exiting");exit(2) @@ -315,30 +318,31 @@ def main(): ncfile = netcdf.netcdf_file(base_nc,"a",mmap=False) try: - values = str2fvec(mod.find('val').text.strip()) - except: - # try: - if(isinstance(mod.find('val').text,type(None))): - # values = mod.find('val').text.strip() - # except: + # print("trying val: {}".format(paramname)) + valstring = mod.find('val').text.strip() + values = str2fvec(valstring) + except Exception as emsg: + # print("type: {}".format(type(valstring))) + if(isinstance(valstring,type(None))): print("Warning: no values (val). Setting undefined (i.e. '_'): {}\n".format(paramname)) sel_values = ncfile.variables['fates_dev_arbitrary_pft'].data dcode = "d" - else: - print("unknown values (val), exiting");exit(2) + elif(isinstance(valstring,str)): + dcode = "c" + values = valstring.split(',') + for i,val in enumerate(values): + values[i] = val.strip() + print("value: {},{}".format(i,values[i])) + sel_values = selectvalues(ncfile,list(dimnames),ipft_list,values,dcode) + else: + print("exception, unknown values (val), exiting: {}".format(emsg));exit(2) #print("no values (val), exiting");exit(2) else: #code.interact(local=dict(globals(), **locals())) if(dimnames[0]=='scalar' or dimnames[0]=='none' or dimnames[0]==''): dimnames = () - - if(isinstance(values[0],str)): - dcode = "c" - values = values.split(',') - for i,val in enumerate(values): - values[i] = val.strip() elif(isinstance(values[0],float)): dcode = "d" else: From beeb0faa36130ca1659d9a0a69f2cdf1fda41510 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 13 Sep 2023 16:11:05 -0700 Subject: [PATCH 112/250] align maxpatches by landuse variable names --- biogeochem/EDPatchDynamicsMod.F90 | 2 +- main/EDParamsMod.F90 | 1 + main/FatesInterfaceMod.F90 | 14 ++++++++------ parameter_files/archive/api27.0.0_080923_luh2.xml | 2 +- parameter_files/fates_params_default.cdl | 8 ++++---- 5 files changed, 15 insertions(+), 12 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index ae20ba9057..3ccb7b7943 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -102,7 +102,7 @@ module EDPatchDynamicsMod use SFParamsMod, only : SF_VAL_CWD_FRAC use EDParamsMod, only : logging_event_code use EDParamsMod, only : logging_export_frac - use EDParamsMod, only : maxpatches_bylanduse + use EDParamsMod, only : maxpatches_by_landuse use FatesRunningMeanMod, only : ema_sdlng_mdd use FatesRunningMeanMod, only : ema_sdlng_emerg_h2o, ema_sdlng_mort_par, ema_sdlng2sap_par use FatesRunningMeanMod, only : ema_24hr, fixed_24hr, ema_lpa, ema_longterm diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 88260168e3..34c22ec26e 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -198,6 +198,7 @@ module EDParamsMod character(len=param_string_length),parameter,public :: ED_name_history_height_bin_edges= "fates_history_height_bin_edges" character(len=param_string_length),parameter,public :: ED_name_history_coageclass_bin_edges = "fates_history_coageclass_bin_edges" character(len=param_string_length),parameter,public :: ED_name_history_damage_bin_edges = "fates_history_damage_bin_edges" + character(len=param_string_length),parameter,public :: ED_name_maxpatches_by_landuse = "fates_maxpatches_by_landuse" ! Hydraulics Control Parameters (ONLY RELEVANT WHEN USE_FATES_HYDR = TRUE) ! ---------------------------------------------------------------------------------------------- diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index c5f600b3da..c5839d1412 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -16,7 +16,7 @@ module FatesInterfaceMod use EDParamsMod , only : ED_val_vai_width_increase_factor use EDParamsMod , only : ED_val_history_damage_bin_edges use EDParamsMod , only : maxpatch_total - use EDParamsMod , only : maxpatches_bylanduse + use EDParamsMod , only : maxpatches_by_landuse use EDParamsMod , only : max_cohort_per_patch use EDParamsMod , only : regeneration_model use EDParamsMod , only : maxSWb @@ -40,6 +40,9 @@ module FatesInterfaceMod use FatesConstantsMod , only : days_per_year use FatesConstantsMod , only : TRS_regeneration use FatesConstantsMod , only : g_per_kg + use FatesConstantsMod , only : n_landuse_cats + use FatesConstantsMod , only : primaryland + use FatesConstantsMod , only : secondaryland use FatesGlobals , only : fates_global_verbose use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun @@ -772,8 +775,8 @@ subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft) ! to hold all PFTs. So create the same number of ! patches as the number of PFTs - maxpatches_bylanduse(primaryland) = fates_numpft - maxpatches_bylanduse(secondaryland:n_landuse_cats) = 0 + maxpatches_by_landuse(primaryland) = fates_numpft + maxpatches_by_landuse(secondaryland:n_landuse_cats) = 0 maxpatch_total = fates_numpft ! If this is an SP run, we actually need enough patches on the @@ -793,8 +796,8 @@ subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft) if(hlm_use_nocomp==itrue) then - maxpatches_bylanduse(primaryland) = max(maxpatches_bylanduse(primaryland),fates_numpft) - maxpatch_total = sum(maxpatches_bylanduse(:)) + maxpatches_by_landuse(primaryland) = max(maxpatches_by_landuse(primaryland),fates_numpft) + maxpatch_total = sum(maxpatches_by_landuse(:)) !if(maxpatch_primary 5 - fates_maxpatches_bylanduse + fates_maxpatches_by_landuse fates_landuseclass count maximum number of patches per site on each land use type diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index ed9fe8c3db..e58ff5c7f4 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -672,9 +672,9 @@ variables: double fates_frag_cwd_frac(fates_NCWD) ; fates_frag_cwd_frac:units = "fraction" ; fates_frag_cwd_frac:long_name = "fraction of woody (bdead+bsw) biomass destined for CWD pool" ; - double fates_maxpatches_bylanduse(fates_landuseclass) ; - fates_maxpatches_bylanduse:units = "count" ; - fates_maxpatches_bylanduse:long_name = "maximum number of patches per site on each land use type" ; + double fates_maxpatches_by_landuse(fates_landuseclass) ; + fates_maxpatches_by_landuse:units = "count" ; + fates_maxpatches_by_landuse:long_name = "maximum number of patches per site on each land use type" ; double fates_canopy_closure_thresh ; fates_canopy_closure_thresh:units = "unitless" ; fates_canopy_closure_thresh:long_name = "tree canopy coverage at which crown area allometry changes from savanna to forest value" ; @@ -1597,7 +1597,7 @@ data: fates_frag_cwd_frac = 0.045, 0.075, 0.21, 0.67 ; - fates_maxpatches_bylanduse = 10, 4, 1, 1, 1 ; + fates_maxpatches_by_landuse = 10, 4, 1, 1, 1 ; fates_canopy_closure_thresh = 0.8 ; From 059a03eb23f7015dc9c95365699cc3e7c08b2129 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 15 Sep 2023 14:48:39 -0700 Subject: [PATCH 113/250] fix total area variable name --- main/EDInitMod.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 0037dc2ee2..d36ede5af0 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -12,7 +12,6 @@ module EDInitMod use FatesConstantsMod , only : nearzero use FatesConstantsMod , only : n_landuse_cats use FatesConstantsMod , only : fates_unset_r8 - use FatesConstantsMod , only : primaryforest use FatesConstantsMod , only : nearzero, area_error_4, area_error_3 use FatesGlobals , only : endrun => fates_endrun use EDParamsMod , only : nclmax @@ -560,7 +559,7 @@ subroutine init_patches( nsites, sites, bc_in) integer :: num_new_patches integer :: nocomp_pft real(r8) :: newparea, newparea_withlanduse - real(r8) :: tota !check on area + real(r8) :: total !check on area real(r8) :: litt_init !invalid for satphen, 0 otherwise real(r8) :: old_carea integer :: is_first_patch From df91bb2903969126bae3b79dd7cd3d18b07ff57f Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Mon, 18 Sep 2023 17:34:23 -0700 Subject: [PATCH 114/250] fixed dimension order --- parameter_files/fates_params_default.cdl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index e58ff5c7f4..f7ee94a1a9 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -8,12 +8,12 @@ dimensions: fates_history_size_bins = 13 ; fates_hlm_pftno = 14 ; fates_hydr_organs = 4 ; + fates_landuseclass = 5 ; fates_leafage_class = 1 ; fates_litterclass = 6 ; fates_pft = 12 ; fates_plant_organs = 4 ; fates_string_length = 60 ; - fates_landuseclass = 5 ; variables: double fates_history_ageclass_bin_edges(fates_history_age_bins) ; fates_history_ageclass_bin_edges:units = "yr" ; From 6d59ea53a32b8af29559a842670c6eb8a5f8bd2a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 19 Sep 2023 12:39:43 -0400 Subject: [PATCH 115/250] add readme to init bld directory --- functional_unit_testing/radiation/bld/README | 1 + 1 file changed, 1 insertion(+) create mode 100644 functional_unit_testing/radiation/bld/README diff --git a/functional_unit_testing/radiation/bld/README b/functional_unit_testing/radiation/bld/README new file mode 100644 index 0000000000..dc7db6c15f --- /dev/null +++ b/functional_unit_testing/radiation/bld/README @@ -0,0 +1 @@ +This is a placeholder to force git to initialize the bld directory \ No newline at end of file From 3a6b2dcd060ae5182b6731d158f914ddac527665 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 19 Sep 2023 14:03:08 -0400 Subject: [PATCH 116/250] Updates to two-stream functional unit tests --- .../radiation/RadiationUTestDriver.py | 99 ++++++++++++------- .../radiation/f90_src/WrapShrMod.F90 | 5 +- radiation/TwoStreamMLPEMod.F90 | 7 +- 3 files changed, 70 insertions(+), 41 deletions(-) diff --git a/functional_unit_testing/radiation/RadiationUTestDriver.py b/functional_unit_testing/radiation/RadiationUTestDriver.py index a553ab3b1f..b22d262be2 100644 --- a/functional_unit_testing/radiation/RadiationUTestDriver.py +++ b/functional_unit_testing/radiation/RadiationUTestDriver.py @@ -32,7 +32,7 @@ font = {'family' : 'sans-serif', 'weight' : 'normal', - 'size' : 12} + 'size' : 11} matplotlib.rc('font', **font) @@ -103,8 +103,17 @@ def __init__(self,n_vai): self.r_abs = np.zeros([n_vai]) #self.sunfrac = np.zeros([n_vai]) +class patch_type: + def __init__(self,ground_albedo_diff,ground_albedo_beam): + self.ground_albedo_beam = ground_albedo_diff + self.ground_albedo_beam = ground_albedo_beam + self.cohorts = [] + + # uses the form: + # patch.cohorts.append(cohort_type(n_vai,lai,sai)) + class cohort_type: - def __init__(self,n_vai,lai,sai): + def __init__(self,n_vai,area_frac,lai,sai,pft): self.n_vai = n_vai #self.avai = np.zeros([n_vai]) @@ -114,6 +123,7 @@ def __init__(self,n_vai,lai,sai): self.rb_abs_leaf = np.zeros([n_vai]) self.r_abs_stem = np.zeros([n_vai]) self.sunfrac = np.zeros([n_vai]) + self.pft = pft def main(argv): @@ -148,13 +158,13 @@ def main(argv): if(False): ParallelElementPerturbDist() - if(True): + if(False): SunFracTests() if(True): SingleElementPerturbTest() - if(True): + if(False): SerialParallelCanopyTest() plt.show() @@ -183,20 +193,21 @@ def SerialParallelCanopyTest(): #self.n_vai = n_vai #self.avai = np.zeros([n_vai]) - + # Five elements (cohorts), each take up 20% of the space + area_frac = 0.2 serialc = [] - serialc.append(cohort_type(100,cohort_lai[0],cohort_lai[0]*sai_frac)) - serialc.append(cohort_type(100,cohort_lai[1],cohort_lai[1]*sai_frac)) - serialc.append(cohort_type(100,cohort_lai[2],cohort_lai[2]*sai_frac)) - serialc.append(cohort_type(100,cohort_lai[3],cohort_lai[3]*sai_frac)) - serialc.append(cohort_type(100,cohort_lai[4],cohort_lai[4]*sai_frac)) + serialc.append(cohort_type(100,area_frac,cohort_lai[0],cohort_lai[0]*sai_frac,pft)) + serialc.append(cohort_type(100,area_frac,cohort_lai[1],cohort_lai[1]*sai_frac,pft)) + serialc.append(cohort_type(100,area_frac,cohort_lai[2],cohort_lai[2]*sai_frac,pft)) + serialc.append(cohort_type(100,area_frac,cohort_lai[3],cohort_lai[3]*sai_frac,pft)) + serialc.append(cohort_type(100,area_frac,cohort_lai[4],cohort_lai[4]*sai_frac,pft)) parallelc = [] - parallelc.append(cohort_type(100,cohort_lai[0],cohort_lai[0]*sai_frac)) - parallelc.append(cohort_type(100,cohort_lai[1],cohort_lai[1]*sai_frac)) - parallelc.append(cohort_type(100,cohort_lai[2],cohort_lai[2]*sai_frac)) - parallelc.append(cohort_type(100,cohort_lai[3],cohort_lai[3]*sai_frac)) - parallelc.append(cohort_type(100,cohort_lai[4],cohort_lai[4]*sai_frac)) + parallelc.append(cohort_type(100,area_frac,cohort_lai[0],cohort_lai[0]*sai_frac,pft)) + parallelc.append(cohort_type(100,area_frac,cohort_lai[1],cohort_lai[1]*sai_frac,pft)) + parallelc.append(cohort_type(100,area_frac,cohort_lai[2],cohort_lai[2]*sai_frac,pft)) + parallelc.append(cohort_type(100,area_frac,cohort_lai[3],cohort_lai[3]*sai_frac,pft)) + parallelc.append(cohort_type(100,area_frac,cohort_lai[4],cohort_lai[4]*sai_frac,pft)) elems = [] elems.append([]) @@ -683,11 +694,34 @@ def ParallelElementPerturbDist(): plt.tight_layout() plt.show() dealloc_twostream_call() + def SingleElementPerturbTest(): # =================================================================================== + # In this test, we have a canopy that is constructed from a single cohort + # and therefore a single element. The cohort does not cover all of the ground + # so their is an air element in parallel with the leaf/stem element. + + ground_albedo_diff = 0.1 + ground_albedo_beam = 0.1 + veg_frac_snow = 0.0 + + patch = patch_type(ground_albedo_diff,ground_albedo_beam) + + # Vegetation cohort + area_frac = 0.9 + lai = 2.0 + sai = 0.5 + pft = 1 + air_pft = 0 + patch.cohorts.append(cohort_type(100,area_frac,lai,sai,pft)) + + # Open space (air) + patch.cohorts.append(cohort_type(100,1.0-area_frac,0.,0.,air_pft)) + + n_col = 2 n_layer = 1 iret = alloc_twostream_call(ci(n_layer),ci(n_col)) @@ -695,12 +729,9 @@ def SingleElementPerturbTest(): ican = 1 # Single canopy layer icol = 1 # Single PFT pft = 1 # Use PFT number 1 - area = 0.9 # Assume only 90% of the ground is covered - lai = 2.0 # LAI - sai = 0.5 # SAI vai = lai+sai - iret = setup_canopy_call(c_int(1),c_int(1),c_int(pft),c_double(area),c_double(lai),c_double(sai)) - iret = setup_canopy_call(c_int(1),c_int(2),c_int(0),c_double(1.0-area),c_double(0.0),c_double(0.0)) + iret = setup_canopy_call(c_int(1),c_int(1),c_int(pft),c_double(area_frac),c_double(lai),c_double(sai)) + iret = setup_canopy_call(c_int(1),c_int(2),c_int(0),c_double(1.0-area_frac),c_double(0.0),c_double(0.0)) # Decide on a band: @@ -718,14 +749,14 @@ def SingleElementPerturbTest(): # Make parameter pertubations, bump up 50% pp_dict = {} - pp_dict['Kb'] = 0.66118239744 #74 #*1.5 - pp_dict['Kd'] = 0.9063246621781269 #*1.5 - pp_dict['om'] = 0.17819999999999997 #*1.5 - pp_dict['betab'] = 0.48253004714288084 #*1.5 - pp_dict['betad'] = 0.5999777777777778 #*1.5 - - R_beam = 100. - R_diff = 100. + pp_dict['Kb'] = 1.5*0.66118239744 #74 #*1.5 + pp_dict['Kd'] = 1.5*0.9063246621781269 #*1.5 + pp_dict['om'] = 1.5*0.17819999999999997 #*1.5 + pp_dict['betab'] = 1.5*0.48253004714288084 #*1.5 + pp_dict['betad'] = 1.5*0.5999777777777778 #*1.5 + + R_beam = 0.5 + R_diff = 0.5 cosz = np.cos(0.0) n_vai = 100 vai_a = np.linspace(0,vai,num=n_vai) @@ -757,13 +788,10 @@ def SingleElementPerturbTest(): cd_ffdiff_beam = c_double(-9.0) cd_ffdiff_diff = c_double(-9.0) - ground_albedo_diff = 0.1 - ground_albedo_beam = 0.1 - frac_snow = 0.0 - + iret = grndsnow_albedo_call(c_int(ib),c_double(ground_albedo_diff),*ccharnb('albedo_grnd_diff')) iret = grndsnow_albedo_call(c_int(ib),c_double(ground_albedo_beam),*ccharnb('albedo_grnd_beam')) - iret = canopy_prep_call(c8(frac_snow)) + iret = canopy_prep_call(c8(veg_frac_snow)) iret = zenith_prep_call(c8(cosz)) iret = solver_call(ci(ib),ci(normalized_boundary),c8(1.0),c8(1.0), \ @@ -798,7 +826,7 @@ def SingleElementPerturbTest(): i = -1 for key,val in pp_dict.items(): i=i+1 - iret = canopy_prep_call(c8(frac_snow)) + iret = canopy_prep_call(c8(veg_frac_snow)) iret = zenith_prep_call(c8(cosz)) iret = forceparam_call(c_int(ican),c_int(icol),ci(ib),c_double(val),*ccharnb(key)) @@ -824,7 +852,7 @@ def SingleElementPerturbTest(): p_drdv_diff_up[iv-1] = (p_r_diff_up[iv]-p_r_diff_up[iv-1])/dv - fig1, ((ax1,ax2),(ax3,ax4)) = plt.subplots(2,2,figsize=(9,7)) + fig1, ((ax1,ax2),(ax3,ax4)) = plt.subplots(2,2,figsize=(7.5,6.5)) ap = ax1.plot(r_beam,vai_a,p_r_beam[:,i],vai_a) first_color = ap[0].get_color() @@ -879,6 +907,7 @@ def SingleElementPerturbTest(): verticalalignment='center', transform=ax4.transAxes,backgroundcolor=[1.0,1.0,1.0],fontsize=12,color=first_color) ax4.text(0.5,0.5,r"{0}={1:.2f}".format(key,val),color=last_color) plt.subplots_adjust(wspace=0.1, hspace=0.25) + plt.tight_layout() plt.show() diff --git a/functional_unit_testing/radiation/f90_src/WrapShrMod.F90 b/functional_unit_testing/radiation/f90_src/WrapShrMod.F90 index 094b3d9cbc..7bc093b4d5 100644 --- a/functional_unit_testing/radiation/f90_src/WrapShrMod.F90 +++ b/functional_unit_testing/radiation/f90_src/WrapShrMod.F90 @@ -8,9 +8,12 @@ module shr_log_mod function shr_log_errMsg(source, line) result(ans) character(kind=c_char,len=*), intent(in) :: source integer(c_int), intent(in) :: line + character(kind=c_char,len=4) :: cline ! character version of int character(kind=c_char,len=128) :: ans + + write(cline,'(I4)') line + ans = "source: " // trim(source) // " line: "// trim(cline) - ans = "source: " // trim(source) // " line: " end function shr_log_errMsg end module shr_log_mod diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index d2e5c49925..3c0493abe2 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -1078,12 +1078,9 @@ subroutine Solve(this, ib, & type(scelg_type),pointer :: scelgp ! Pointer to the scelg data structure type(scelb_type),pointer :: scelbp ! Pointer to the scelb data structure - ! Parameters for solving via LAPACK DGELS() - character(1),parameter :: trans = 'N' ! Input matrix is not transposed - integer, parameter :: workmax = 100 ! Maximum iterations to minimize work - real(r8) :: work(workmax) ! Work array - integer :: lwork ! Dimension of work array + ! Parameters for solving via LAPACK DGELS() and DGESV() integer :: info ! Procedure diagnostic ouput + ! Testing switch ! If true, then allow elements ! of different layers, but same row, to have priority From fd0d926edbdd29201c7f87b48d7e2715ea8c296f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 20 Sep 2023 12:29:33 -0400 Subject: [PATCH 117/250] Connected the radiation model switch in the parameter file to the in-code logic --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 8 ++++---- .../radiation/RadiationUTestDriver.py | 1 - main/FatesRestartInterfaceMod.F90 | 6 +++--- radiation/FatesRadiationDriveMod.F90 | 8 ++++---- radiation/FatesRadiationMemMod.F90 | 2 -- radiation/FatesTwoStreamInterfaceMod.F90 | 10 +++++++--- 6 files changed, 18 insertions(+), 17 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index ad57b15e41..9d7e3e71cd 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -67,7 +67,7 @@ module FATESPlantRespPhotosynthMod use EDPftvarcon , only : EDPftvarcon_inst use TemperatureType, only : temperature_type use FatesRadiationMemMod, only : norman_solver,twostr_solver - use FatesRadiationMemMod, only : rad_solver + use EDParamsMod, only : radiation_model use FatesRadiationMemMod, only : ipar use FatesTwoStreamInterfaceMod, only : FatesGetCohortAbsRad use FatesAllometryMod , only : VegAreaLayer @@ -495,8 +495,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) rate_mask_if: if ( .not.rate_mask_z(iv,ft,cl) .or. & (hlm_use_planthydro.eq.itrue) .or. & - (rad_solver .eq. twostr_solver ) .or. & - (rad_solver .eq. norman_solver ) .or. & + (radiation_model .eq. twostr_solver ) .or. & + (radiation_model .eq. norman_solver ) .or. & (nleafage > 1) .or. & (hlm_parteh_mode .ne. prt_carbon_allom_hyp ) ) then @@ -617,7 +617,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! fsun = [m2 of sunlit leaves / m2 of total leaves] ! ------------------------------------------------------------------ - if_radsolver: if(rad_solver.eq.norman_solver) then + if_radsolver: if(radiation_model.eq.norman_solver) then laisun = currentPatch%elai_profile(cl,ft,iv)*currentPatch%f_sun(cl,ft,iv) laisha = currentPatch%elai_profile(cl,ft,iv)*(1._r8-currentPatch%f_sun(cl,ft,iv)) diff --git a/functional_unit_testing/radiation/RadiationUTestDriver.py b/functional_unit_testing/radiation/RadiationUTestDriver.py index b22d262be2..244fe94845 100644 --- a/functional_unit_testing/radiation/RadiationUTestDriver.py +++ b/functional_unit_testing/radiation/RadiationUTestDriver.py @@ -19,7 +19,6 @@ import os import sys import getopt -#import code # For development: code.interact(local=dict(globals(), **locals())) import code # For development: code.interact(local=locals()) code.interact(local=dict(globals(), **locals())) import time import importlib diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 1f122c60b7..8f23acf7b1 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -46,10 +46,10 @@ module FatesRestartInterfaceMod use PRTGenericMod, only : num_elements use FatesRunningMeanMod, only : rmean_type use FatesRunningMeanMod, only : ema_lpa - use FatesRadiationMemMod, only : num_swb,rad_solver,norman_solver + use FatesRadiationMemMod, only : num_swb,norman_solver use TwoStreamMLPEMod, only : normalized_upper_boundary use EDParamsMod, only : regeneration_model - + use EDParamsMod, only : radiation_model ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg @@ -3630,7 +3630,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) enddo else - if_solver: if(rad_solver.eq.norman_solver) then + if_solver: if(radiation_model.eq.norman_solver) then call PatchNormanRadiation (currentPatch, & bc_out(s)%albd_parb(ifp,:), & diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index c96f8f7014..06e080bb45 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -29,7 +29,7 @@ module FatesRadiationDriveMod use FatesRadiationMemMod, only : alb_ice, rho_snow, tau_snow use FatesRadiationMemMod, only : norman_solver use FatesRadiationMemMod, only : twostr_solver - use FatesRadiationMemMod, only : rad_solver + use EDParamsMod, only : radiation_model use TwoStreamMLPEMod, only : normalized_upper_boundary use FatesTwoStreamInterfaceMod, only : FatesPatchFSun use FatesTwoStreamInterfaceMod, only : CheckPatchRadiationBalance @@ -127,7 +127,7 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) ! RGK: The ZenithPrep should only be necessary if the flag is true ! Move and test this. - if(rad_solver.eq.twostr_solver) then + if(radiation_model.eq.twostr_solver) then call currentPatch%twostr%CanopyPrep(bc_in(s)%fcansno_pa(ifp)) call currentPatch%twostr%ZenithPrep(bc_in(s)%coszen_pa(ifp)) end if @@ -152,7 +152,7 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) else - if_solver: if(rad_solver.eq.norman_solver) then + if_solver: if(radiation_model.eq.norman_solver) then call PatchNormanRadiation (currentPatch, & bc_out(s)%albd_parb(ifp,:), & ! Surface Albedo direct @@ -1220,7 +1220,7 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) cpatch%parprof_pft_dir_z(:,:,:) = 0._r8 cpatch%parprof_pft_dif_z(:,:,:) = 0._r8 - if_norm_twostr: if (rad_solver.eq.norman_solver) then + if_norm_twostr: if (radiation_model.eq.norman_solver) then ! Loop over patches to calculate laisun_z and laisha_z for each layer. ! Derive canopy laisun, laisha, and fsun from layer sums. diff --git a/radiation/FatesRadiationMemMod.F90 b/radiation/FatesRadiationMemMod.F90 index f41a18e455..3e72e766d4 100644 --- a/radiation/FatesRadiationMemMod.F90 +++ b/radiation/FatesRadiationMemMod.F90 @@ -16,8 +16,6 @@ Module FatesRadiationMemMod integer, parameter, public :: norman_solver = 1 integer, parameter, public :: twostr_solver = 2 - integer, parameter, public :: rad_solver = twostr_solver - integer, parameter, public :: num_rad_stream_types = 2 ! The number of radiation streams used (direct/diffuse) diff --git a/radiation/FatesTwoStreamInterfaceMod.F90 b/radiation/FatesTwoStreamInterfaceMod.F90 index 8eb4e2f0eb..114f8cddd9 100644 --- a/radiation/FatesTwoStreamInterfaceMod.F90 +++ b/radiation/FatesTwoStreamInterfaceMod.F90 @@ -24,9 +24,9 @@ Module FatesTwoStreamInterfaceMod use TwoStreamMLPEMod , only : AllocateRadParams use TwoStreamMLPEMod , only : rel_err_thresh,area_err_thresh use EDPftvarcon , only : EDPftvarcon_inst - use FatesRadiationMemMod , only : rad_solver,twostr_solver + use FatesRadiationMemMod , only : twostr_solver use FatesAllometryMod , only : VegAreaLayer - + use EDParamsMod , only : radiation_model implicit none @@ -87,7 +87,7 @@ subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) !type(ed_cohort_type), pointer :: elem_co_ptrs(ncl*max_el_per_layer,100) - if(rad_solver.ne.twostr_solver)return + if(radiation_model.ne.twostr_solver)return max_elements = -1 ifp=0 @@ -301,6 +301,10 @@ subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) patch => patch%younger end do + ! Re-evaluate the scratch space used for solving two-stream radiation + ! The scratch space needs to be 2x the number of computational elements + ! for the patch with the most elements. + if(allocated(site%taulambda_2str) .and. max_elements>0 )then n_scr = ubound(site%taulambda_2str,dim=1) allocate_scratch = .false. From d7396b177fda1a597a2960685438b9a037644337 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 21 Sep 2023 12:36:58 -0400 Subject: [PATCH 118/250] Updated radiation model checks to allow for norman and two-stream. Updated netcdf python tools to use updated scipy library configuration --- main/EDPftvarcon.F90 | 3 ++- parameter_files/patch_default_bciopt224.xml | 2 +- tools/BatchPatchParams.py | 11 +++++++---- tools/FatesPFTIndexSwapper.py | 7 ++++--- tools/modify_fates_paramfile.py | 9 +++++---- 5 files changed, 19 insertions(+), 13 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 9bfebb3b84..1795d9c360 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -8,6 +8,7 @@ module EDPftvarcon ! !USES: use FatesRadiationMemMod, only: num_swb,ivis,inir + use FatesRadiationMemMod, only: norman_solver,twostr_solver use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : nearzero use FatesConstantsMod, only : itrue, ifalse @@ -1743,7 +1744,7 @@ subroutine FatesCheckParams(is_master) if(.not.is_master) return - if(radiation_model.ne.1) then + if(.not.any(radiation_model == [norman_solver,twostr_solver])) then write(fates_log(),*) 'The only available canopy radiation model' write(fates_log(),*) 'is the Norman scheme: fates_rad_model = 1' write(fates_log(),*) 'The two-stream scheme is not available yet' diff --git a/parameter_files/patch_default_bciopt224.xml b/parameter_files/patch_default_bciopt224.xml index 8ab504ed31..b1ec419f64 100644 --- a/parameter_files/patch_default_bciopt224.xml +++ b/parameter_files/patch_default_bciopt224.xml @@ -2,7 +2,7 @@ This parameter dataset was created by Ryan Knox rgknox@lbl.gov. Please contact if using in published work. The calibration uses the following datasets: [1] Ely et al. 2019. Leaf mass area, Panama. NGEE-Tropics data collection.http://dx.doi.org/10.15486/ngt/1411973 and [2] Condit et al. 2019. Complete data from the Barro Colorado 50-ha plot. https://doi.org/10.15146/5xcp-0d46. [3] Koven et al. 2019. Benchmarking and parameter sensitivity of physiological and vegetation dynamics using the functionally assembled terrestrial ecosystem simulator. Biogeosciences. The ECA nutrient aquisition parmeters are unconstrained, the file output naming convention vmn6phi is shorthand for vmax for nitrogen uptake is order e-6 and for phosphorus is excessively high. These parameters were calibrated with the special fates modification in main/EDTypesMod.F90: nclmax = 3 fates_params_default.cdl - fates_params_opt224_040822_api25.cdl + fates_params_opt224_092023_api26.cdl 1 diff --git a/tools/BatchPatchParams.py b/tools/BatchPatchParams.py index 99a6f6bd76..db4588ca5d 100755 --- a/tools/BatchPatchParams.py +++ b/tools/BatchPatchParams.py @@ -7,7 +7,7 @@ import os import argparse import code # For development: code.interact(local=dict(globals(), **locals())) -from scipy.io import netcdf +import scipy import xml.etree.ElementTree as et debug = True @@ -105,15 +105,18 @@ def main(): base_nc = os.popen('mktemp').read().rstrip('\n') gencmd = "ncgen -o "+base_nc+" "+base_cdl os.system(gencmd) - + # Generate a temp output file name new_nc = os.popen('mktemp').read().rstrip('\n') + os.system("ls "+base_nc) + os.system("ls "+new_nc) + # Use FatesPFTIndexSwapper.py to prune out unwanted PFTs pft_trim_list = xmlroot.find('pft_trim_list').text.replace(" ","") swapcmd="../tools/FatesPFTIndexSwapper.py --pft-indices="+pft_trim_list+" --fin="+base_nc+" --fout="+new_nc+" --nohist" #+" 1>/dev/null" os.system(swapcmd) - + # On subsequent parameters, overwrite the file paramroot = xmlroot.find('parameters') @@ -173,7 +176,7 @@ def main(): # Append history - fp_nc = netcdf.netcdf_file(new_nc, 'a') + fp_nc = scipy.io.netcdf_file(new_nc, 'a') fp_nc.history = "This file was generated by BatchPatchParams.py:\n"\ "CDL Base File = {}\n"\ "XML patch file = {}"\ diff --git a/tools/FatesPFTIndexSwapper.py b/tools/FatesPFTIndexSwapper.py index 99e258bdc6..dee1032a6c 100755 --- a/tools/FatesPFTIndexSwapper.py +++ b/tools/FatesPFTIndexSwapper.py @@ -15,7 +15,8 @@ import getopt import code # For development: code.interact(local=locals()) from datetime import datetime -from scipy.io import netcdf +#from scipy.io import netcdf +import scipy #import matplotlib.pyplot as plt @@ -147,9 +148,9 @@ def main(argv): num_pft_out = len(donor_pft_indices) # Open the netcdf files - fp_out = netcdf.netcdf_file(output_fname, 'w') + fp_out = scipy.io.netcdf_file(output_fname, 'w') - fp_in = netcdf.netcdf_file(input_fname, 'r') + fp_in = scipy.io.netcdf_file(input_fname, 'r') for key, value in sorted(fp_in.dimensions.items()): if(key==pft_dim_name): diff --git a/tools/modify_fates_paramfile.py b/tools/modify_fates_paramfile.py index adacb2457b..5d043f4050 100755 --- a/tools/modify_fates_paramfile.py +++ b/tools/modify_fates_paramfile.py @@ -17,7 +17,8 @@ # ======================================================================================= import os -from scipy.io import netcdf as nc +#from scipy.io import netcdf as nc +import scipy import argparse import shutil import tempfile @@ -85,7 +86,7 @@ def main(): try: shutil.copyfile(args.inputfname, tempfilename) # - ncfile = nc.netcdf_file(tempfilename, 'a') + ncfile = scipy.io.netcdf_file(tempfilename, 'a') # var = ncfile.variables[args.varname] @@ -174,8 +175,8 @@ def main(): ### close the file that's open and start over. ncfile.close() os.remove(tempfilename) - ncfile = nc.netcdf_file(tempfilename, 'w') - ncfile_old = nc.netcdf_file(args.inputfname, 'r') + ncfile = scipy.io.netcdf_file(tempfilename, 'w') + ncfile_old = scipy.io.netcdf_file(args.inputfname, 'r') # try: ncfile.history = ncfile_old.history From bc03f653b2be482a24e47e11e7be3b49ab413be5 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 27 Sep 2023 12:25:22 -0400 Subject: [PATCH 119/250] Started a new radiation unit test that is used to target specific canopy and radiation compositions that may had failed or are problematic --- .../radiation/RadiationUTestDriver.py | 37 +++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/functional_unit_testing/radiation/RadiationUTestDriver.py b/functional_unit_testing/radiation/RadiationUTestDriver.py index 244fe94845..eb8e409de6 100644 --- a/functional_unit_testing/radiation/RadiationUTestDriver.py +++ b/functional_unit_testing/radiation/RadiationUTestDriver.py @@ -14,6 +14,7 @@ import argparse #from matplotlib.backends.backend_pdf import PdfPages import platform +import xml.etree.ElementTree as ET import numpy as np import matplotlib import os @@ -154,6 +155,9 @@ def main(argv): # Process the core 2Stream parameters from parameters in file iret = param_prep_call(ci(n_pft)) + if(False): + TestCrash() + if(False): ParallelElementPerturbDist() @@ -167,7 +171,40 @@ def main(argv): SerialParallelCanopyTest() plt.show() + +def TestCrash(): + + # This is used to diagnose a specific failure. This is probably + # reconstructed from the output dump of a failed solve. + + xmlfile = "f45error_elements.xml" + xmlroot = ET.parse(xmlfile).getroot() + print("\nOpenend: "+xmlfile) + cosz = float(xmlroot.find('cosz').text.strip()) + ib = int(xmlroot.find('band_id').text.strip()) + #elem = xmlroot.find('time_control') + + # Iterate through canopy layers + areas = [] + print("Loading Layers") + for can in xmlroot.iter('can'): + print("canopy layer: {}".format(int(can.attrib['id'].strip()))) + # Iterate through elements in each layer + can_id = int(can.attrib['id'].strip()) + for elem in can.iter('elem'): + elem_id = int(elem.attrib['id'].strip()) + textlist = elem.text.split(',') + pft = int(textlist[0].strip()) + lai = float(textlist[1].strip()) + sai = float(textlist[2].strip()) + area = float(textlist[3].strip()) + + areas.append(area) + + code.interact(local=dict(globals(), **locals())) + + def SerialParallelCanopyTest(): From 174f2923ab9b5e178dea79465a3c55e1c66883d2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 29 Sep 2023 15:54:23 -0400 Subject: [PATCH 120/250] Updates to two-stream error reporting, checking the linear solution, and albedo correction --- radiation/FatesRadiationDriveMod.F90 | 2 +- radiation/FatesTwoStreamInterfaceMod.F90 | 3 +- radiation/TwoStreamMLPEMod.F90 | 88 +++++++++++++++--------- 3 files changed, 60 insertions(+), 33 deletions(-) diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index 261048a9d6..32efb4ce82 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -200,7 +200,7 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) if(bc_out(s)%fabi_parb(ifp,ib)>1.0 .or. bc_out(s)%fabd_parb(ifp,ib)>1.0)then write(fates_log(),*) 'absorbed fraction > 1.0?' write(fates_log(),*) ifp,ib,bc_out(s)%fabi_parb(ifp,ib),bc_out(s)%fabd_parb(ifp,ib) - call twostr%Dump(ib,bc_in(s)%coszen_pa(ifp),lat=sites(s)%lat,lon=sites(s)%lon) + call twostr%Dump(ib,lat=sites(s)%lat,lon=sites(s)%lon) call endrun(msg=errMsg(sourcefile, __LINE__)) end if end if diff --git a/radiation/FatesTwoStreamInterfaceMod.F90 b/radiation/FatesTwoStreamInterfaceMod.F90 index 5e838eb88c..3840715912 100644 --- a/radiation/FatesTwoStreamInterfaceMod.F90 +++ b/radiation/FatesTwoStreamInterfaceMod.F90 @@ -252,7 +252,8 @@ subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) twostr%scelg(ican,1)%sai = twostr%scelg(ican,1)%sai / area_ratio write(fates_log(),*) 'overfull areas' - call twostr%Dump(1,coszen_pa(ifp),lat=site%lat,lon=site%lon) + twostr%cosz = coszen_pa(ifp) + call twostr%Dump(1,lat=site%lat,lon=site%lon) call endrun(msg=errMsg(sourcefile, __LINE__)) end if diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index 3c0493abe2..47d793d3fc 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -204,7 +204,8 @@ Module TwoStreamMLPEMod ! parameters on short sub-daily timesteps real(r8) :: frac_snow ! Current mean snow-fraction of the canopy real(r8) :: frac_snow_old ! Previous mean snow-fraction of the canopy - + real(r8) :: cosz ! Current cosine of the zenith angle + contains procedure :: ZenithPrep ! Update coefficients as zenith changes @@ -586,13 +587,12 @@ end subroutine GetAbsRad ! ================================================================================================ - subroutine Dump(this,ib,cosz,lat,lon) + subroutine Dump(this,ib,lat,lon) ! Dump out everything we know about these two-stream elements class(twostream_type) :: this integer,intent(in) :: ib - real(r8),intent(in) :: cosz real(r8),optional,intent(in) :: lat real(r8),optional,intent(in) :: lon integer :: ican @@ -604,7 +604,7 @@ subroutine Dump(this,ib,cosz,lat,lon) write(log_unit,*) 'rdiff_atm: ',this%band(ib)%Rdiff_atm write(log_unit,*) 'alb grnd diff: ',this%band(ib)%albedo_grnd_diff write(log_unit,*) 'alb grnd beam: ',this%band(ib)%albedo_grnd_beam - write(log_unit,*) 'cosz: ',cosz + write(log_unit,*) 'cosz: ',this%cosz write(log_unit,*) 'snow fraction: ',this%frac_snow if(present(lat)) write(log_unit,*) 'lat: ',lat if(present(lon)) write(log_unit,*) 'lon: ',lon @@ -878,6 +878,8 @@ subroutine ZenithPrep(this,cosz) cosz = max(0.001,cosz) + this%cosz = cosz + do_ican: do ican = 1,this%n_lyr do_ical: do icol = 1,this%n_col(ican) @@ -1038,6 +1040,11 @@ subroutine Solve(this, ib, & real(r8) :: frac_beam_grnd_beam ! fraction of beam radiation at ground resulting from of beam at canopy top [-] real(r8) :: frac_diff_grnd_beam ! fraction of down diffuse radiation at ground resulting from beam at canopy top real(r8) :: frac_diff_grnd_diff ! fraction of down diffuse radiation at ground resulting from down diffuse at canopy top [-] + + ! These arrays are only used if we run in debug mode, and are + ! looking to report the error on the linear solution e = TAU - OMEGA*LAMBDA + real(r8),allocatable :: tau_temp(:) + real(r8),allocatable :: omega_temp(:,:) ! Two stream solution arrays ! Each of these are given generic names, because @@ -1071,6 +1078,7 @@ subroutine Solve(this, ib, & real(r8) :: r_abs_stem ! total absorbed by stems (dummy) real(r8) :: r_abs_snow ! total absorbed by snow (dummy) real(r8) :: leaf_sun_frac ! sunlit fraction of leaves (dummy) + real(r8) :: err1,err2 real(r8) :: rel_err ! radiation canopy balance conservation ! error, fraction of incident @@ -1087,8 +1095,6 @@ subroutine Solve(this, ib, & ! flux into the other element, instead of a mix logical, parameter :: continuity_on = .true. - - ! ------------------------------------------------------------------------------------ ! Example system of equations for 2 parallel columns in each of two canopy ! layers. Each line is one of the balanc equations. And the x's are @@ -1284,7 +1290,7 @@ subroutine Solve(this, ib, & end if omega(1:n_eq,1:n_eq) = 0._r8 - taulamb(1:n_eq) = 0._r8 + taulamb(1:n_eq) = 0._r8 ! -------------------------------------------------------------------- ! I. Flux equations with the atmospheric boundary @@ -1459,27 +1465,44 @@ subroutine Solve(this, ib, & end do - !LAMBDA(1:n_eq) = TAU(1:n_eq) - ! Solution borrowed from Greg Lemieux's usage during FATES canopy trimming: - ! Compute the optimum size of the work array + ! dgesv will overwrite TAU with LAMBDA + ! ie, left side of TAU = OMEGA*LAMBDA + ! lets dave it temporarily + if(debug)then + allocate(tau_temp(n_eq),omega_temp(n_eq,n_eq)) + tau_temp(1:n_eq) = taulamb(1:n_eq) + omega_temp(1:n_eq,1:n_eq) = omega(1:n_eq,1:n_eq) + end if + ! Find the solution call dgesv(n_eq, 1, omega(1:n_eq,1:n_eq), n_eq, ipiv(1:n_eq), taulamb(1:n_eq), n_eq, info) - !lwork = -1 ! Ask dgels to compute optimal number of entries for work - !call dgels(trans, n_eq, n_eq, 1, omega(1:n_eq,1:n_eq), n_eq, taulamb(1:n_eq), n_eq, work, lwork, info) - !lwork = int(work(1)) ! Pick the optimum. TBD, can work(1) come back with greater than work size? - - ! Compute the minimum of 2-norm of of the least squares fit to solve for X - ! Note that dgels returns the solution by overwriting the taulamb array. - ! The result has the form: X = [b; m] - !call dgels(trans, n_eq, n_eq, 1, omega(1:n_eq,1:n_eq), n_eq, taulamb(1:n_eq), n_eq, work, lwork, info) - if(info.ne.0)then write(log_unit,*) 'Could not find a solution via dgesv' call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if(debug)then + ! Perform a forward check on the solution error + do ilem = 1,n_eq + err1 = tau_temp(ilem) - sum(taulamb(1:n_eq)*omega_temp(ilem,1:n_eq)) + if(err1>1.e-9_r8)then + write(log_unit,*) 'Poor forward solution on two-stream solver' + write(log_unit,*) 'isol (1=beam or 2=diff): ',isol + write(log_unit,*) 'i (equation): ',ilem + write(log_unit,*) 'band index (1=vis,2=nir): ',ib + write(log_unit,*) 'error (tau(i) - omega(i,:)*lambda(:)) ',err1 + this%band(ib)%Rbeam_atm = 1._r8 + this%band(ib)%Rdiff_atm = 1._r8 + call this%Dump(ib) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do + deallocate(tau_temp,omega_temp) + end if + + ! Save the solution terms ilem_off = 0 @@ -1611,22 +1634,13 @@ subroutine Solve(this, ib, & diff_err = Rdiff_atm - (albedo_diff + frac_abs_can_diff + & frac_diff_grnd_diff*(1._r8-this%band(ib)%albedo_grnd_diff)) - !if( abs(rel_err) > rel_err_thresh ) then - if( rel_err.ne.rel_err) then + if( abs(rel_err) > rel_err_thresh ) then write(log_unit,*)"Total canopy flux balance not closing in TwoStrteamMLPEMod:Solve" write(log_unit,*)"Relative Error, delta/(Rbeam_atm+Rdiff_atm) :",rel_err write(log_unit,*)"Max Error: ",rel_err_thresh write(log_unit,*)"ib: ",ib - write(log_unit,*) beam_err,diff_err - write(log_unit,*)this%band(ib)%albedo_grnd_diff - write(log_unit,*) frac_diff_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_diff) + & - frac_beam_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_beam) - write(log_unit,*) frac_diff_grnd_diff*(1._r8-this%band(ib)%albedo_grnd_diff) - write(log_unit,*) albedo_beam,albedo_diff - write(log_unit,*) frac_abs_can_beam,frac_abs_can_diff - write(log_unit,*) frac_diff_grnd_beam,frac_beam_grnd_beam,frac_diff_grnd_diff - write(log_unit,*) "scattering coeff: ",(2*rad_params%om_leaf(ib,1)+0.5*rad_params%om_stem(ib,1))/2.5 - write(log_unit,*) "Breakdown:",this%n_lyr + write(log_unit,*)"scattering coeff: ",(2*rad_params%om_leaf(ib,1)+0.5*rad_params%om_stem(ib,1))/2.5 + write(log_unit,*)"Breakdown:",this%n_lyr do ican = 1,this%n_lyr do icol = 1,this%n_col(ican) scelgp => this%scelg(ican,icol) @@ -1644,6 +1658,18 @@ subroutine Solve(this, ib, & call endrun(msg=errMsg(sourcefile, __LINE__)) end if + ! Re-cast the abledos so they are direct result of the components. + ! CESM and E3SM have higher tolerances. We close to 1e-6 but they + ! close to 1e-8, which is just very difficult when the canopies + ! get complex + + albedo_beam = Rbeam_atm - (frac_abs_can_beam + & + frac_diff_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_diff) + & + frac_beam_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_beam)) + + albedo_diff = Rdiff_atm - (frac_abs_can_diff + & + frac_diff_grnd_diff*(1._r8-this%band(ib)%albedo_grnd_diff)) + ! Set the boundary conditions back to unknown for a normalized solution ! This prevents us from calling the absorption and flux query routines incorrectly. From e10595c0d7d58bf5f3d1cea1eb75c64100fa7731 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 4 Oct 2023 10:34:48 -0600 Subject: [PATCH 121/250] Applied higher threshold to two-stream closure check, added forced closure logical --- radiation/TwoStreamMLPEMod.F90 | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index 47d793d3fc..5d11b2412a 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -43,7 +43,7 @@ Module TwoStreamMLPEMod ! Allowable error, as a fraction of total incident for total canopy ! radiation balance checks - real(r8), public, parameter :: rel_err_thresh = 1.e-8_r8 + real(r8), public, parameter :: rel_err_thresh = 1.e-6_r8 real(r8), public, parameter :: area_err_thresh = rel_err_thresh*0.1_r8 ! These are the codes for how the upper boundary is specified, normalized or absolute @@ -1095,6 +1095,8 @@ subroutine Solve(this, ib, & ! flux into the other element, instead of a mix logical, parameter :: continuity_on = .true. + logical, parameter :: albedo_corr = .false. + ! ------------------------------------------------------------------------------------ ! Example system of equations for 2 parallel columns in each of two canopy ! layers. Each line is one of the balanc equations. And the x's are @@ -1487,7 +1489,7 @@ subroutine Solve(this, ib, & ! Perform a forward check on the solution error do ilem = 1,n_eq err1 = tau_temp(ilem) - sum(taulamb(1:n_eq)*omega_temp(ilem,1:n_eq)) - if(err1>1.e-9_r8)then + if(abs(err1)>rel_err_thresh)then write(log_unit,*) 'Poor forward solution on two-stream solver' write(log_unit,*) 'isol (1=beam or 2=diff): ',isol write(log_unit,*) 'i (equation): ',ilem @@ -1662,14 +1664,16 @@ subroutine Solve(this, ib, & ! CESM and E3SM have higher tolerances. We close to 1e-6 but they ! close to 1e-8, which is just very difficult when the canopies ! get complex + if(albedo_corr)then - albedo_beam = Rbeam_atm - (frac_abs_can_beam + & - frac_diff_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_diff) + & - frac_beam_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_beam)) + albedo_beam = Rbeam_atm - (frac_abs_can_beam + & + frac_diff_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_diff) + & + frac_beam_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_beam)) + + albedo_diff = Rdiff_atm - (frac_abs_can_diff + & + frac_diff_grnd_diff*(1._r8-this%band(ib)%albedo_grnd_diff)) - albedo_diff = Rdiff_atm - (frac_abs_can_diff + & - frac_diff_grnd_diff*(1._r8-this%band(ib)%albedo_grnd_diff)) - + end if ! Set the boundary conditions back to unknown for a normalized solution ! This prevents us from calling the absorption and flux query routines incorrectly. From 521728925ec5b2a14410fd1053cd7777628aec6d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 4 Oct 2023 10:36:54 -0600 Subject: [PATCH 122/250] Set albedo correction to true in fates two-stream --- radiation/TwoStreamMLPEMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index 5d11b2412a..094ac1ac9b 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -1095,7 +1095,7 @@ subroutine Solve(this, ib, & ! flux into the other element, instead of a mix logical, parameter :: continuity_on = .true. - logical, parameter :: albedo_corr = .false. + logical, parameter :: albedo_corr = .true. ! ------------------------------------------------------------------------------------ ! Example system of equations for 2 parallel columns in each of two canopy From dd58c11e4a5dc3b8c21313d5a1877ff1dde4c270 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Wed, 4 Oct 2023 17:10:31 -0700 Subject: [PATCH 123/250] adding some more comments to spawn_patches --- biogeochem/EDPatchDynamicsMod.F90 | 91 +++++++++++++++++++++---------- 1 file changed, 63 insertions(+), 28 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 3ccb7b7943..56ee469253 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -417,7 +417,9 @@ end subroutine disturbance_rates subroutine spawn_patches( currentSite, bc_in) ! ! !DESCRIPTION: - ! In this subroutine, the following happens + ! In this subroutine, the following happens, + ! all of which within a complex loop structure of (from outermost to innermost loop), + ! nocomp-PFT, disturbance type, donor patch land use label, and receiver patch land use label: ! 1) the total area disturbed is calculated ! 2) a new patch is created ! 3) properties are averaged @@ -504,29 +506,54 @@ subroutine spawn_patches( currentSite, bc_in) ! If nocomp is not enabled, then this is not much of a loop, it only passes through once. nocomp_pft_loop: do i_nocomp_pft = min_nocomp_pft,max_nocomp_pft + ! we want at the second-outermost loop to go through all disturbance types, because we resolve each of these separately disturbance_type_loop: do i_disturbance_type = 1,N_DIST_TYPES + ! the next loop level is to go through patches that have a specific land-use type. the reason to do this is because the combination of + ! disturbance type and donor land-use type uniquly define the land-use type of the receiver patch. landuse_donortype_loop: do i_donorpatch_landuse_type = 1, n_landuse_cats + ! figure out what land use label(s) the receiver patch for disturbance from patches with - ! this disturbance label and disturbance of this type will have, and set receiver label loop bounds accordingly - if ( i_disturbance_type .eq. dtype_ilog) then + ! this disturbance label and disturbance of this type will have, and set receiver label loop bounds accordingly. + + ! for fire and treefall disturbance, receiver land-use type is whatever the donor land-use type is. + ! for logging disturbance, receiver land-use type is always secondary lands + ! for land-use-change disturbance, we need to loop over all possible transition types for land-use-change from the current land-use type. + + select case(i_disturbance_type) + case(dtype_ifire) + start_receiver_lulabel = i_donorpatch_landuse_type + end_receiver_lulabel = i_donorpatch_landuse_type + case(dtype_ifall) + start_receiver_lulabel = i_donorpatch_landuse_type + end_receiver_lulabel = i_donorpatch_landuse_type + case(dtype_ilog) start_receiver_lulabel = secondaryland end_receiver_lulabel = secondaryland - else if ( i_disturbance_type .eq. dtype_ilandusechange) then + case(dtype_ilandusechange) start_receiver_lulabel = 1 ! this could actually maybe be 2, as primaryland column of matrix should all be zeros, but leave as 1 for now end_receiver_lulabel = n_landuse_cats - else - start_receiver_lulabel = i_donorpatch_landuse_type - end_receiver_lulabel = i_donorpatch_landuse_type - endif - + case default + write(fates_log(),*) 'unknown disturbance mode?' + write(fates_log(),*) 'i_disturbance_type: ',i_disturbance_type + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + ! next loop level is the set of possible receiver patch land use types. + ! for disturbance types other than land use change, this is sort of a dummy loop, per the above logic. landusechange_receiverpatchlabel_loop: do i_landusechange_receiverpatchlabel = start_receiver_lulabel, end_receiver_lulabel - ! calculate area of disturbed land, in this timestep, by summing contributions from each existing patch. + ! now we want to begin resolving all of the disturbance given the above categorical criteria of: + ! nocomp-PFT, disturbance type, donor patch land use label, and receiver patch land use label. All of the disturbed area that meets these + ! criteria (if any) will be put into a new patch whose area and properties are taken from one or more donor patches. + + ! calculate area of disturbed land that meets the above criteria, in this timestep, by summing contributions from each existing patch. currentPatch => currentSite%youngest_patch + ! this variable site_areadis holds all the newly disturbed area from all patches for all disturbance being resolved now. site_areadis = 0.0_r8 + ! loop over all patches to figure out the total patch area generated as a result of all disturbance being resolved now. patchloop_areadis: do while(associated(currentPatch)) cp_nocomp_matches_1_if: if ( hlm_use_nocomp .eq. ifalse .or. & @@ -593,10 +620,12 @@ subroutine spawn_patches( currentSite, bc_in) endif - ! loop round all the patches that contribute surviving indivduals and litter + ! we now have a new patch and know its area, but it is otherwise empty. Next, we + ! loop round all the patches that contribute surviving individuals and litter ! pools to the new patch. We only loop the pre-existing patches, so - ! quit the loop if the current patch is either null, or matches the - ! two new pointers. + ! quit the loop if the current patch is null, and ignore the patch if the patch's categorical variables do not + ! match those of the outermost set of loops (i.e. the patch's land-use label or nocomp-PFT label + ! are not what we are resolving right now). currentPatch => currentSite%oldest_patch patchloop: do while(associated(currentPatch)) @@ -607,7 +636,7 @@ subroutine spawn_patches( currentSite, bc_in) patchlabel_matches_lutype_if: if (currentPatch%land_use_label .eq. i_donorpatch_landuse_type) then - ! This is the amount of patch area that is disturbed, and donated by the donor + ! disturbance_rate is the fraction of the patch's area that is disturbed and donated disturbance_rate = 0.0_r8 if ( i_disturbance_type .ne. dtype_ilandusechange) then disturbance_rate = currentPatch%disturbance_rates(i_disturbance_type) @@ -615,6 +644,7 @@ subroutine spawn_patches( currentSite, bc_in) disturbance_rate = currentPatch%landuse_transition_rates(i_landusechange_receiverpatchlabel) endif + ! patch_site_areadis is the absolute amount of the patch's area that is disturbed and donated patch_site_areadis = currentPatch%area * disturbance_rate areadis_gt_zero_if: if ( patch_site_areadis > nearzero ) then @@ -625,9 +655,9 @@ subroutine spawn_patches( currentSite, bc_in) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - ! for the case where the donating patch is not primary, if + ! for the case where the donating patch is not primary, and ! the current disturbance from this patch is non-anthropogenic, - ! we need to average in the time-since-anthropogenic-disturbance + ! then we need to average in the time-since-anthropogenic-disturbance ! from the donor patch into that of the receiver patch if ( currentPatch%land_use_label .gt. primaryland .and. & (i_disturbance_type .lt. dtype_ilog) ) then @@ -650,8 +680,6 @@ subroutine spawn_patches( currentSite, bc_in) ! Transfer in litter fluxes from plants in various contexts of death and destruction - ! CDK what do we do here for land use transitions? - select case(i_disturbance_type) case (dtype_ilog) call logging_litter_fluxes(currentSite, currentPatch, & @@ -698,11 +726,11 @@ subroutine spawn_patches( currentSite, bc_in) ! some litter from dead plants and pre-existing litter from the donor patches. ! ! Next, we loop through the cohorts in the donor patch, copy them with - ! area modified number density into the new-patch, and apply survivorship. + ! area modified number density into the new patch, and apply survivorship. ! ------------------------------------------------------------------------- currentCohort => currentPatch%shortest - do while(associated(currentCohort)) + cohortloop: do while(associated(currentCohort)) allocate(nc) if(hlm_use_planthydro.eq.itrue) call InitHydrCohort(CurrentSite,nc) @@ -736,8 +764,11 @@ subroutine spawn_patches( currentSite, bc_in) store_c = currentCohort%prt%GetState(store_organ, carbon12_element) total_c = sapw_c + struct_c + leaf_c + fnrt_c + store_c + ! survivorship of plants in both the disturbed and undisturbed cohorts depends on what type of disturbance is happening. + disttype_case: select case(i_disturbance_type) - ! treefall mortality is the current disturbance + + ! treefall mortality is the current disturbance case (dtype_ifall) in_canopy_if_falldtype: if(currentCohort%canopy_layer == 1)then @@ -766,7 +797,7 @@ subroutine spawn_patches( currentSite, bc_in) nc%l_degrad = nan else - ! small trees + ! understory trees woody_if_falldtype: if( prt_params%woody(currentCohort%pft) == itrue)then @@ -859,7 +890,7 @@ subroutine spawn_patches( currentSite, bc_in) endif woody_if_falldtype endif in_canopy_if_falldtype - ! Fire is the current disturbance + ! Fire is the current disturbance case (dtype_ifire) ! Number of members in the new patch, before we impose fire survivorship @@ -884,6 +915,7 @@ subroutine spawn_patches( currentSite, bc_in) total_c * g_per_kg * days_per_sec * ha_per_m2 else + ! understory currentSite%fmort_rate_ustory(currentCohort%size_class, currentCohort%pft) = & currentSite%fmort_rate_ustory(currentCohort%size_class, currentCohort%pft) + & nc%n * currentCohort%fire_mort / hlm_freq_day @@ -988,7 +1020,7 @@ subroutine spawn_patches( currentSite, bc_in) - ! Logging is the current disturbance + ! Logging is the current disturbance case (dtype_ilog) ! If this cohort is in the upper canopy. It generated @@ -1115,7 +1147,7 @@ subroutine spawn_patches( currentSite, bc_in) endif in_canopy_if_logdtype ! Select canopy layer - + ! Land use change is the current disturbance type case (dtype_ilandusechange) ! Number of members in the new patch, before we impose LUC survivorship @@ -1136,6 +1168,8 @@ subroutine spawn_patches( currentSite, bc_in) call endrun(msg=errMsg(sourcefile, __LINE__)) end select disttype_case ! Select disturbance mode + ! if some plants in the new temporary cohort survived the transfer to the new patch, + ! then put the cohort into the linked list. cohort_n_gt_zero: if (nc%n > 0.0_r8) then storebigcohort => newPatch%tallest storesmallcohort => newPatch%shortest @@ -1160,9 +1194,9 @@ subroutine spawn_patches( currentSite, bc_in) newPatch%tallest => storebigcohort newPatch%shortest => storesmallcohort - else - ! Get rid of the new temporary cohort + else + ! sadly, no plants in the cohort survived. on the bright side, we can deallocate their memory. call nc%FreeMemory() deallocate(nc, stat=istat, errmsg=smsg) if (istat/=0) then @@ -1172,7 +1206,8 @@ subroutine spawn_patches( currentSite, bc_in) endif cohort_n_gt_zero currentCohort => currentCohort%taller - enddo ! currentCohort + enddo cohortloop + call sort_cohorts(currentPatch) !update area of donor patch From 853efcfc2b18fd42f3f0c721c54d67304450cf9c Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Thu, 5 Oct 2023 13:15:42 -0700 Subject: [PATCH 124/250] added restart capability for site-level disturbance rate diagnostic --- main/FatesRestartInterfaceMod.F90 | 38 ++++++++++++++++++++++++++++++- 1 file changed, 37 insertions(+), 1 deletion(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index ecdf13139b..ca3bc1ba21 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -47,6 +47,8 @@ module FatesRestartInterfaceMod use FatesRunningMeanMod, only : rmean_type use FatesRunningMeanMod, only : ema_lpa use EDParamsMod, only : regeneration_model + use FatesConstantsMod, only : n_landuse_cats + use FatesConstantsMod, only : N_DIST_TYPES ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg @@ -249,6 +251,8 @@ module FatesRestartInterfaceMod integer :: ir_abg_imort_flux_siscpf integer :: ir_abg_fmort_flux_siscpf + integer :: ir_disturbance_rates_siluludi + integer :: ir_cwdagin_flxdg integer :: ir_cwdbgin_flxdg integer :: ir_leaflittin_flxdg @@ -1468,6 +1472,10 @@ subroutine define_restart_vars(this, initialize_variables) long_name='24-hour patch veg temp', & units='K', initialize=initialize_variables,ivar=ivar, index = ir_tveg24_pa) + call this%DefineRMeanRestartVar(vname='fates_disturbance_rates',vtype=cohort_r8, & + long_name='disturbance rates by donor land-use type, receiver land-use type, and disturbance type', & + units='1/day', initialize=initialize_variables,ivar=ivar, index = ir_disturbance_rates_siluludi) + if ( regeneration_model == TRS_regeneration ) then call this%DefineRMeanRestartVar(vname='fates_seedling_layer_par24',vtype=cohort_r8, & @@ -1948,6 +1956,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) integer :: io_idx_si_pft ! each site-pft index integer :: io_idx_si_vtmem ! indices for veg-temp memory at site integer :: io_idx_pa_ncl ! each canopy layer within each patch + integer :: io_idx_si_luludi ! site-level lu x lu x ndist index ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) @@ -1970,6 +1979,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) integer :: i_cdam ! loop counter for damage integer :: icdi ! loop counter for damage integer :: icdj ! loop counter for damage + integer :: i_lu_donor, i_lu_receiver, i_dist ! loop counters for land use and disturbance type(fates_restart_variable_type) :: rvar type(fates_patch_type),pointer :: cpatch @@ -2078,6 +2088,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_abg_imort_flux_siscpf => this%rvars(ir_abg_imort_flux_siscpf)%r81d, & rio_abg_fmort_flux_siscpf => this%rvars(ir_abg_fmort_flux_siscpf)%r81d, & rio_abg_term_flux_siscpf => this%rvars(ir_abg_term_flux_siscpf)%r81d, & + rio_disturbance_rates_siluludi => this%rvars(ir_disturbance_rates_siluludi)%r81d, & rio_imortrate_sicdpf => this%rvars(ir_imortrate_sicdpf)%r81d, & rio_imortcflux_sicdsc => this%rvars(ir_imortcflux_sicdsc)%r81d, & @@ -2127,6 +2138,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_cdpf = io_idx_co_1st io_idx_si_scpf = io_idx_co_1st io_idx_si_pft = io_idx_co_1st + io_idx_si_luludi = io_idx_co_1st ! recruitment rate do i_pft = 1,numpft @@ -2173,6 +2185,16 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_pft = io_idx_si_pft + 1 end do + ! site-level disturbance rate diagnostic + do i_lu_donor = 1, n_landuse_cats + do i_lu_receiver = 1, n_landuse_cats + do i_dist = 1, n_dist_types + rio_disturbance_rates_siluludi(io_idx_si_luludi) = sites(s)%disturbance_rates(i_dist,i_lu_donor, i_lu_receiver) + io_idx_si_luludi = io_idx_si_luludi + 1 + end do + end do + end do + if(hlm_use_sp.eq.ifalse)then do el = 1, num_elements @@ -2894,6 +2916,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) integer :: io_idx_si_cdpf ! damage x size x pft within site integer :: io_idx_pa_ncl ! each canopy layer within each patch + integer :: io_idx_si_luludi ! site-level lu x lu x ndist index ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) @@ -2913,6 +2936,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) integer :: i_cdam ! loop counter for damage class integer :: icdj ! loop counter for damage class integer :: icdi ! loop counter for damage class + integer :: i_lu_donor, i_lu_receiver, i_dist ! loop counters for land use and disturbance associate( rio_npatch_si => this%rvars(ir_npatch_si)%int1d, & rio_cd_status_si => this%rvars(ir_cd_status_si)%int1d, & @@ -2995,6 +3019,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_imortrate_siscpf => this%rvars(ir_imortrate_siscpf)%r81d, & rio_fmortrate_crown_siscpf => this%rvars(ir_fmortrate_crown_siscpf)%r81d, & rio_fmortrate_cambi_siscpf => this%rvars(ir_fmortrate_cambi_siscpf)%r81d, & + rio_disturbance_rates_siluludi => this%rvars(ir_disturbance_rates_siluludi)%r81d, & rio_termnindiv_cano_siscpf => this%rvars(ir_termnindiv_cano_siscpf)%r81d, & rio_termnindiv_usto_siscpf => this%rvars(ir_termnindiv_usto_siscpf)%r81d, & rio_growflx_fusion_siscpf => this%rvars(ir_growflx_fusion_siscpf)%r81d, & @@ -3055,7 +3080,8 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_cdpf = io_idx_co_1st io_idx_si_scpf = io_idx_co_1st io_idx_si_pft = io_idx_co_1st - + io_idx_si_luludi = io_idx_co_1st + ! read seed_bank info(site-level, but PFT-resolved) do i_pft = 1,numpft sites(s)%recruitment_rate(i_pft) = rio_recrate_sift(io_idx_co_1st+i_pft-1) @@ -3108,6 +3134,16 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_pft = io_idx_si_pft + 1 end do + ! site-level disturbance rate diagnostic + do i_lu_donor = 1, n_landuse_cats + do i_lu_receiver = 1, n_landuse_cats + do i_dist = 1, n_dist_types + sites(s)%disturbance_rates(i_dist,i_lu_donor, i_lu_receiver) = rio_disturbance_rates_siluludi(io_idx_si_luludi) + io_idx_si_luludi = io_idx_si_luludi + 1 + end do + end do + end do + ! Mass balance and diagnostics across elements at the site level if(hlm_use_sp.eq.ifalse)then do el = 1, num_elements From 26d6a9fd826c0d504702aba70c6c2c718dc1dc36 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Thu, 5 Oct 2023 14:15:07 -0700 Subject: [PATCH 125/250] reset n_dist_types back to 4 --- main/FatesConstantsMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 71710b1979..6f67545714 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -41,11 +41,11 @@ module FatesConstantsMod (/0._fates_r8, 5._fates_r8, 20._fates_r8, 50._fates_r8, 100._fates_r8, 150._fates_r8/) ! array of bin lower edges for comparing patches - integer , parameter, public :: N_DIST_TYPES = 3 ! Disturbance Modes 1) tree-fall, 2) fire, 3) logging + integer , parameter, public :: N_DIST_TYPES = 4 ! Disturbance Modes 1) tree-fall, 2) fire, 3) logging, 4) land-use change integer , parameter, public :: dtype_ifall = 1 ! index for naturally occuring tree-fall generated event integer , parameter, public :: dtype_ifire = 2 ! index for fire generated disturbance event integer , parameter, public :: dtype_ilog = 3 ! index for logging generated disturbance event - integer , parameter, public :: dtype_ilandusechange = 4 ! index for land use change disturbance (not including logging) + integer , parameter, public :: dtype_ilandusechange = 4 ! index for land use change disturbance (not including logging) ! Labels for patch disturbance history integer, parameter, public :: n_landuse_cats = 5 From 12132bdab2082fb3faec4eafb0969666b54df64a Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Thu, 5 Oct 2023 14:49:14 -0700 Subject: [PATCH 126/250] various fixes per review comments --- biogeochem/EDPatchDynamicsMod.F90 | 8 +++-- biogeochem/FatesLandUseChangeMod.F90 | 50 +++++++++++++--------------- main/FatesInterfaceMod.F90 | 8 ++--- 3 files changed, 33 insertions(+), 33 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 56ee469253..bfb886c5a6 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -270,7 +270,11 @@ subroutine disturbance_rates( site_in, bc_in) call get_harvest_debt(site_in, bc_in, harvest_tag) - call get_landuse_transition_rates(bc_in, landuse_transition_matrix) + if ( hlm_use_luh .eq. itrue ) then + call get_landuse_transition_rates(bc_in, landuse_transition_matrix) + else + landuse_transition_matrix(:) = 0._r8 + endif ! calculate total area in each landuse category current_fates_landuse_state_vector(:) = 0._r8 @@ -445,8 +449,6 @@ subroutine spawn_patches( currentSite, bc_in) ! ! !LOCAL VARIABLES: type (fates_patch_type) , pointer :: newPatch - ! type (fates_patch_type) , pointer :: new_patch_primary - ! type (fates_patch_type) , pointer :: new_patch_secondary type (fates_patch_type) , pointer :: currentPatch type (fates_cohort_type), pointer :: currentCohort type (fates_cohort_type), pointer :: nc diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index a92eebcb8f..adb92bcebc 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -83,38 +83,36 @@ subroutine get_landuse_transition_rates(bc_in, landuse_transition_matrix) landuse_transition_matrix(:,:) = 0._r8 urban_fraction = 0._r8 - use_luh_if: if ( hlm_use_luh .eq. itrue ) then - - ! Check the LUH data incoming to see if any of the transitions are NaN - temp_vector = bc_in%hlm_luh_transitions - call CheckLUHData(temp_vector,modified_flag) - if (.not. modified_flag) then - ! identify urban fraction so that it can be factored into the land use state output - urban_fraction = bc_in%hlm_luh_states(findloc(bc_in%hlm_luh_state_names,'urban',dim=1)) - end if + ! Check the LUH data incoming to see if any of the transitions are NaN + temp_vector = bc_in%hlm_luh_transitions + call CheckLUHData(temp_vector,modified_flag) + if (.not. modified_flag) then + ! identify urban fraction so that it can be factored into the land use state output + urban_fraction = bc_in%hlm_luh_states(findloc(bc_in%hlm_luh_state_names,'urban',dim=1)) + end if - !!TODO: may need some logic here to ask whether or not ot perform land use change on this timestep. current code occurs every day. - !!If not doing transition every day, need to update units. + !!TODO: may need some logic here to ask whether or not ot perform land use change on this timestep. current code occurs every day. + !!If not doing transition every day, need to update units. - transitions_loop: do i_luh2_transitions = 1, hlm_num_luh2_transitions + transitions_loop: do i_luh2_transitions = 1, hlm_num_luh2_transitions - ! transition names are written in form xxxxx_to_yyyyy where x and y are donor and receiver state names - transition_name = bc_in%hlm_luh_transition_names(i_luh2_transitions) - donor_name = transition_name(1:5) - receiver_name = transition_name(10:14) + ! transition names are written in form xxxxx_to_yyyyy where x and y are donor and receiver state names + transition_name = bc_in%hlm_luh_transition_names(i_luh2_transitions) + donor_name = transition_name(1:5) + receiver_name = transition_name(10:14) - ! Get the fates land use type index associated with the luh2 state types - i_donor= lumap%GetIndex(donor_name) - i_receiver = lumap%GetIndex(receiver_name) + ! Get the fates land use type index associated with the luh2 state types + i_donor= lumap%GetIndex(donor_name) + i_receiver = lumap%GetIndex(receiver_name) - ! Avoid transitions with 'urban' as those are handled seperately - if (.not.(i_donor .eq. fates_unset_int .or. i_receiver .eq. fates_unset_int)) then - landuse_transition_matrix(i_donor,i_receiver) = & - landuse_transition_matrix(i_donor,i_receiver) + temp_vector(i_luh2_transitions) * years_per_day / (1._r8 - urban_fraction) + ! Avoid transitions with 'urban' as those are handled seperately + if (.not.(i_donor .eq. fates_unset_int .or. i_receiver .eq. fates_unset_int)) then + landuse_transition_matrix(i_donor,i_receiver) = & + landuse_transition_matrix(i_donor,i_receiver) + temp_vector(i_luh2_transitions) * years_per_day / (1._r8 - urban_fraction) + + end if + end do transitions_loop - end if - end do transitions_loop - end if use_luh_if end subroutine get_landuse_transition_rates !---------------------------------------------------------------------------------------------------- diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index c5839d1412..554425eac0 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -398,9 +398,9 @@ subroutine zero_bcs(fates,s) fates%bc_out(s)%hrv_deadstemc_to_prod10c = 0.0_r8 fates%bc_out(s)%hrv_deadstemc_to_prod100c = 0.0_r8 - if (hlm_use_luh .gt. 0) then - fates%bc_in(s)%hlm_luh_states = 0.0_r8 - fates%bc_in(s)%hlm_luh_transitions = 0.0_r8 + if (hlm_use_luh .eq. itrue) then + fates%bc_in(s)%hlm_luh_states(:) = 0.0_r8 + fates%bc_in(s)%hlm_luh_transitions(:) = 0.0_r8 end if return @@ -558,7 +558,7 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats, allocate(bc_in%pft_areafrac(natpft_lb:natpft_ub)) ! LUH2 state and transition data - if (hlm_use_luh .gt. 0) then + if (hlm_use_luh .eq. itrue) then allocate(bc_in%hlm_luh_states(num_luh2_states)) allocate(bc_in%hlm_luh_state_names(num_luh2_states)) allocate(bc_in%hlm_luh_transitions(num_luh2_transitions)) From 3fc589e54f601845ed05174b2a23efa4859fcc6b Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 6 Oct 2023 09:40:07 -0700 Subject: [PATCH 127/250] minor build fix --- biogeochem/EDPatchDynamicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index bfb886c5a6..3e045f2ab8 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -273,7 +273,7 @@ subroutine disturbance_rates( site_in, bc_in) if ( hlm_use_luh .eq. itrue ) then call get_landuse_transition_rates(bc_in, landuse_transition_matrix) else - landuse_transition_matrix(:) = 0._r8 + landuse_transition_matrix(:,:) = 0._r8 endif ! calculate total area in each landuse category From 2ae2f91f5972645462d481cf9684bb1f7b823f88 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 6 Oct 2023 10:34:13 -0700 Subject: [PATCH 128/250] manually revert back to previous terminate patches subroutine method --- biogeochem/EDPatchDynamicsMod.F90 | 76 ++++++------------------------- 1 file changed, 15 insertions(+), 61 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 3e045f2ab8..cf0191d032 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2904,8 +2904,7 @@ subroutine terminate_patches(currentSite) ! Start at the youngest patch in the list and assume that the largest patch is this patch currentPatch => currentSite%youngest_patch - largestPatch => currentPatch - do while(associated(currentPatch)) + do while(associated(currentPatch)) lessthan_min_patcharea_if: if(currentPatch%area <= min_patch_area)then ! Initialize gotfused flag for both nocomp and all other cases @@ -2936,30 +2935,12 @@ subroutine terminate_patches(currentSite) else nocomp_if - ! Check to see if the current patch is the largest patch so far and update if it is - if (currentPatch%area .gt. largestPatch%area) largestPatch => currentPatch - - ! Determine if the current patch is the youngest in the land use grouping - ! If the 'younger' patch has a different landuse label then the current is the youngest - ! per the InsertPatch subroutine. That said it could also be the only patch and - ! also the oldest. Should we handle that distinction? - current_patch_is_youngest_lutype = .false. - - ! Check if the current patch is already the youngest patch on the site - if (associated(currentPatch,currentSite%youngest_patch)) then - current_patch_is_youngest_lutype = .true. - else - ! Otherwise check to see if the younger patch is a different landuse label - if (currentPatch%younger%land_use_label .ne. currentPatch%land_use_label) then - current_patch_is_youngest_lutype = .true. - end if - end if - ! Even if the patch area is small, avoid fusing it into its neighbor ! if it is the youngest of all patches. We do this in attempts to maintain ! a discrete patch for very young patches. ! However, if the patch to be fused is excessively small, then fuse at all costs. - notyoungest_if: if ( .not. current_patch_is_youngest_lutype .or. currentPatch%area <= min_patch_area_forced ) then + notyoungest_if: if ( .not.associated(currentPatch,currentSite%youngest_patch) .or. & + currentPatch%area <= min_patch_area_forced ) then ! Determine if there is an older patch available associated_older_if: if(associated(currentPatch%older)) then @@ -2978,34 +2959,22 @@ subroutine terminate_patches(currentSite) write(fates_log(),*) 'terminate: fused to older patch, same label: ', currentPatch%land_use_label, olderPatch%land_use_label call fuse_2_patches(currentSite, olderPatch, currentPatch) - gotfused = .true. - - else distlabel_1_if - - ! If we're having an incredibly hard time fusing patches because of their differing - ! landuse labels (i.e. the count_cycles is more than zero), then fuse the current - ! patch with the largest patch regardless of landuse label. - countcycles_if: if (count_cycles .gt. 0) then - - ! Work through the rest of the list to find the largest patch - do while (associated(olderPatch)) - if (olderPatch%area .gt. largestPatch%area) largestPatch => olderPatch - olderPatch => olderPatch%older - end do - if(debug) & - write(fates_log(),*) 'terminate: fuse to largest patch, diff label: ', currentPatch%land_use_label, largestPatch%land_use_label + ! The fusion process has updated the "older" pointer on currentPatch + ! for us. - ! Set the donor patch label to match the reciever patch label to avoid an error - ! due to a label check inside fuse_2_patches - currentPatch%land_use_label = largestPatch%land_use_label + ! This logic checks to make sure that the younger patch is not the youngest + ! patch. As mentioned earlier, we try not to fuse it. + gotfused = .true. - ! We also assign the age since disturbance value to be the younger (donor) patch to avoid combining a valid - ! age with fates_unset_r8 (i.e. the age for primaryland) in the fuse_2_patches procedure - currentPatch%age_since_anthro_disturbance = largestPatch%age_since_anthro_disturbance + else distlabel_1_if !i.e. anthro labels of two patches are not the same + countcycles_if: if (count_cycles .gt. 0) then + ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, + ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its older sibling + ! and then allow them to fuse together. + currentPatch%anthro_disturbance_label = olderPatch%anthro_disturbance_label call fuse_2_patches(currentSite, currentPatch, largestPatch) gotfused = .true. - endif countcycles_if endif distlabel_1_if endif associated_older_if @@ -3020,9 +2989,6 @@ subroutine terminate_patches(currentSite) distlabel_2_if: if (currentPatch%land_use_label .eq. youngerPatch% land_use_label) then - if(debug) & - write(fates_log(),*) 'terminate: fused to younger patch, same label: ', currentPatch%land_use_label, youngerPatch%land_use_label - call fuse_2_patches(currentSite, youngerPatch, currentPatch) ! The fusion process has updated the "younger" pointer on currentPatch @@ -3032,21 +2998,9 @@ subroutine terminate_patches(currentSite) if (count_cycles .gt. 0) then ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its younger sibling - ! Note that given the grouping of landuse types in the linked list, this could result in very small patches - ! being fused to much larger patches - if(debug) & - write(fates_log(),*) 'terminate: fuse to largest patch, diff label: ', currentPatch%land_use_label, largestPatch%land_use_label - - ! Set the donor patch label to match the reciever patch label to avoid an error - ! due to a label check inside fuse_2_patches - currentPatch%land_use_label = largestPatch%land_use_label - - ! We also assigned the age since disturbance value to be the younger (donor) patch to avoid combining a valid - ! age with fates_unset_r8 (i.e. the age for primaryland) in the fuse_2_patches procedure - currentPatch%age_since_anthro_disturbance = largestPatch%age_since_anthro_disturbance + currentPatch%anthro_disturbance_label = youngerPatch%anthro_disturbance_label call fuse_2_patches(currentSite, currentPatch, largestPatch) gotfused = .true. - endif ! count cycles endif distlabel_2_if ! anthro labels endif not_gotfused_if ! has an older patch From bc8fddd0487ebe2184dda804ddb55a52343a3beb Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 6 Oct 2023 10:47:04 -0700 Subject: [PATCH 129/250] minor comment alignments and fixing bad copies --- biogeochem/EDPatchDynamicsMod.F90 | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index cf0191d032..b61925f402 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2907,11 +2907,9 @@ subroutine terminate_patches(currentSite) do while(associated(currentPatch)) lessthan_min_patcharea_if: if(currentPatch%area <= min_patch_area)then - ! Initialize gotfused flag for both nocomp and all other cases - gotfused = .false. - nocomp_if: if (hlm_use_nocomp .eq. itrue) then + gotfused = .false. patchpointer => currentSite%youngest_patch do while(associated(patchpointer)) if ( .not.associated(currentPatch,patchpointer) .and. & @@ -2938,11 +2936,14 @@ subroutine terminate_patches(currentSite) ! Even if the patch area is small, avoid fusing it into its neighbor ! if it is the youngest of all patches. We do this in attempts to maintain ! a discrete patch for very young patches. - ! However, if the patch to be fused is excessively small, then fuse at all costs. + ! However, if the patch to be fused is excessively small, then fuse + ! at all costs. + notyoungest_if: if ( .not.associated(currentPatch,currentSite%youngest_patch) .or. & currentPatch%area <= min_patch_area_forced ) then - ! Determine if there is an older patch available + gotfused = .false. + associated_older_if: if(associated(currentPatch%older)) then if(debug) & @@ -2950,6 +2951,9 @@ subroutine terminate_patches(currentSite) currentPatch%area, & currentPatch%older%area + ! We set a pointer to this patch, because + ! it will be returned by the subroutine as de-referenced + olderPatch => currentPatch%older ! If the older patch has the same landuse label fuse the older (donor) patch into the current patch @@ -2965,14 +2969,14 @@ subroutine terminate_patches(currentSite) ! This logic checks to make sure that the younger patch is not the youngest ! patch. As mentioned earlier, we try not to fuse it. - gotfused = .true. + gotfused = .true. else distlabel_1_if !i.e. anthro labels of two patches are not the same countcycles_if: if (count_cycles .gt. 0) then ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its older sibling ! and then allow them to fuse together. - currentPatch%anthro_disturbance_label = olderPatch%anthro_disturbance_label + currentPatch%land_use_label = olderPatch%land_use_label call fuse_2_patches(currentSite, currentPatch, largestPatch) gotfused = .true. endif countcycles_if @@ -2992,13 +2996,14 @@ subroutine terminate_patches(currentSite) call fuse_2_patches(currentSite, youngerPatch, currentPatch) ! The fusion process has updated the "younger" pointer on currentPatch + gotfused = .true. else distlabel_2_if if (count_cycles .gt. 0) then ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its younger sibling - currentPatch%anthro_disturbance_label = youngerPatch%anthro_disturbance_label + currentPatch%land_use_label = youngerPatch%land_use_label call fuse_2_patches(currentSite, currentPatch, largestPatch) gotfused = .true. endif ! count cycles From 713bbad3364a5455c699860c1a23c9496e90dc91 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 6 Oct 2023 14:24:42 -0400 Subject: [PATCH 130/250] small updates to two-stream unit tests --- .../radiation/RadiationUTestDriver.py | 133 ++++++++---------- radiation/TwoStreamMLPEMod.F90 | 7 +- 2 files changed, 60 insertions(+), 80 deletions(-) diff --git a/functional_unit_testing/radiation/RadiationUTestDriver.py b/functional_unit_testing/radiation/RadiationUTestDriver.py index eb8e409de6..cd0f8ed223 100644 --- a/functional_unit_testing/radiation/RadiationUTestDriver.py +++ b/functional_unit_testing/radiation/RadiationUTestDriver.py @@ -164,10 +164,10 @@ def main(argv): if(False): SunFracTests() - if(True): + if(False): SingleElementPerturbTest() - if(False): + if(True): SerialParallelCanopyTest() plt.show() @@ -225,10 +225,8 @@ def SerialParallelCanopyTest(): iret = alloc_twostream_call(ci(n_layer),ci(n_col)) #class cohort_type: - #def __init__(self,n_vai): - #self.n_vai = n_vai - #self.avai = np.zeros([n_vai]) - + #def __init__(self,n_vai,area_frac,lai,sai,pft) + # Five elements (cohorts), each take up 20% of the space area_frac = 0.2 serialc = [] @@ -244,17 +242,17 @@ def SerialParallelCanopyTest(): parallelc.append(cohort_type(100,area_frac,cohort_lai[2],cohort_lai[2]*sai_frac,pft)) parallelc.append(cohort_type(100,area_frac,cohort_lai[3],cohort_lai[3]*sai_frac,pft)) parallelc.append(cohort_type(100,area_frac,cohort_lai[4],cohort_lai[4]*sai_frac,pft)) + + # Setup serial canopy "s_elems" - elems = [] - elems.append([]) - elems.append([]) + s_elems = [] + s_elems.append([]) + s_elems.append([]) n_vai = 100 dvai = 0.05 - for i in range(n_layer): ican = i+1 - icol = 1 area = np.sum(cohort_area[i:]) if(i==0): @@ -265,21 +263,20 @@ def SerialParallelCanopyTest(): sai = lai*sai_frac n_vai = int((lai+sai)/dvai) - elems[0].append(elem_type(n_vai)) + s_elems[0].append(elem_type(n_vai)) - - elems[0][-1].lai = lai - elems[0][-1].sai = sai - elems[0][-1].area = area - elems[0][-1].avai = np.linspace(0,lai+sai,num=n_vai) + s_elems[0][-1].lai = lai + s_elems[0][-1].sai = sai + s_elems[0][-1].area = area + s_elems[0][-1].avai = np.linspace(0,lai+sai,num=n_vai) iret = setup_canopy_call(c_int(ican),c_int(icol),c_int(pft),c_double(area),c_double(lai),c_double(sai)) icol = 2 area = 1-np.sum(cohort_area[i:]) - elems[1].append(elem_type(1)) - elems[1][-1].lai = 0.0 - elems[1][-1].sai = 0.0 - elems[1][-1].area = area + s_elems[1].append(elem_type(1)) + s_elems[1][-1].lai = 0.0 + s_elems[1][-1].sai = 0.0 + s_elems[1][-1].area = area lai = 0.0 sai = 0.0 air_pft = 0 @@ -311,8 +308,8 @@ def SerialParallelCanopyTest(): cd_ffdiff_diff = c_double(-9.0) - R_beam = 100. - R_diff = 100. + R_beam = 1. + R_diff = 1. cosz = np.cos(0.0) ground_albedo_diff = 0.3 @@ -323,43 +320,37 @@ def SerialParallelCanopyTest(): iret = grndsnow_albedo_call(c_int(visb),c_double(ground_albedo_beam),*ccharnb('albedo_grnd_beam')) iret = grndsnow_albedo_call(c_int(nirb),c_double(ground_albedo_diff),*ccharnb('albedo_grnd_diff')) iret = grndsnow_albedo_call(c_int(nirb),c_double(ground_albedo_beam),*ccharnb('albedo_grnd_beam')) - iret = canopy_prep_call(c8(frac_snow)) iret = zenith_prep_call(c8(cosz)) - - - iret = solver_call(ci(ib),ci(normalized_boundary),c8(1.0),c8(1.0), \ byref(cd_albedo_beam),byref(cd_albedo_diff), \ byref(cd_canabs_beam),byref(cd_canabs_diff), \ byref(cd_ffbeam_beam),byref(cd_ffdiff_beam),byref(cd_ffdiff_diff)) - iret = setdown_call(ci(ib),c8(R_beam),c8(R_diff)) - for i in range(n_layer): ican = i+1 icol = 1 - for iv in range(elems[0][i].n_vai): - iret = getintens_call(ci(ican),ci(icol),ci(ib),c8(elems[0][i].avai[iv]),byref(cd_r_diff_dn),byref(cd_r_diff_up),byref(cd_r_beam)) - elems[0][i].r_dn[iv] = cd_r_diff_dn.value - elems[0][i].r_up[iv] = cd_r_diff_up.value - elems[0][i].r_b[iv] = cd_r_beam.value + for iv in range(s_elems[0][i].n_vai): + iret = getintens_call(ci(ican),ci(icol),ci(ib),c8(s_elems[0][i].avai[iv]),byref(cd_r_diff_dn),byref(cd_r_diff_up),byref(cd_r_beam)) + s_elems[0][i].r_dn[iv] = cd_r_diff_dn.value + s_elems[0][i].r_up[iv] = cd_r_diff_up.value + s_elems[0][i].r_b[iv] = cd_r_beam.value if(iv>0): - elems[0][i].r_abs[iv-1] = (elems[0][i].r_dn[iv]-elems[0][i].r_dn[iv-1]) + \ - (elems[0][i].r_up[iv-1]-elems[0][i].r_up[iv]) + \ - (elems[0][i].r_b[iv]-elems[0][i].r_b[iv-1]) - - for iv in range(elems[1][i].n_vai): - iret = getintens_call(ci(ican),ci(icol+1),ci(ib),c8(elems[1][i].avai[iv]),byref(cd_r_diff_dn),byref(cd_r_diff_up),byref(cd_r_beam)) - elems[1][i].r_dn[iv] = cd_r_diff_dn.value - elems[1][i].r_up[iv] = cd_r_diff_up.value - elems[1][i].r_b[iv] = cd_r_beam.value + s_elems[0][i].r_abs[iv-1] = (s_elems[0][i].r_dn[iv]-s_elems[0][i].r_dn[iv-1]) + \ + (s_elems[0][i].r_up[iv-1]-s_elems[0][i].r_up[iv]) + \ + (s_elems[0][i].r_b[iv]-s_elems[0][i].r_b[iv-1]) + + for iv in range(s_elems[1][i].n_vai): + iret = getintens_call(ci(ican),ci(icol+1),ci(ib),c8(s_elems[1][i].avai[iv]),byref(cd_r_diff_dn),byref(cd_r_diff_up),byref(cd_r_beam)) + s_elems[1][i].r_dn[iv] = cd_r_diff_dn.value + s_elems[1][i].r_up[iv] = cd_r_diff_up.value + s_elems[1][i].r_b[iv] = cd_r_beam.value if(iv>0): - elems[1][i].r_abs[iv-1] = (elems[1][i].r_dn[iv]-elems[1][i].r_dn[iv-1]) + \ - (elems[1][i].r_up[iv-1]-elems[1][i].r_up[iv]) + \ - (elems[1][i].r_b[iv]-elems[1][i].r_b[iv-1]) + s_elems[1][i].r_abs[iv-1] = (s_elems[1][i].r_dn[iv]-s_elems[1][i].r_dn[iv-1]) + \ + (s_elems[1][i].r_up[iv-1]-s_elems[1][i].r_up[iv]) + \ + (s_elems[1][i].r_b[iv]-s_elems[1][i].r_b[iv-1]) # Lets get the absorbed radiation from the cohorts @@ -420,7 +411,7 @@ def SerialParallelCanopyTest(): maxlai = np.max([maxlai,np.max(serialc[i].avai) ]) max_sunfrac = np.max([max_sunfrac,np.max(serialc[i].sunfrac)]) - fig, axs = plt.subplots(ncols=n_cohorts,nrows=1,figsize=(9,5)) + fig, axs = plt.subplots(ncols=n_cohorts,nrows=1,figsize=(6,3)) ax1s = axs.reshape(-1) y0 = 0.1 @@ -451,7 +442,7 @@ def SerialParallelCanopyTest(): x0 = x0+dx ic=ic+1 - fig, axs = plt.subplots(ncols=n_cohorts,nrows=1,figsize=(9,5)) + fig, axs = plt.subplots(ncols=n_cohorts,nrows=1,figsize=(6,3)) ax1s = axs.reshape(-1) y0 = 0.1 @@ -488,9 +479,9 @@ def SerialParallelCanopyTest(): if(True): - PlotRadMaps(elems,0,'Beam Radiation [W/m2]') - PlotRadMaps(elems,1,'Downwelling Diffuse Radiation [W/m2]') - PlotRadMaps(elems,2,'Upwelling Diffuse Radiation [W/m2]') + PlotRadMaps(s_elems,0,'Beam Radiation [W/m2]') + PlotRadMaps(s_elems,1,'Downwelling Diffuse Radiation [W/m2]') + PlotRadMaps(s_elems,2,'Upwelling Diffuse Radiation [W/m2]') def SunFracTests(): @@ -791,8 +782,8 @@ def SingleElementPerturbTest(): pp_dict['betab'] = 1.5*0.48253004714288084 #*1.5 pp_dict['betad'] = 1.5*0.5999777777777778 #*1.5 - R_beam = 0.5 - R_diff = 0.5 + R_beam = 1.0 + R_diff = 1.0 cosz = np.cos(0.0) n_vai = 100 vai_a = np.linspace(0,vai,num=n_vai) @@ -888,7 +879,7 @@ def SingleElementPerturbTest(): p_drdv_diff_up[iv-1] = (p_r_diff_up[iv]-p_r_diff_up[iv-1])/dv - fig1, ((ax1,ax2),(ax3,ax4)) = plt.subplots(2,2,figsize=(7.5,6.5)) + fig1, ((ax1,ax2),(ax3,ax4)) = plt.subplots(2,2,figsize=(6.5,5.5)) ap = ax1.plot(r_beam,vai_a,p_r_beam[:,i],vai_a) first_color = ap[0].get_color() @@ -927,20 +918,17 @@ def SingleElementPerturbTest(): param_str = r"""In-element Scattering Profiles - Broad band: {0} -$R_{{b,atm}} = ${1:.0f} -$R_{{d,atm}} = ${2:.0f} -$cos(\phi) = ${3:.2f} -$K_b = ${4:.2f} -$K_d = ${5:.2f} -$\omega = ${6:.2f} -$\beta_b = ${7:.2f} -$\beta_d = ${8:.2f} -$\alpha_{{gd}} = ${9:.2f} -$\alpha_{{gb}} = ${9:.2f}""".format(band_name,R_beam,R_diff,cosz,cd_kb.value,cd_kd.value,cd_om.value,cd_betab.value,cd_betad.value,ground_albedo_diff,ground_albedo_beam) +$cos(\phi) = ${1:.2f} +$K_b = ${2:.2f} +$K_d = ${3:.2f} +$\omega = ${4:.2f} +$\beta_b = ${5:.2f} +$\beta_d = ${6:.2f} +$\alpha_{{gd}} = ${7:.2f} +$\alpha_{{gb}} = ${8:.2f}""".format(band_name,cosz,cd_kb.value,cd_kd.value,cd_om.value,cd_betab.value,cd_betad.value,ground_albedo_diff,ground_albedo_beam) ax4.text(0.1, 0.5, param_str, horizontalalignment='left', \ - verticalalignment='center', transform=ax4.transAxes,backgroundcolor=[1.0,1.0,1.0],fontsize=12,color=first_color) + verticalalignment='center', transform=ax4.transAxes,backgroundcolor=[1.0,1.0,1.0],fontsize=11,color=first_color) ax4.text(0.5,0.5,r"{0}={1:.2f}".format(key,val),color=last_color) plt.subplots_adjust(wspace=0.1, hspace=0.25) plt.tight_layout() @@ -955,13 +943,10 @@ def SingleElementPerturbTest(): def PlotRadMaps(elems,rtype,plt_title): - fig, ax = plt.subplots(ncols=1,nrows=1,figsize=(8,8)) + fig, ax = plt.subplots(ncols=1,nrows=1,figsize=(5,5)) cmap = mpl.cm.Reds - - #code.interact(local=dict(globals(), **locals())) n_layer = len(elems[0]) - total_vai = 0 for i in range(n_layer): total_vai = total_vai + \ @@ -975,18 +960,14 @@ def PlotRadMaps(elems,rtype,plt_title): for i in range(n_layer): # Vegetated - for iv in range(elems[0][i].n_vai-1): - #rel_intense = np.max([0,np.min([1.,elems[0][i].r_dn[iv]/R_diff])]) - #rel_intense = np.max([0,np.min([R_diff,elems[0][i].r_dn[iv]])]) if(rtype==0): rel_intense = np.max([0,elems[0][i].r_b[iv]]) elif(rtype==1): rel_intense = np.max([0,elems[0][i].r_dn[iv]]) elif(rtype==2): rel_intense = np.max([0,elems[0][i].r_up[iv]]) - - + dvai = elems[0][i].avai[iv+1]-elems[0][i].avai[iv] rect.append(mpl.patches.Rectangle((0,(elems[0][i].avai[iv]+total_vai)),elems[0][i].area,dvai)) #,color = [rel_intense,0.5,0.5])) rcolor.append(rel_intense) @@ -1021,7 +1002,7 @@ def PlotRadMaps(elems,rtype,plt_title): ax.set_xlabel('Ground Area Fraction') ax.set_title(plt_title) #) plt.colorbar(im) - + plt.show() def PlotRadLines(): diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index 094ac1ac9b..a28a28dcbd 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -1078,7 +1078,6 @@ subroutine Solve(this, ib, & real(r8) :: r_abs_stem ! total absorbed by stems (dummy) real(r8) :: r_abs_snow ! total absorbed by snow (dummy) real(r8) :: leaf_sun_frac ! sunlit fraction of leaves (dummy) - real(r8) :: err1,err2 real(r8) :: rel_err ! radiation canopy balance conservation ! error, fraction of incident @@ -1488,13 +1487,13 @@ subroutine Solve(this, ib, & if(debug)then ! Perform a forward check on the solution error do ilem = 1,n_eq - err1 = tau_temp(ilem) - sum(taulamb(1:n_eq)*omega_temp(ilem,1:n_eq)) - if(abs(err1)>rel_err_thresh)then + rel_err = tau_temp(ilem) - sum(taulamb(1:n_eq)*omega_temp(ilem,1:n_eq)) + if(abs(rel_err)>rel_err_thresh)then write(log_unit,*) 'Poor forward solution on two-stream solver' write(log_unit,*) 'isol (1=beam or 2=diff): ',isol write(log_unit,*) 'i (equation): ',ilem write(log_unit,*) 'band index (1=vis,2=nir): ',ib - write(log_unit,*) 'error (tau(i) - omega(i,:)*lambda(:)) ',err1 + write(log_unit,*) 'error (tau(i) - omega(i,:)*lambda(:)) ',rel_err this%band(ib)%Rbeam_atm = 1._r8 this%band(ib)%Rdiff_atm = 1._r8 call this%Dump(ib) From 40d74ad7fe355353e6ae12d9858b4cfd541b3438 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 6 Oct 2023 11:43:47 -0700 Subject: [PATCH 131/250] remove largestpatch missed in manual reversion --- biogeochem/EDPatchDynamicsMod.F90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index b61925f402..b257fc15c0 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2889,7 +2889,6 @@ subroutine terminate_patches(currentSite) type(fates_patch_type), pointer :: olderPatch type(fates_patch_type), pointer :: youngerPatch type(fates_patch_type), pointer :: patchpointer - type(fates_patch_type), pointer :: largestPatch integer, parameter :: max_cycles = 10 ! After 10 loops through ! You should had fused integer :: count_cycles @@ -2977,7 +2976,7 @@ subroutine terminate_patches(currentSite) ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its older sibling ! and then allow them to fuse together. currentPatch%land_use_label = olderPatch%land_use_label - call fuse_2_patches(currentSite, currentPatch, largestPatch) + call fuse_2_patches(currentSite, olderPatch, currentPatch) gotfused = .true. endif countcycles_if endif distlabel_1_if @@ -3004,7 +3003,7 @@ subroutine terminate_patches(currentSite) ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its younger sibling currentPatch%land_use_label = youngerPatch%land_use_label - call fuse_2_patches(currentSite, currentPatch, largestPatch) + call fuse_2_patches(currentSite, youngerPatch, currentPatch) gotfused = .true. endif ! count cycles endif distlabel_2_if ! anthro labels From f47f0092749b58b3d8fbaac7b61dae4fc068a7a6 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 6 Oct 2023 14:30:04 -0700 Subject: [PATCH 132/250] update last ditch fusion to have donor give reciever the same age_since --- biogeochem/EDPatchDynamicsMod.F90 | 15 ++++++++++++++- main/FatesHistoryInterfaceMod.F90 | 4 +--- 2 files changed, 15 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index b257fc15c0..7e311af6ab 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2585,6 +2585,7 @@ subroutine fuse_patches( csite, bc_in ) !-----------------------! tmpptr => currentPatch%older + write(fates_log(),*) 'fusepatches: calling fuse', tpp%land_use_label, currentPatch%land_use_label call fuse_2_patches(csite, currentPatch, tpp) call fuse_cohorts(csite,tpp, bc_in) call sort_cohorts(tpp) @@ -2714,8 +2715,12 @@ subroutine fuse_2_patches(csite, dp, rp) inv_sum_area = 1.0_r8/(dp%area + rp%area) rp%age = (dp%age * dp%area + rp%age * rp%area) * inv_sum_area + write(fates_log(),*) 'fuse2 pre: agesince: rp, dp:', rp%age_since_anthro_disturbance, dp%age_since_anthro_disturbance + write(fates_log(),*) 'fuse2 pre: area: rp, dp:', rp%area, dp%area rp%age_since_anthro_disturbance = (dp%age_since_anthro_disturbance * dp%area & + rp%age_since_anthro_disturbance * rp%area) * inv_sum_area + write(fates_log(),*) 'fuse2 pst: agesince: rp, dp:', rp%age_since_anthro_disturbance, dp%age_since_anthro_disturbance + write(fates_log(),*) 'fuse2 pst: area: rp, dp:', rp%area, dp%area rp%age_class = get_age_class_index(rp%age) @@ -2961,6 +2966,7 @@ subroutine terminate_patches(currentSite) if(debug) & write(fates_log(),*) 'terminate: fused to older patch, same label: ', currentPatch%land_use_label, olderPatch%land_use_label + write(fates_log(),*) 'terminate: distlabel_1: calling fuse: same', olderPatch%land_use_label, currentPatch%land_use_label call fuse_2_patches(currentSite, olderPatch, currentPatch) ! The fusion process has updated the "older" pointer on currentPatch @@ -2975,7 +2981,10 @@ subroutine terminate_patches(currentSite) ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its older sibling ! and then allow them to fuse together. + write(fates_log(),*) 'terminate: distlabel_1: calling fuse: diff', olderPatch%land_use_label, currentPatch%land_use_label + write(fates_log(),*) 'terminate: agesince: rp, dp:', currentPatch%age_since_anthro_disturbance, olderPatch%age_since_anthro_disturbance currentPatch%land_use_label = olderPatch%land_use_label + currentPatch%age_since_anthro_disturbance = olderPatch%age_since_anthro_disturbance call fuse_2_patches(currentSite, olderPatch, currentPatch) gotfused = .true. endif countcycles_if @@ -2990,8 +2999,9 @@ subroutine terminate_patches(currentSite) youngerPatch => currentPatch%younger - distlabel_2_if: if (currentPatch%land_use_label .eq. youngerPatch% land_use_label) then + distlabel_2_if: if (currentPatch%land_use_label .eq. youngerPatch%land_use_label) then + write(fates_log(),*) 'terminate: distlabel_2: calling fuse: same', youngerPatch%land_use_label, currentPatch%land_use_label call fuse_2_patches(currentSite, youngerPatch, currentPatch) ! The fusion process has updated the "younger" pointer on currentPatch @@ -3002,7 +3012,10 @@ subroutine terminate_patches(currentSite) if (count_cycles .gt. 0) then ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its younger sibling + write(fates_log(),*) 'terminate: distlabel_2: calling fuse: diff', youngerPatch%land_use_label, currentPatch%land_use_label + write(fates_log(),*) 'terminate: agesince: rp, dp:', currentPatch%age_since_anthro_disturbance,youngerPatch%age_since_anthro_disturbance currentPatch%land_use_label = youngerPatch%land_use_label + currentPatch%age_since_anthro_disturbance = youngerPatch%age_since_anthro_disturbance call fuse_2_patches(currentSite, youngerPatch, currentPatch) gotfused = .true. endif ! count cycles diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index fa4ce3b42d..28932ec490 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2815,6 +2815,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) cpatch%area * AREA_INV ageclass_since_anthrodist = get_age_class_index(cpatch%age_since_anthro_disturbance) + write(fates_log(),*) 'hist: lul, agesince:', cpatch%land_use_label, cpatch%age_since_anthro_disturbance hio_agesince_anthrodist_si_age(io_si,ageclass_since_anthrodist) = & hio_agesince_anthrodist_si_age(io_si,ageclass_since_anthrodist) & @@ -2823,10 +2824,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_secondarylands_area_si_age(io_si,cpatch%age_class) = & hio_secondarylands_area_si_age(io_si,cpatch%age_class) & + cpatch%area * AREA_INV - endif - ! Secondary forest mean LAI - if ( cpatch%land_use_label .eq. secondaryland ) then hio_lai_secondary_si(io_si) = hio_lai_secondary_si(io_si) & + sum(cpatch%tlai_profile(:,:,:)) * cpatch%total_canopy_area end if From 3c6dee2d59ac125c13e3d1750f410e6124880831 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 9 Oct 2023 11:28:53 -0400 Subject: [PATCH 133/250] Added error tracking in two-stream --- biogeochem/FatesPatchMod.F90 | 9 +- .../radiation/f90_src/RadiationWrapMod.F90 | 8 +- main/FatesHistoryInterfaceMod.F90 | 96 ++++++++++++++++++- main/FatesRestartInterfaceMod.F90 | 6 ++ radiation/FatesRadiationDriveMod.F90 | 5 + radiation/TwoStreamMLPEMod.F90 | 24 ++++- 6 files changed, 138 insertions(+), 10 deletions(-) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index 443ee19474..d5c31769dc 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -123,9 +123,12 @@ module FatesPatchMod real(r8) :: fcansno ! fraction of canopy covered in snow [0-1] logical :: solar_zenith_flag ! integer flag specifying daylight (based on zenith angle) real(r8) :: solar_zenith_angle ! solar zenith angle [radians] - real(r8) :: gnd_alb_dif(num_swb) ! ground albedo for diffuse rad, both bands [0-1] - real(r8) :: gnd_alb_dir(num_swb) ! ground albedo for direct rad, both bands [0-1] - + real(r8) :: gnd_alb_dif(num_swb) ! ground albedo for diffuse rad, both bands [0-1] + real(r8) :: gnd_alb_dir(num_swb) ! ground albedo for direct rad, both bands [0-1] + real(r8) :: solve_err(num_swb) ! Error from linear system solver, fraction of unit forcing + real(r8) :: consv_err(num_swb) ! Error from albedo conservation check, fraction of unit forcing + + ! organized by canopy layer, pft, and leaf layer real(r8) :: fabd_sun_z(nclmax,maxpft,nlevleaf) ! sun fraction of direct light absorbed [0-1] real(r8) :: fabd_sha_z(nclmax,maxpft,nlevleaf) ! shade fraction of direct light absorbed [0-1] diff --git a/functional_unit_testing/radiation/f90_src/RadiationWrapMod.F90 b/functional_unit_testing/radiation/f90_src/RadiationWrapMod.F90 index 596087f046..635a8dc7b3 100644 --- a/functional_unit_testing/radiation/f90_src/RadiationWrapMod.F90 +++ b/functional_unit_testing/radiation/f90_src/RadiationWrapMod.F90 @@ -157,6 +157,8 @@ end subroutine WrapSetDownwelling subroutine WrapSolve(ib,boundary_type,Rbeam_atm,Rdiff_atm, & albedo_beam, & albedo_diff, & + err_solve, & + err_consv, & frac_abs_can_beam, & frac_abs_can_diff, & frac_beam_grnd_beam, & @@ -168,6 +170,8 @@ subroutine WrapSolve(ib,boundary_type,Rbeam_atm,Rdiff_atm, & real(r8) :: albedo_beam real(r8) :: albedo_diff + real(r8) :: err_solve + real(r8) :: err_consv real(r8) :: frac_abs_can_beam real(r8) :: frac_abs_can_diff real(r8) :: frac_beam_grnd_beam @@ -186,7 +190,9 @@ subroutine WrapSolve(ib,boundary_type,Rbeam_atm,Rdiff_atm, & omega, & ipiv, & albedo_beam, & - albedo_diff, & + albedo_diff, & + err_solve, & + err_consv, & frac_abs_can_beam, & frac_abs_can_diff, & frac_beam_grnd_beam, & diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 2fd0845b56..9a95b05338 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -48,6 +48,8 @@ module FatesHistoryInterfaceMod use EDParamsMod , only : ED_val_comp_excln use EDParamsMod , only : ED_val_phen_coldtemp use EDParamsMod , only : nlevleaf + use EDParamsMod , only : ED_val_history_height_bin_edges + use EDParamsMod , only : ED_val_history_ageclass_bin_edges use FatesInterfaceTypesMod , only : nlevsclass, nlevage use FatesInterfaceTypesMod , only : nlevheight use FatesInterfaceTypesMod , only : bc_in_type @@ -56,7 +58,7 @@ module FatesHistoryInterfaceMod use FatesInterfaceTypesMod , only : nlevcoage use FatesInterfaceTypesMod , only : hlm_use_nocomp use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog - + use FatesRadiationMemMod , only : ivis,inir use FatesInterfaceTypesMod , only : hio_include_hifr_multi use FatesAllometryMod , only : CrownDepth @@ -98,6 +100,7 @@ module FatesHistoryInterfaceMod use PRTGenericMod , only : prt_carbon_allom_hyp use PRTAllometricCNPMod , only : stoich_max,stoich_growth_min use FatesSizeAgeTypeIndicesMod, only : get_layersizetype_class_index + use FatesSizeAgeTypeIndicesMod, only : get_age_class_index implicit none private ! By default everything is private @@ -352,7 +355,11 @@ module FatesHistoryInterfaceMod integer :: ih_c_stomata_si integer :: ih_c_lblayer_si integer :: ih_rad_error_si - + integer :: ih_vis_solve_err_age_si + integer :: ih_nir_solve_err_age_si + integer :: ih_vis_consv_err_age_si + integer :: ih_nir_consv_err_age_si + integer :: ih_fire_c_to_atm_si @@ -2121,14 +2128,14 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) use FatesSizeAgeTypeIndicesMod, only : get_sizeagepft_class_index use FatesSizeAgeTypeIndicesMod, only : get_agepft_class_index use FatesSizeAgeTypeIndicesMod, only : get_agefuel_class_index - use FatesSizeAgeTypeIndicesMod, only : get_age_class_index + use FatesSizeAgeTypeIndicesMod, only : get_height_index use FatesSizeAgeTypeIndicesMod, only : sizetype_class_index use FatesSizeAgeTypeIndicesMod, only : get_cdamagesize_class_index use FatesSizeAgeTypeIndicesMod, only : get_cdamagesizepft_class_index use FatesSizeAgeTypeIndicesMod, only : coagetype_class_index - use EDParamsMod , only : ED_val_history_height_bin_edges + use FatesInterfaceTypesMod , only : nlevdamage ! Arguments @@ -4397,9 +4404,14 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste integer :: s ! The local site index integer :: io_si ! The site index of the IO array integer :: ipa ! patch bc index for the patch + integer :: age_class ! class age index real(r8) :: site_area_veg_inv ! inverse canopy area of the site (1/m2) + real(r8) :: site_area_rad_inv ! inverse canopy area of site for only + ! patches that called the solver real(r8) :: dt_tstep_inv ! inverse timestep (1/sec) real(r8) :: n_perm2 ! number of plants per square meter + real(r8),allocatable :: age_area_rad_inv(:) + type(fates_patch_type),pointer :: cpatch type(fates_cohort_type),pointer :: ccohort @@ -4416,6 +4428,10 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste hio_c_stomata_si => this%hvars(ih_c_stomata_si)%r81d, & hio_c_lblayer_si => this%hvars(ih_c_lblayer_si)%r81d, & hio_rad_error_si => this%hvars(ih_rad_error_si)%r81d, & + hio_vis_solve_err_age_si => this%hvars(ih_vis_solve_err_age_si)%r82d, & + hio_nir_solve_err_age_si => this%hvars(ih_nir_solve_err_age_si)%r82d, & + hio_vis_consv_err_age_si => this%hvars(ih_vis_consv_err_age_si)%r82d, & + hio_nir_consv_err_age_si => this%hvars(ih_nir_consv_err_age_si)%r82d, & hio_nep_si => this%hvars(ih_nep_si)%r81d, & hio_hr_si => this%hvars(ih_hr_si)%r81d, & hio_gpp_canopy_si => this%hvars(ih_gpp_canopy_si)%r81d, & @@ -4435,6 +4451,8 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste dt_tstep_inv = 1.0_r8/dt_tstep + allocate(age_area_rad_inv(size(ED_val_history_ageclass_bin_edges,1)+1)) + do_sites: do s = 1,nsites call this%zero_site_hvars(sites(s), upfreq_in=2) @@ -4444,13 +4462,56 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste hio_nep_si(io_si) = -bc_in(s)%tot_het_resp * kg_per_g hio_hr_si(io_si) = bc_in(s)%tot_het_resp * kg_per_g + ! Diagnostics that are only incremented if we called the radiation solver + ! We do not call the radiation solver if + ! a) there is no vegetation + ! b) there is no light! (ie cos(zenith) ~= 0) + age_area_rad_inv(:) = 0._r8 + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + if( abs(cpatch%solve_err(ivis)-hlm_hio_ignore_val)>nearzero ) then + age_class = get_age_class_index(cpatch%age) + age_area_rad_inv(age_class) = age_area_rad_inv(age_class) + cpatch%total_canopy_area + end if + cpatch => cpatch%younger + end do + + do age_class = 1,size(ED_val_history_ageclass_bin_edges,1) + if( age_area_rad_inv(age_class) < nearzero) then + hio_vis_solve_err_age_si(io_si,age_class) = hlm_hio_ignore_val + hio_nir_solve_err_age_si(io_si,age_class) = hlm_hio_ignore_val + hio_vis_consv_err_age_si(io_si,age_class) = hlm_hio_ignore_val + hio_nir_consv_err_age_si(io_si,age_class) = hlm_hio_ignore_val + end if + end do + + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + if( abs(cpatch%solve_err(ivis)-hlm_hio_ignore_val)>nearzero ) then + age_class = get_age_class_index(cpatch%age) + hio_vis_solve_err_age_si(io_si,age_class) = hio_vis_solve_err_age_si(io_si,age_class) + & + cpatch%solve_err(ivis) * cpatch%total_canopy_area/age_area_rad_inv(age_class) + hio_nir_solve_err_age_si(io_si,age_class) = hio_nir_solve_err_age_si(io_si,age_class) + & + cpatch%solve_err(inir) * cpatch%total_canopy_area/age_area_rad_inv(age_class) + hio_vis_consv_err_age_si(io_si,age_class) = hio_vis_consv_err_age_si(io_si,age_class) + & + cpatch%consv_err(ivis) * cpatch%total_canopy_area/age_area_rad_inv(age_class) + hio_nir_consv_err_age_si(io_si,age_class) = hio_nir_consv_err_age_si(io_si,age_class) + & + cpatch%consv_err(inir) * cpatch%total_canopy_area/age_area_rad_inv(age_class) + end if + cpatch => cpatch%younger + end do + + ! Diagnostics that are only relevant if there is vegetation present on this site + ! ie, non-zero canopy area + + site_area_veg_inv = 0._r8 cpatch => sites(s)%oldest_patch do while(associated(cpatch)) site_area_veg_inv = site_area_veg_inv + cpatch%total_canopy_area cpatch => cpatch%younger end do !patch loop - + if_veg_area: if(site_area_veg_inv < nearzero) then hio_c_stomata_si(io_si) = hlm_hio_ignore_val @@ -4480,6 +4541,8 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste hio_rad_error_si(io_si) = hio_rad_error_si(io_si) + & cpatch%radiation_error * cpatch%total_canopy_area * site_area_veg_inv + + ! Only accumulate the instantaneous vegetation temperature for vegetated patches if (cpatch%patchno .ne. 0) then hio_tveg(io_si) = hio_tveg(io_si) + & @@ -4574,6 +4637,9 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste end do end if if_veg_area end do do_sites + + deallocate(age_area_rad_inv) + end associate return end subroutine update_history_hifrq_simple @@ -6540,6 +6606,26 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_rad_error_si) + call this%set_history_var(vname='FATES_VIS_SOLVE_ERROR_AGE', units='-', & + long='mean two-stream solver error for VIS by patch age', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_vis_solve_err_age_si) + + call this%set_history_var(vname='FATES_NIR_SOLVE_ERROR_AGE', units='-', & + long='mean two-stream solver error for NIR by patch age', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_nir_solve_err_age_si) + + call this%set_history_var(vname='FATES_VIS_CONSV_ERROR_AGE', units='-', & + long='mean two-stream conservation error for VIS by patch age', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_vis_consv_err_age_si) + + call this%set_history_var(vname='FATES_NIR_CONSV_ERROR_AGE', units='-', & + long='mean two-stream conservation error for NIR by patch age', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_nir_consv_err_age_si) + call this%set_history_var(vname='FATES_AR', units='gC/m^2/s', & long='autotrophic respiration', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 96badcf40b..557adc52f4 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -25,6 +25,7 @@ module FatesRestartInterfaceMod use FatesInterfaceTypesMod, only : hlm_use_sp use FatesInterfaceTypesMod, only : hlm_use_nocomp, hlm_use_fixed_biogeog use FatesInterfaceTypesMod, only : fates_maxElementsPerSite + use FatesInterfaceTypesMod, only : hlm_hio_ignore_val use FatesInterfaceTypesMod, only : hlm_use_tree_damage use FatesHydraulicsMemMod, only : nshell use FatesHydraulicsMemMod, only : n_hypool_ag @@ -3597,6 +3598,9 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 + currentPatch%solve_err(:) = hlm_hio_ignore_val + currentPatch%consv_err(:) = hlm_hio_ignore_val + ! ----------------------------------------------------------- ! When calling norman radiation from the short-timestep ! we are passing in boundary conditions to set the following @@ -3661,6 +3665,8 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) sites(s)%ipiv_2str, & ! inout (scratch) bc_out(s)%albd_parb(ifp,ib), & ! out bc_out(s)%albi_parb(ifp,ib), & ! out + currentPatch%solve_err(ib), & ! out + currentPatch%consv_err(ib), & ! out bc_out(s)%fabd_parb(ifp,ib), & ! out bc_out(s)%fabi_parb(ifp,ib), & ! out bc_out(s)%ftdd_parb(ifp,ib), & ! out diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index 32efb4ce82..e742159cc5 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -125,6 +125,9 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) currentPatch%gnd_alb_dir(1:hlm_numSWb) = bc_in(s)%albgr_dir_rb(1:hlm_numSWb) currentPatch%fcansno = bc_in(s)%fcansno_pa(ifp) + currentPatch%solve_err(:) = hlm_hio_ignore_val + currentPatch%consv_err(:) = hlm_hio_ignore_val + ! RGK: The ZenithPrep should only be necessary if the flag is true ! Move and test this. if(radiation_model.eq.twostr_solver) then @@ -183,6 +186,8 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) sites(s)%ipiv_2str, & ! inout (scratch) bc_out(s)%albd_parb(ifp,ib), & ! out bc_out(s)%albi_parb(ifp,ib), & ! out + currentPatch%solve_err(ib), & ! out + currentPatch%consv_err(ib), & ! out bc_out(s)%fabd_parb(ifp,ib), & ! out bc_out(s)%fabi_parb(ifp,ib), & ! out bc_out(s)%ftdd_parb(ifp,ib), & ! out diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index a28a28dcbd..9452714c7b 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -994,7 +994,9 @@ subroutine Solve(this, ib, & omega, & ipiv, & albedo_beam, & - albedo_diff, & + albedo_diff, & + solve_err, & + consv_err, & frac_abs_can_beam, & frac_abs_can_diff, & frac_beam_grnd_beam, & @@ -1035,6 +1037,17 @@ subroutine Solve(this, ib, & real(r8) :: albedo_beam ! Mean albedo at canopy top generated from beam radiation [-] real(r8) :: albedo_diff ! Mean albedo at canopy top generated from downwelling diffuse [-] + + real(r8) :: solve_err ! This is the maximum error encountered when comparing the forward solution + ! of the linear solution A*x, to the known b, in Ax=b. This is the maximum + ! considering all equations, and both beam and diffuse boundaries. Units + ! are a fraction relative to the boundary flux. + + real(r8) :: consv_err ! This is the error that is returned when seeing if the + ! total albedo matches the total absorbed by all cohorts and + ! the soil absorbed radiation. It is a fraction based + ! on upper boundaries of 1 W/m2 for both beam and diffuse + real(r8) :: frac_abs_can_beam ! Fraction of incident beam radiation absorbed by the vegetation [-] real(r8) :: frac_abs_can_diff ! Fraction of incident diffuse radiation absorbed by the vegetation [-] real(r8) :: frac_beam_grnd_beam ! fraction of beam radiation at ground resulting from of beam at canopy top [-] @@ -1135,6 +1148,14 @@ subroutine Solve(this, ib, & ! upper canopy. ! -------------------------------------------------------------------------- + if(debug)then + solve_err = 0._r8 + else + solve_err = -unset_r8 + end if + + consv_err = 0._r8 + if((Rbeam_atm+Rdiff_atm)rel_err_thresh)then write(log_unit,*) 'Poor forward solution on two-stream solver' write(log_unit,*) 'isol (1=beam or 2=diff): ',isol From fbde7c076c8ae14c0c33088040b5e5b38a1c84b7 Mon Sep 17 00:00:00 2001 From: John Alex Date: Wed, 11 Oct 2023 09:49:31 -0600 Subject: [PATCH 134/250] Define new fates_param_reader_type type for abstracting param I/O, and copy FatesReadParameters() over from HLM. --- main/FatesInterfaceMod.F90 | 64 ++++++++++++++++++++++++++++--- main/FatesParametersInterface.F90 | 29 ++++++++++++++ 2 files changed, 88 insertions(+), 5 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 857c79336a..4f569fc140 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -64,9 +64,16 @@ module FatesInterfaceMod use EDParamsMod , only : ED_val_history_ageclass_bin_edges use EDParamsMod , only : ED_val_history_height_bin_edges use EDParamsMod , only : ED_val_history_coageclass_bin_edges - use CLMFatesParamInterfaceMod , only : FatesReadParameters - use EDParamsMod , only : p_uptake_mode - use EDParamsMod , only : n_uptake_mode + use FatesParametersInterface , only : fates_param_reader_type + use FatesParametersInterface , only : fates_parameters_type + use EDParamsMod , only : FatesRegisterParams, FatesReceiveParams + use SFParamsMod , only : SpitFireRegisterParams, SpitFireReceiveParams + use PRTInitParamsFATESMod , only : PRTRegisterParams, PRTReceiveParams + use FatesSynchronizedParamsMod, only : FatesSynchronizedParamsInst + ! TODO(jpalex): remove this direct reference to HLM code. + use CLMFatesParamInterfaceMod , only : HLM_FatesReadParameters => FatesReadParameters + use EDParamsMod , only : p_uptake_mode + use EDParamsMod , only : n_uptake_mode use EDTypesMod , only : ed_site_type use FatesConstantsMod , only : prescribed_p_uptake use FatesConstantsMod , only : prescribed_n_uptake @@ -173,6 +180,8 @@ module FatesInterfaceMod public :: set_bcs public :: UpdateFatesRMeansTStep public :: InitTimeAveragingGlobals + + private :: FatesReadParameters contains @@ -726,7 +735,7 @@ end subroutine set_bcs ! =================================================================================== - subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft) + subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft,param_reader) ! -------------------------------------------------------------------------------- ! @@ -741,13 +750,21 @@ subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft) logical, intent(in) :: use_fates ! Is fates turned on? integer, intent(in) :: surf_numpft ! Number of PFTs in surface dataset integer, intent(in) :: surf_numcft ! Number of CFTs in surface dataset + ! TODO(jpalex): make non-optional once all HLMs pass it in. + class(fates_param_reader_type), optional, intent(in) :: param_reader ! HLM-provided param file reader integer :: fates_numpft ! Number of PFTs tracked in FATES if (use_fates) then ! Self explanatory, read the fates parameter file - call FatesReadParameters() + if (present(param_reader)) then + ! new, Fates-side. + call FatesReadParameters(param_reader) + else + ! old, HLM-side. + call HLM_FatesReadParameters() + end if fates_numpft = size(prt_params%wood_density,dim=1) @@ -2142,5 +2159,42 @@ subroutine SeedlingParPatch(cpatch, & return end subroutine SeedlingParPatch + !----------------------------------------------------------------------- + ! TODO(jpalex): this belongs in FatesParametersInterface.F90, but would require + ! untangling the dependencies of the *RegisterParams methods below. + subroutine FatesReadParameters(param_reader) + implicit none + + class(fates_param_reader_type), intent(in) :: param_reader ! HLM-provided param file reader + + character(len=32) :: subname = 'FatesReadParameters' + class(fates_parameters_type), allocatable :: fates_params + logical :: is_host_file + + if ( hlm_masterproc == itrue ) then + write(fates_log(), *) 'FatesParametersInterface.F90::'//trim(subname)//' :: CLM reading ED/FATES '//' parameters ' + end if + + allocate(fates_params) + call fates_params%Init() ! fates_params class, in FatesParameterInterfaceMod + call FatesRegisterParams(fates_params) !EDParamsMod, only operates on fates_params class + call SpitFireRegisterParams(fates_params) !SpitFire Mod, only operates of fates_params class + call PRTRegisterParams(fates_params) ! PRT mod, only operates on fates_params class + call FatesSynchronizedParamsInst%RegisterParams(fates_params) !Synchronized params class in Synchronized params mod, only operates on fates_params class + + is_host_file = .false. + call param_reader%Read(is_host_file, fates_params) + + is_host_file = .true. + call param_reader%Read(is_host_file, fates_params) + + call FatesReceiveParams(fates_params) + call SpitFireReceiveParams(fates_params) + call PRTReceiveParams(fates_params) + call FatesSynchronizedParamsInst%ReceiveParams(fates_params) + + call fates_params%Destroy() + deallocate(fates_params) + end subroutine FatesReadParameters end module FatesInterfaceMod diff --git a/main/FatesParametersInterface.F90 b/main/FatesParametersInterface.F90 index b19817a091..3a220e1066 100644 --- a/main/FatesParametersInterface.F90 +++ b/main/FatesParametersInterface.F90 @@ -83,6 +83,35 @@ module FatesParametersInterface end type fates_parameters_type + ! Abstract class (to be implemented by host land models) to read in + ! parameter values. + type, abstract, public :: fates_param_reader_type + contains + ! Public functions + procedure(Read_interface), public, deferred :: Read + + end type fates_param_reader_type + + abstract interface + subroutine Read_interface(this, is_host_file, fates_params ) + ! + ! !DESCRIPTION: + ! Read 'fates_params' parameters from appropriate filename given 'is_host_file'. + ! + ! USES + import :: fates_param_reader_type + import :: fates_parameters_type + ! !ARGUMENTS: + class(fates_param_reader_type) :: this + logical, intent(in) :: is_host_file + class(fates_parameters_type), intent(inout) :: fates_params + !----------------------------------------------------------------------- + + end subroutine Read_interface + + !----------------------------------------------------------------------- + end interface + contains !----------------------------------------------------------------------- From af6a2717d3e45b0b75d1d33126e7b6f3ab34c6a5 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 13 Oct 2023 13:10:58 -0600 Subject: [PATCH 135/250] Removed canopy_structure() from the restart sequence, it shouldn't be there --- main/EDMainMod.F90 | 33 ++++++++++++++++--------------- main/FatesRestartInterfaceMod.F90 | 17 +++++++++++++++- 2 files changed, 33 insertions(+), 17 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 7bbe46cb99..6a360352ab 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -763,7 +763,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) end subroutine ed_integrate_state_variables !-------------------------------------------------------------------------------! - subroutine ed_update_site( currentSite, bc_in, bc_out ) + subroutine ed_update_site( currentSite, bc_in, bc_out, is_restart ) ! ! !DESCRIPTION: ! Calls routines to consolidate the ED growth process. @@ -779,6 +779,7 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) type(ed_site_type) , intent(inout), target :: currentSite type(bc_in_type) , intent(in) :: bc_in type(bc_out_type) , intent(inout) :: bc_out + logical,intent(in) :: is_restart ! is this called during restart read? ! ! !LOCAL VARIABLES: type (fates_patch_type) , pointer :: currentPatch @@ -789,7 +790,7 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) call TotalBalanceCheck(currentSite,6) - if(hlm_use_sp.eq.ifalse)then + if(hlm_use_sp.eq.ifalse .and. (.not.is_restart) )then call canopy_structure(currentSite, bc_in) endif @@ -803,22 +804,22 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) - ! Is termination really needed here? - ! Canopy_structure just called it several times! (rgk) - call terminate_cohorts(currentSite, currentPatch, 1, 11, bc_in) - call terminate_cohorts(currentSite, currentPatch, 2, 11, bc_in) - - ! This cohort count is used in the photosynthesis loop - call count_cohorts(currentPatch) - - ! Update the total area of by patch age class array - currentSite%area_by_age(currentPatch%age_class) = & - currentSite%area_by_age(currentPatch%age_class) + currentPatch%area - - currentPatch => currentPatch%younger + if(.not.is_restart)then + call terminate_cohorts(currentSite, currentPatch, 1, 11, bc_in) + call terminate_cohorts(currentSite, currentPatch, 2, 11, bc_in) + end if + ! This cohort count is used in the photosynthesis loop + call count_cohorts(currentPatch) + + ! Update the total area of by patch age class array + currentSite%area_by_age(currentPatch%age_class) = & + currentSite%area_by_age(currentPatch%age_class) + currentPatch%area + + currentPatch => currentPatch%younger + enddo - + ! The HLMs need to know about nutrient demand, and/or ! root mass and affinities call PrepNutrientAquisitionBCs(currentSite,bc_in,bc_out) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 55016e9acb..05fa063601 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -140,7 +140,8 @@ module FatesRestartInterfaceMod integer :: ir_treesai_co integer :: ir_canopy_layer_tlai_pa - + integer :: ir_nclp_pa + integer :: ir_zstar_pa !Logging integer :: ir_lmort_direct_co @@ -1133,12 +1134,22 @@ subroutine define_restart_vars(this, initialize_variables) long_name='stem area index of fates cohort', & units='m2/m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_treesai_co ) + call this%set_restart_var(vname='fates_canopy_layer_tlai_pa', vtype=cohort_r8, & long_name='total patch level leaf area index of each fates canopy layer', & units='m2/m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_layer_tlai_pa ) end if + call this%set_restart_var(vname='fates_nclp_pa', vtype=cohort_r8, & + long_name='total number of canopy layers', & + units='-', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_nclp_pa ) + + call this%set_restart_var(vname='fates_zstar_pa', vtype=cohort_r8, & + long_name='patch zstar', & + units='-', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_zstar_pa ) ! Only register hydraulics restart variables if it is turned on! @@ -2402,6 +2413,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ,io_idx_co,cohortsperpatch endif + this%rvars(ir_nclp_pa)%r81d(io_idx_co_1st) = cpatch%ncl_p + this%rvars(ir_zstar_pa)%r81d(io_idx_co_1st) = cpatch%zstar if(hlm_use_sp.eq.ifalse)then @@ -3301,6 +3314,8 @@ subroutine get_restart_vectors(this, nc, nsites, sites) cpatch%solar_zenith_flag = ( rio_solar_zenith_flag_pa(io_idx_co_1st) .eq. itrue ) cpatch%solar_zenith_angle = rio_solar_zenith_angle_pa(io_idx_co_1st) + cpatch%ncl_p = this%rvars(ir_nclp_pa)%r81d(io_idx_co_1st) + cpatch%zstar = this%rvars(ir_zstar_pa)%r81d(io_idx_co_1st) call this%GetRMeanRestartVar(cpatch%tveg24, ir_tveg24_pa, io_idx_co_1st) call this%GetRMeanRestartVar(cpatch%tveg_lpa, ir_tveglpa_pa, io_idx_co_1st) From 3d5e878e31b65e34313516970c277f9c43f44bea Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 13 Oct 2023 15:13:55 -0700 Subject: [PATCH 136/250] update diagnostics --- biogeochem/EDPatchDynamicsMod.F90 | 19 +++++++++++-------- main/FatesHistoryInterfaceMod.F90 | 1 - 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 7e311af6ab..ddc810b78c 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2585,6 +2585,7 @@ subroutine fuse_patches( csite, bc_in ) !-----------------------! tmpptr => currentPatch%older + if (currentPatch%land_use_label .eq. secondaryland) & write(fates_log(),*) 'fusepatches: calling fuse', tpp%land_use_label, currentPatch%land_use_label call fuse_2_patches(csite, currentPatch, tpp) call fuse_cohorts(csite,tpp, bc_in) @@ -2715,12 +2716,8 @@ subroutine fuse_2_patches(csite, dp, rp) inv_sum_area = 1.0_r8/(dp%area + rp%area) rp%age = (dp%age * dp%area + rp%age * rp%area) * inv_sum_area - write(fates_log(),*) 'fuse2 pre: agesince: rp, dp:', rp%age_since_anthro_disturbance, dp%age_since_anthro_disturbance - write(fates_log(),*) 'fuse2 pre: area: rp, dp:', rp%area, dp%area rp%age_since_anthro_disturbance = (dp%age_since_anthro_disturbance * dp%area & + rp%age_since_anthro_disturbance * rp%area) * inv_sum_area - write(fates_log(),*) 'fuse2 pst: agesince: rp, dp:', rp%age_since_anthro_disturbance, dp%age_since_anthro_disturbance - write(fates_log(),*) 'fuse2 pst: area: rp, dp:', rp%area, dp%area rp%age_class = get_age_class_index(rp%age) @@ -2966,6 +2963,7 @@ subroutine terminate_patches(currentSite) if(debug) & write(fates_log(),*) 'terminate: fused to older patch, same label: ', currentPatch%land_use_label, olderPatch%land_use_label + if (olderPatch%land_use_label .eq. secondaryland) & write(fates_log(),*) 'terminate: distlabel_1: calling fuse: same', olderPatch%land_use_label, currentPatch%land_use_label call fuse_2_patches(currentSite, olderPatch, currentPatch) @@ -2981,8 +2979,10 @@ subroutine terminate_patches(currentSite) ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its older sibling ! and then allow them to fuse together. - write(fates_log(),*) 'terminate: distlabel_1: calling fuse: diff', olderPatch%land_use_label, currentPatch%land_use_label - write(fates_log(),*) 'terminate: agesince: rp, dp:', currentPatch%age_since_anthro_disturbance, olderPatch%age_since_anthro_disturbance + if (olderPatch%land_use_label .eq. secondaryland) then + write(fates_log(),*) 'terminate: distlabel_1: calling fuse: diff', olderPatch%land_use_label, currentPatch%land_use_label + write(fates_log(),*) 'terminate: agesince: rp, dp:', currentPatch%age_since_anthro_disturbance, olderPatch%age_since_anthro_disturbance + end if currentPatch%land_use_label = olderPatch%land_use_label currentPatch%age_since_anthro_disturbance = olderPatch%age_since_anthro_disturbance call fuse_2_patches(currentSite, olderPatch, currentPatch) @@ -3001,6 +3001,7 @@ subroutine terminate_patches(currentSite) distlabel_2_if: if (currentPatch%land_use_label .eq. youngerPatch%land_use_label) then + if (youngerPatch%land_use_label .eq. secondaryland) & write(fates_log(),*) 'terminate: distlabel_2: calling fuse: same', youngerPatch%land_use_label, currentPatch%land_use_label call fuse_2_patches(currentSite, youngerPatch, currentPatch) @@ -3012,8 +3013,10 @@ subroutine terminate_patches(currentSite) if (count_cycles .gt. 0) then ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its younger sibling - write(fates_log(),*) 'terminate: distlabel_2: calling fuse: diff', youngerPatch%land_use_label, currentPatch%land_use_label - write(fates_log(),*) 'terminate: agesince: rp, dp:', currentPatch%age_since_anthro_disturbance,youngerPatch%age_since_anthro_disturbance + if (youngerPatch%land_use_label .eq. secondaryland) then + write(fates_log(),*) 'terminate: distlabel_2: calling fuse: diff', youngerPatch%land_use_label, currentPatch%land_use_label + write(fates_log(),*) 'terminate: agesince: rp, dp:', currentPatch%age_since_anthro_disturbance,youngerPatch%age_since_anthro_disturbance + end if currentPatch%land_use_label = youngerPatch%land_use_label currentPatch%age_since_anthro_disturbance = youngerPatch%age_since_anthro_disturbance call fuse_2_patches(currentSite, youngerPatch, currentPatch) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 28932ec490..13b393ab90 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2815,7 +2815,6 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) cpatch%area * AREA_INV ageclass_since_anthrodist = get_age_class_index(cpatch%age_since_anthro_disturbance) - write(fates_log(),*) 'hist: lul, agesince:', cpatch%land_use_label, cpatch%age_since_anthro_disturbance hio_agesince_anthrodist_si_age(io_si,ageclass_since_anthrodist) = & hio_agesince_anthrodist_si_age(io_si,ageclass_since_anthrodist) & From 8cf5d471c14284d5a68e8641e90e44ad81ea22f5 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Sun, 15 Oct 2023 22:44:56 -0700 Subject: [PATCH 137/250] remove diagnostic statments --- biogeochem/EDPatchDynamicsMod.F90 | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index ddc810b78c..ec234bef76 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2585,8 +2585,6 @@ subroutine fuse_patches( csite, bc_in ) !-----------------------! tmpptr => currentPatch%older - if (currentPatch%land_use_label .eq. secondaryland) & - write(fates_log(),*) 'fusepatches: calling fuse', tpp%land_use_label, currentPatch%land_use_label call fuse_2_patches(csite, currentPatch, tpp) call fuse_cohorts(csite,tpp, bc_in) call sort_cohorts(tpp) @@ -2963,8 +2961,6 @@ subroutine terminate_patches(currentSite) if(debug) & write(fates_log(),*) 'terminate: fused to older patch, same label: ', currentPatch%land_use_label, olderPatch%land_use_label - if (olderPatch%land_use_label .eq. secondaryland) & - write(fates_log(),*) 'terminate: distlabel_1: calling fuse: same', olderPatch%land_use_label, currentPatch%land_use_label call fuse_2_patches(currentSite, olderPatch, currentPatch) ! The fusion process has updated the "older" pointer on currentPatch @@ -2979,10 +2975,6 @@ subroutine terminate_patches(currentSite) ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its older sibling ! and then allow them to fuse together. - if (olderPatch%land_use_label .eq. secondaryland) then - write(fates_log(),*) 'terminate: distlabel_1: calling fuse: diff', olderPatch%land_use_label, currentPatch%land_use_label - write(fates_log(),*) 'terminate: agesince: rp, dp:', currentPatch%age_since_anthro_disturbance, olderPatch%age_since_anthro_disturbance - end if currentPatch%land_use_label = olderPatch%land_use_label currentPatch%age_since_anthro_disturbance = olderPatch%age_since_anthro_disturbance call fuse_2_patches(currentSite, olderPatch, currentPatch) @@ -3001,8 +2993,6 @@ subroutine terminate_patches(currentSite) distlabel_2_if: if (currentPatch%land_use_label .eq. youngerPatch%land_use_label) then - if (youngerPatch%land_use_label .eq. secondaryland) & - write(fates_log(),*) 'terminate: distlabel_2: calling fuse: same', youngerPatch%land_use_label, currentPatch%land_use_label call fuse_2_patches(currentSite, youngerPatch, currentPatch) ! The fusion process has updated the "younger" pointer on currentPatch @@ -3013,10 +3003,6 @@ subroutine terminate_patches(currentSite) if (count_cycles .gt. 0) then ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its younger sibling - if (youngerPatch%land_use_label .eq. secondaryland) then - write(fates_log(),*) 'terminate: distlabel_2: calling fuse: diff', youngerPatch%land_use_label, currentPatch%land_use_label - write(fates_log(),*) 'terminate: agesince: rp, dp:', currentPatch%age_since_anthro_disturbance,youngerPatch%age_since_anthro_disturbance - end if currentPatch%land_use_label = youngerPatch%land_use_label currentPatch%age_since_anthro_disturbance = youngerPatch%age_since_anthro_disturbance call fuse_2_patches(currentSite, youngerPatch, currentPatch) From 438a1e5c428242a5d628e8bec6deac3f1bc5c008 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 16 Oct 2023 10:25:41 -0400 Subject: [PATCH 138/250] Changed ncl_p restart variable to integer, since... its and integer --- main/FatesRestartInterfaceMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 05fa063601..96ef276779 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -1141,7 +1141,7 @@ subroutine define_restart_vars(this, initialize_variables) hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_layer_tlai_pa ) end if - call this%set_restart_var(vname='fates_nclp_pa', vtype=cohort_r8, & + call this%set_restart_var(vname='fates_nclp_pa', vtype=cohort_int, & long_name='total number of canopy layers', & units='-', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_nclp_pa ) @@ -2413,7 +2413,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ,io_idx_co,cohortsperpatch endif - this%rvars(ir_nclp_pa)%r81d(io_idx_co_1st) = cpatch%ncl_p + this%rvars(ir_nclp_pa)%int1d(io_idx_co_1st) = cpatch%ncl_p this%rvars(ir_zstar_pa)%r81d(io_idx_co_1st) = cpatch%zstar if(hlm_use_sp.eq.ifalse)then @@ -3314,7 +3314,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) cpatch%solar_zenith_flag = ( rio_solar_zenith_flag_pa(io_idx_co_1st) .eq. itrue ) cpatch%solar_zenith_angle = rio_solar_zenith_angle_pa(io_idx_co_1st) - cpatch%ncl_p = this%rvars(ir_nclp_pa)%r81d(io_idx_co_1st) + cpatch%ncl_p = this%rvars(ir_nclp_pa)%int1d(io_idx_co_1st) cpatch%zstar = this%rvars(ir_zstar_pa)%r81d(io_idx_co_1st) call this%GetRMeanRestartVar(cpatch%tveg24, ir_tveg24_pa, io_idx_co_1st) From 3966cc85f3308a1653db108ef153edca9dcec012 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 16 Oct 2023 08:57:17 -0600 Subject: [PATCH 139/250] Updates to error tracking of two-stream --- main/FatesHistoryInterfaceMod.F90 | 116 +++++++++++++++++++++++------- radiation/TwoStreamMLPEMod.F90 | 2 +- 2 files changed, 93 insertions(+), 25 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 9a95b05338..552477dd2f 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -355,6 +355,10 @@ module FatesHistoryInterfaceMod integer :: ih_c_stomata_si integer :: ih_c_lblayer_si integer :: ih_rad_error_si + integer :: ih_vis_solve_err_si + integer :: ih_nir_solve_err_si + integer :: ih_vis_consv_err_si + integer :: ih_nir_consv_err_si integer :: ih_vis_solve_err_age_si integer :: ih_nir_solve_err_age_si integer :: ih_vis_consv_err_age_si @@ -4410,6 +4414,7 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste ! patches that called the solver real(r8) :: dt_tstep_inv ! inverse timestep (1/sec) real(r8) :: n_perm2 ! number of plants per square meter + real(r8) :: sum_area_rad ! sum of patch canopy areas real(r8),allocatable :: age_area_rad_inv(:) type(fates_patch_type),pointer :: cpatch @@ -4428,6 +4433,10 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste hio_c_stomata_si => this%hvars(ih_c_stomata_si)%r81d, & hio_c_lblayer_si => this%hvars(ih_c_lblayer_si)%r81d, & hio_rad_error_si => this%hvars(ih_rad_error_si)%r81d, & + hio_vis_solve_err_si => this%hvars(ih_vis_solve_err_si)%r81d, & + hio_nir_solve_err_si => this%hvars(ih_nir_solve_err_si)%r81d, & + hio_vis_consv_err_si => this%hvars(ih_vis_consv_err_si)%r81d, & + hio_nir_consv_err_si => this%hvars(ih_nir_consv_err_si)%r81d, & hio_vis_solve_err_age_si => this%hvars(ih_vis_solve_err_age_si)%r82d, & hio_nir_solve_err_age_si => this%hvars(ih_nir_solve_err_age_si)%r82d, & hio_vis_consv_err_age_si => this%hvars(ih_vis_consv_err_age_si)%r82d, & @@ -4469,6 +4478,11 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste age_area_rad_inv(:) = 0._r8 cpatch => sites(s)%oldest_patch do while(associated(cpatch)) + ! We initialize the solver error to the ignore value + ! in the radiation driver. It is only modified if the + ! solver was called. The solver will be called for NIR + ! if VIS is called, and likewise the same for conservation + ! error. So the check on VIS solve error will catch all. if( abs(cpatch%solve_err(ivis)-hlm_hio_ignore_val)>nearzero ) then age_class = get_age_class_index(cpatch%age) age_area_rad_inv(age_class) = age_area_rad_inv(age_class) + cpatch%total_canopy_area @@ -4476,31 +4490,65 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste cpatch => cpatch%younger end do - do age_class = 1,size(ED_val_history_ageclass_bin_edges,1) - if( age_area_rad_inv(age_class) < nearzero) then - hio_vis_solve_err_age_si(io_si,age_class) = hlm_hio_ignore_val - hio_nir_solve_err_age_si(io_si,age_class) = hlm_hio_ignore_val - hio_vis_consv_err_age_si(io_si,age_class) = hlm_hio_ignore_val - hio_nir_consv_err_age_si(io_si,age_class) = hlm_hio_ignore_val - end if - end do - - cpatch => sites(s)%oldest_patch - do while(associated(cpatch)) - if( abs(cpatch%solve_err(ivis)-hlm_hio_ignore_val)>nearzero ) then - age_class = get_age_class_index(cpatch%age) - hio_vis_solve_err_age_si(io_si,age_class) = hio_vis_solve_err_age_si(io_si,age_class) + & - cpatch%solve_err(ivis) * cpatch%total_canopy_area/age_area_rad_inv(age_class) - hio_nir_solve_err_age_si(io_si,age_class) = hio_nir_solve_err_age_si(io_si,age_class) + & - cpatch%solve_err(inir) * cpatch%total_canopy_area/age_area_rad_inv(age_class) - hio_vis_consv_err_age_si(io_si,age_class) = hio_vis_consv_err_age_si(io_si,age_class) + & - cpatch%consv_err(ivis) * cpatch%total_canopy_area/age_area_rad_inv(age_class) - hio_nir_consv_err_age_si(io_si,age_class) = hio_nir_consv_err_age_si(io_si,age_class) + & - cpatch%consv_err(inir) * cpatch%total_canopy_area/age_area_rad_inv(age_class) - end if - cpatch => cpatch%younger - end do + sum_area_rad = sum(age_area_rad_inv(:)) + + if_anyrad: if(sum_area_rad sites(s)%oldest_patch + do while(associated(cpatch)) + if( abs(cpatch%solve_err(ivis)-hlm_hio_ignore_val)>nearzero ) then + age_class = get_age_class_index(cpatch%age) + + hio_vis_solve_err_age_si(io_si,age_class) = hio_vis_solve_err_age_si(io_si,age_class) + & + cpatch%solve_err(ivis) * cpatch%total_canopy_area/age_area_rad_inv(age_class) + hio_nir_solve_err_age_si(io_si,age_class) = hio_nir_solve_err_age_si(io_si,age_class) + & + cpatch%solve_err(inir) * cpatch%total_canopy_area/age_area_rad_inv(age_class) + hio_vis_consv_err_age_si(io_si,age_class) = hio_vis_consv_err_age_si(io_si,age_class) + & + cpatch%consv_err(ivis) * cpatch%total_canopy_area/age_area_rad_inv(age_class) + hio_nir_consv_err_age_si(io_si,age_class) = hio_nir_consv_err_age_si(io_si,age_class) + & + cpatch%consv_err(inir) * cpatch%total_canopy_area/age_area_rad_inv(age_class) + + hio_vis_solve_err_si(io_si) = hio_vis_solve_err_si(io_si) + & + cpatch%solve_err(ivis)*cpatch%total_canopy_area/sum(age_area_rad_inv(:)) + hio_nir_solve_err_si(io_si) = hio_nir_solve_err_si(io_si) + & + cpatch%solve_err(inir)*cpatch%total_canopy_area/sum(age_area_rad_inv(:)) + hio_vis_consv_err_si(io_si) = hio_vis_consv_err_si(io_si) + & + cpatch%consv_err(ivis)*cpatch%total_canopy_area/sum(age_area_rad_inv(:)) + hio_nir_consv_err_si(io_si) = hio_nir_consv_err_si(io_si) + & + cpatch%consv_err(inir)*cpatch%total_canopy_area/sum(age_area_rad_inv(:)) + + end if + cpatch => cpatch%younger + end do + end if if_anyrad + ! Diagnostics that are only relevant if there is vegetation present on this site ! ie, non-zero canopy area @@ -6606,6 +6654,26 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_rad_error_si) + call this%set_history_var(vname='FATES_VIS_SOLVE_ERROR', units='-', & + long='mean two-stream solver error for VIS', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_vis_solve_err_si) + + call this%set_history_var(vname='FATES_NIR_SOLVE_ERROR', units='-', & + long='mean two-stream solver error for NIR', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_nir_solve_err_si) + + call this%set_history_var(vname='FATES_VIS_CONSV_ERROR', units='-', & + long='mean two-stream conservation error for VIS', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_vis_consv_err_si) + + call this%set_history_var(vname='FATES_NIR_CONSV_ERROR', units='-', & + long='mean two-stream conservation error for NIR', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_nir_consv_err_si) + call this%set_history_var(vname='FATES_VIS_SOLVE_ERROR_AGE', units='-', & long='mean two-stream solver error for VIS by patch age', use_default='active', & avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', upfreq=2, & diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index 9452714c7b..e711244341 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -43,7 +43,7 @@ Module TwoStreamMLPEMod ! Allowable error, as a fraction of total incident for total canopy ! radiation balance checks - real(r8), public, parameter :: rel_err_thresh = 1.e-6_r8 + real(r8), public, parameter :: rel_err_thresh = 1.e-4_r8 real(r8), public, parameter :: area_err_thresh = rel_err_thresh*0.1_r8 ! These are the codes for how the upper boundary is specified, normalized or absolute From 1f6eb832950ecfb73aaec3d66ed3282e396c057c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 17 Oct 2023 12:02:22 -0400 Subject: [PATCH 140/250] Update biogeochem/FatesAllometryMod.F90 Co-authored-by: Marcos Longo <5891904+mpaiao@users.noreply.github.com> --- biogeochem/FatesAllometryMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index b9b20f2f7e..759834a2db 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -2595,7 +2595,7 @@ subroutine VegAreaLayer(tree_lai,tree_sai,tree_height,iv,nv,pft,snow_depth, & elai_layer,esai_layer,tlai_layer,tsai_layer) ! ----------------------------------------------------------------------------------- - ! This routine returns the exposed leaf area (m2 of leaf) per m2 of + ! This routine returns the exposed leaf and stem areas (m2 of leaf and stem) per m2 of ! ground inside the crown, for the leaf-layer specified. ! ----------------------------------------------------------------------------------- From 25923bc120885302c8ffacc08f70c32c9f6d9db0 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 17 Oct 2023 12:02:43 -0400 Subject: [PATCH 141/250] Update radiation/TwoStreamMLPEMod.F90 Co-authored-by: Marcos Longo <5891904+mpaiao@users.noreply.github.com> --- radiation/TwoStreamMLPEMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index e711244341..9149e15a0e 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -26,11 +26,11 @@ Module TwoStreamMLPEMod use shr_log_mod , only: errMsg => shr_log_errMsg use shr_sys_mod , only: shr_sys_abort - + use FatesConstantsMod, only : r8 => fates_r8 + implicit none private - integer, parameter :: r8 = selected_real_kind(12) real(r8),parameter :: nearzero = 1.e-20_r8 logical, parameter :: debug=.true. logical, parameter :: use_derivation1 = .true. From 169a8bded6d0b841467b77a41c30f70b82f21128 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 17 Oct 2023 14:48:51 -0400 Subject: [PATCH 142/250] Updates to functional unit test code --- .../radiation/RadiationUTestDriver.py | 190 ++++++++++++------ .../radiation/f90_src/RadiationWrapMod.F90 | 2 - 2 files changed, 129 insertions(+), 63 deletions(-) diff --git a/functional_unit_testing/radiation/RadiationUTestDriver.py b/functional_unit_testing/radiation/RadiationUTestDriver.py index cd0f8ed223..278b80d644 100644 --- a/functional_unit_testing/radiation/RadiationUTestDriver.py +++ b/functional_unit_testing/radiation/RadiationUTestDriver.py @@ -246,12 +246,16 @@ def SerialParallelCanopyTest(): # Setup serial canopy "s_elems" s_elems = [] - s_elems.append([]) - s_elems.append([]) + #s_elems.append([]) + n_vai = 100 + + dvai = 0.05 for i in range(n_layer): + s_elems.append([]) + # Serial Setup ican = i+1 icol = 1 area = np.sum(cohort_area[i:]) @@ -263,20 +267,20 @@ def SerialParallelCanopyTest(): sai = lai*sai_frac n_vai = int((lai+sai)/dvai) - s_elems[0].append(elem_type(n_vai)) + s_elems[i].append(elem_type(n_vai)) - s_elems[0][-1].lai = lai - s_elems[0][-1].sai = sai - s_elems[0][-1].area = area - s_elems[0][-1].avai = np.linspace(0,lai+sai,num=n_vai) + s_elems[i][-1].lai = lai + s_elems[i][-1].sai = sai + s_elems[i][-1].area = area + s_elems[i][-1].avai = np.linspace(0,lai+sai,num=n_vai) iret = setup_canopy_call(c_int(ican),c_int(icol),c_int(pft),c_double(area),c_double(lai),c_double(sai)) icol = 2 area = 1-np.sum(cohort_area[i:]) - s_elems[1].append(elem_type(1)) - s_elems[1][-1].lai = 0.0 - s_elems[1][-1].sai = 0.0 - s_elems[1][-1].area = area + s_elems[i].append(elem_type(1)) + s_elems[i][-1].lai = 0.0 + s_elems[i][-1].sai = 0.0 + s_elems[i][-1].area = area lai = 0.0 sai = 0.0 air_pft = 0 @@ -332,25 +336,27 @@ def SerialParallelCanopyTest(): ican = i+1 icol = 1 - for iv in range(s_elems[0][i].n_vai): - iret = getintens_call(ci(ican),ci(icol),ci(ib),c8(s_elems[0][i].avai[iv]),byref(cd_r_diff_dn),byref(cd_r_diff_up),byref(cd_r_beam)) - s_elems[0][i].r_dn[iv] = cd_r_diff_dn.value - s_elems[0][i].r_up[iv] = cd_r_diff_up.value - s_elems[0][i].r_b[iv] = cd_r_beam.value + for iv in range(s_elems[i][0].n_vai): + iret = getintens_call(ci(ican),ci(icol),ci(ib),c8(s_elems[i][0].avai[iv]),byref(cd_r_diff_dn),byref(cd_r_diff_up),byref(cd_r_beam)) + s_elems[i][0].r_dn[iv] = cd_r_diff_dn.value + s_elems[i][0].r_up[iv] = cd_r_diff_up.value + s_elems[i][0].r_b[iv] = cd_r_beam.value if(iv>0): - s_elems[0][i].r_abs[iv-1] = (s_elems[0][i].r_dn[iv]-s_elems[0][i].r_dn[iv-1]) + \ - (s_elems[0][i].r_up[iv-1]-s_elems[0][i].r_up[iv]) + \ - (s_elems[0][i].r_b[iv]-s_elems[0][i].r_b[iv-1]) - - for iv in range(s_elems[1][i].n_vai): - iret = getintens_call(ci(ican),ci(icol+1),ci(ib),c8(s_elems[1][i].avai[iv]),byref(cd_r_diff_dn),byref(cd_r_diff_up),byref(cd_r_beam)) - s_elems[1][i].r_dn[iv] = cd_r_diff_dn.value - s_elems[1][i].r_up[iv] = cd_r_diff_up.value - s_elems[1][i].r_b[iv] = cd_r_beam.value + s_elems[i][0].r_abs[iv-1] = (s_elems[i][0].r_dn[iv]-s_elems[i][0].r_dn[iv-1]) + \ + (s_elems[i][0].r_up[iv-1]-s_elems[i][0].r_up[iv]) + \ + (s_elems[i][0].r_b[iv]-s_elems[i][0].r_b[iv-1]) + + icol=2 + for iv in range(s_elems[i][1].n_vai): + iret = getintens_call(ci(ican),ci(icol),ci(ib),c8(s_elems[i][1].avai[iv]),byref(cd_r_diff_dn),byref(cd_r_diff_up),byref(cd_r_beam)) + s_elems[i][1].r_dn[iv] = cd_r_diff_dn.value + s_elems[i][1].r_up[iv] = cd_r_diff_up.value + s_elems[i][1].r_b[iv] = cd_r_beam.value + print('air: {} {} {}'.format(ican,icol,cd_r_beam.value)) if(iv>0): - s_elems[1][i].r_abs[iv-1] = (s_elems[1][i].r_dn[iv]-s_elems[1][i].r_dn[iv-1]) + \ - (s_elems[1][i].r_up[iv-1]-s_elems[1][i].r_up[iv]) + \ - (s_elems[1][i].r_b[iv]-s_elems[1][i].r_b[iv-1]) + s_elems[i][1].r_abs[iv-1] = (s_elems[i][1].r_dn[iv]-s_elems[i][1].r_dn[iv-1]) + \ + (s_elems[i][1].r_up[iv-1]-s_elems[i][1].r_up[iv]) + \ + (s_elems[i][1].r_b[iv]-s_elems[i][1].r_b[iv-1]) # Lets get the absorbed radiation from the cohorts @@ -478,12 +484,63 @@ def SerialParallelCanopyTest(): - if(True): + if(False): PlotRadMaps(s_elems,0,'Beam Radiation [W/m2]') PlotRadMaps(s_elems,1,'Downwelling Diffuse Radiation [W/m2]') PlotRadMaps(s_elems,2,'Upwelling Diffuse Radiation [W/m2]') + # Setup paralell canopy p_elems + p_elems = [] + iret = alloc_twostream_call(ci(1),ci(n_cohorts)) + # Only one layer, so just one append + p_elems.append([]) + for i in range(n_cohorts): + icol = i+1 + ican = 1 + # Parallel + + p_elems[0].append(elem_type(n_vai)) + lai = cohort_lai[i] + sai = sai_frac * cohort_lai[i] + area = cohort_area[i] + p_elems[0][-1].lai = lai + p_elems[0][-1].sai = sai + p_elems[0][-1].area = area + p_elems[0][-1].avai = np.linspace(0,cohort_lai[i]*(1.+sai_frac),num=n_vai) + iret = setup_canopy_call(c_int(ican),c_int(icol),c_int(pft),c_double(area),c_double(lai),c_double(sai)) + + iret = grndsnow_albedo_call(c_int(visb),c_double(ground_albedo_diff),*ccharnb('albedo_grnd_diff')) + iret = grndsnow_albedo_call(c_int(visb),c_double(ground_albedo_beam),*ccharnb('albedo_grnd_beam')) + iret = grndsnow_albedo_call(c_int(nirb),c_double(ground_albedo_diff),*ccharnb('albedo_grnd_diff')) + iret = grndsnow_albedo_call(c_int(nirb),c_double(ground_albedo_beam),*ccharnb('albedo_grnd_beam')) + iret = canopy_prep_call(c8(frac_snow)) + iret = zenith_prep_call(c8(cosz)) + iret = solver_call(ci(ib),ci(normalized_boundary),c8(1.0),c8(1.0), \ + byref(cd_albedo_beam),byref(cd_albedo_diff), \ + byref(cd_canabs_beam),byref(cd_canabs_diff), \ + byref(cd_ffbeam_beam),byref(cd_ffdiff_beam),byref(cd_ffdiff_diff)) + iret = setdown_call(ci(ib),c8(R_beam),c8(R_diff)) + + ican = 1 + for i in range(n_cohorts): + icol = i+1 + for iv in range(p_elems[0][i].n_vai): + iret = getintens_call(ci(ican),ci(icol),ci(ib),c8(p_elems[0][i].avai[iv]),byref(cd_r_diff_dn),byref(cd_r_diff_up),byref(cd_r_beam)) + p_elems[0][i].r_dn[iv] = cd_r_diff_dn.value + p_elems[0][i].r_up[iv] = cd_r_diff_up.value + p_elems[0][i].r_b[iv] = cd_r_beam.value + if(iv>0): + p_elems[0][i].r_abs[iv-1] = (p_elems[0][i].r_dn[iv]-p_elems[0][i].r_dn[iv-1]) + \ + (p_elems[0][i].r_up[iv-1]-p_elems[0][i].r_up[iv]) + \ + (p_elems[0][i].r_b[iv]-p_elems[0][i].r_b[iv-1]) + + dealloc_twostream_call() + if(True): + PlotRadMaps(p_elems,0,'Beam Radiation [W/m2]') + PlotRadMaps(p_elems,1,'Downwelling Diffuse Radiation [W/m2]') + PlotRadMaps(p_elems,2,'Upwelling Diffuse Radiation [W/m2]') + def SunFracTests(): @@ -946,11 +1003,14 @@ def PlotRadMaps(elems,rtype,plt_title): fig, ax = plt.subplots(ncols=1,nrows=1,figsize=(5,5)) cmap = mpl.cm.Reds - n_layer = len(elems[0]) + #code.interact(local=dict(globals(), **locals())) + n_layer = len(elems) total_vai = 0 for i in range(n_layer): - total_vai = total_vai + \ - np.max([elems[0][i].lai+elems[0][i].sai,elems[1][i].lai+elems[1][i].sai]) + max_vai = 0. + for j in range(len(elems[i])): + max_vai = np.max([max_vai,elems[i][j].lai+elems[i][j].sai]) + total_vai = total_vai + max_vai ax.set_ylim([0,total_vai]) @@ -958,41 +1018,49 @@ def PlotRadMaps(elems,rtype,plt_title): rect = [] rcolor = [] for i in range(n_layer): - - # Vegetated - for iv in range(elems[0][i].n_vai-1): - if(rtype==0): - rel_intense = np.max([0,elems[0][i].r_b[iv]]) - elif(rtype==1): - rel_intense = np.max([0,elems[0][i].r_dn[iv]]) - elif(rtype==2): - rel_intense = np.max([0,elems[0][i].r_up[iv]]) - - dvai = elems[0][i].avai[iv+1]-elems[0][i].avai[iv] - rect.append(mpl.patches.Rectangle((0,(elems[0][i].avai[iv]+total_vai)),elems[0][i].area,dvai)) #,color = [rel_intense,0.5,0.5])) - rcolor.append(rel_intense) - + # + max_vai = 0. + area_off = 0. + for j in range(len(elems[i])): + max_vai = np.max([max_vai,elems[i][j].lai+elems[i][j].sai]) + for j in range(len(elems[i])): + for iv in range(elems[i][j].n_vai): + if(rtype==0): + rel_intense = np.max([0,elems[i][j].r_b[iv]]) + elif(rtype==1): + rel_intense = np.max([0,elems[i][j].r_dn[iv]]) + elif(rtype==2): + rel_intense = np.max([0,elems[i][j].r_up[iv]]) + + if(iv==0): + yoff = total_vai + dvai = elems[i][j].avai[iv] + else: + yoff = total_vai+elems[i][j].avai[iv-1] + dvai = elems[i][j].avai[iv]-elems[i][j].avai[iv-1] + rect.append(mpl.patches.Rectangle((area_off,yoff),elems[i][j].area,dvai)) + rcolor.append(rel_intense) + area_off = area_off + elems[i][j].area + + total_vai = total_vai + max_vai + # Air #rel_intense = np.max([0,np.min([1.,elems[1][i].r_dn[0]/R_diff])]) #rel_intense = np.max([0,elems[1][i].r_dn[0]]) - if(rtype==0): - rel_intense = np.max([1,elems[1][i].r_b[0]]) - elif(rtype==1): - rel_intense = np.max([1,elems[1][i].r_dn[0]]) - elif(rtype==2): - rel_intense = np.max([1,elems[1][i].r_up[0]]) + #if(rtype==0): + # rel_intense = np.max([0,elems[1][i].r_b[0]]) + #elif(rtype==1): + # rel_intense = np.max([0,elems[1][i].r_dn[0]]) + #elif(rtype==2): + # rel_intense = np.max([0,elems[1][i].r_up[0]]) - rect.append(mpl.patches.Rectangle((elems[0][i].area,total_vai),(1.-elems[0][i].area),(elems[0][i].lai+elems[0][i].sai))) #,color = [rel_intense,0.5,0.5])) - rcolor.append(rel_intense) - - total_vai = total_vai + \ - np.max([elems[0][i].lai+elems[0][i].sai,elems[1][i].lai+elems[1][i].sai]) - + #rect.append(mpl.patches.Rectangle((elems[0][i].area,total_vai),(1.-elems[0][i].area),(elems[0][i].lai+elems[0][i].sai))) #,color = [rel_intense,0.5,0.5])) + #rcolor.append(rel_intense) - p = mpl.collections.PatchCollection(rect,cmap = cmap,alpha = 1.0) - p.set_array(rcolor) - im = ax.add_collection(p) + p = mpl.collections.PatchCollection(rect,cmap = cmap,alpha = 1.0) + p.set_array(rcolor) + im = ax.add_collection(p) #code.interact(local=dict(globals(), **locals())) diff --git a/functional_unit_testing/radiation/f90_src/RadiationWrapMod.F90 b/functional_unit_testing/radiation/f90_src/RadiationWrapMod.F90 index 635a8dc7b3..90c31d21a8 100644 --- a/functional_unit_testing/radiation/f90_src/RadiationWrapMod.F90 +++ b/functional_unit_testing/radiation/f90_src/RadiationWrapMod.F90 @@ -157,8 +157,6 @@ end subroutine WrapSetDownwelling subroutine WrapSolve(ib,boundary_type,Rbeam_atm,Rdiff_atm, & albedo_beam, & albedo_diff, & - err_solve, & - err_consv, & frac_abs_can_beam, & frac_abs_can_diff, & frac_beam_grnd_beam, & From 4d8bebc52e0c2b7a39b018333b018def35681955 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 18 Oct 2023 09:56:53 -0400 Subject: [PATCH 143/250] Updates to the history file for twostream --- main/FatesHistoryInterfaceMod.F90 | 217 +++++++++++++++++++----------- 1 file changed, 137 insertions(+), 80 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 552477dd2f..438b1e51b8 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -4588,7 +4588,6 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste hio_rad_error_si(io_si) = hio_rad_error_si(io_si) + & cpatch%radiation_error * cpatch%total_canopy_area * site_area_veg_inv - ! Only accumulate the instantaneous vegetation temperature for vegetated patches @@ -4728,8 +4727,11 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep real(r8) :: canopy_area_by_age(nlevage) ! canopy area in each bin for normalizing purposes real(r8) :: site_area_veg_inv ! 1/area of the site that is not bare-ground integer :: ipa2 ! patch incrementer - integer :: cnlfpft_indx, cnlf_indx, ipft, ican, ileaf ! more iterators and indices + integer :: clllpf_indx, cnlf_indx, ipft, ican, ileaf ! more iterators and indices + real(r8),allocatable :: clllpf_area_vec(:) ! total area for the cl x ll x pft bin across all patches + real(r8) :: clllpf_area ! total area for the cl x ll x pft bin + type(fates_patch_type),pointer :: cpatch type(fates_cohort_type),pointer :: ccohort real(r8) :: dt_tstep_inv ! Time step in frequency units (/s) @@ -4792,8 +4794,11 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep ! Flush the relevant history variables call this%flush_hvars(nc,upfreq_in=upfreq_hifr_multi) - + dt_tstep_inv = 1.0_r8/dt_tstep + + allocate(clllpf_area_vec(numpft*nlevcan*nlevleaf)) + do_sites: do s = 1,nsites @@ -4815,7 +4820,8 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep patch_area_by_age(1:nlevage) = 0._r8 canopy_area_by_age(1:nlevage) = 0._r8 - + clllpf_area_vec(:) = 0._r8 + call this%zero_site_hvars(sites(s), upfreq_in=upfreq_hifr_multi) cpatch => sites(s)%oldest_patch @@ -4939,78 +4945,82 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep ! summarize radiation profiles through the canopy - if_zenith: if(cpatch%solar_zenith_flag) then - do_pft: do ipft=1,numpft - do_canlev: do ican=1,cpatch%ncl_p - do_leaflev: do ileaf=1,cpatch%ncan(ican,ipft) - ! calculate where we are on multiplexed dimensions - cnlfpft_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax - cnlf_indx = ileaf + (ican-1) * nlevleaf - - ! first do all the canopy x leaf x pft calculations - hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%total_canopy_area * site_area_veg_inv - - hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%total_canopy_area * site_area_veg_inv - ! - hio_laisun_clllpf(io_si,cnlfpft_indx) = hio_laisun_clllpf(io_si,cnlfpft_indx) + & - cpatch%elai_profile(ican,ipft,ileaf)*cpatch%f_sun(ican,ipft,ileaf)*cpatch%area * AREA_INV - - hio_laisha_clllpf(io_si,cnlfpft_indx) = hio_laisha_clllpf(io_si,cnlfpft_indx) + & - cpatch%elai_profile(ican,ipft,ileaf)*(1._r8-cpatch%f_sun(ican,ipft,ileaf))*cpatch%area * AREA_INV - - hio_parprof_dir_si_cnlfpft(io_si,cnlfpft_indx) = hio_parprof_dir_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%parprof_pft_dir_z(ican,ipft,ileaf) * cpatch%total_canopy_area * site_area_veg_inv + do_pft: do ipft=1,numpft + do_canlev: do ican=1,cpatch%ncl_p + do_leaflev: do ileaf=1,cpatch%ncan(ican,ipft) + + ! calculate where we are on multiplexed dimensions + clllpf_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax + cnlf_indx = ileaf + (ican-1) * nlevleaf + + ! canopy_area_profile is the fraction of the total canopy area that + ! is occupied by this bin. If you add up the top leaf layer bins in the + ! top canopy layers, for all pfts, that should equal to 1 + + clllpf_area = cpatch%canopy_area_profile(ican,ipft,ileaf)*cpatch%total_canopy_area + + hio_parsun_z_si_cnlfpft(io_si,clllpf_indx) = hio_parsun_z_si_cnlfpft(io_si,clllpf_indx) + & + cpatch%ed_parsun_z(ican,ipft,ileaf) * clllpf_area + + hio_parsha_z_si_cnlfpft(io_si,clllpf_indx) = hio_parsha_z_si_cnlfpft(io_si,clllpf_indx) + & + cpatch%ed_parsha_z(ican,ipft,ileaf) * clllpf_area + + ! elai_profile is the m2 of leaf inside the m2 of bin. - hio_parprof_dif_si_cnlfpft(io_si,cnlfpft_indx) = hio_parprof_dif_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%parprof_pft_dif_z(ican,ipft,ileaf) * cpatch%total_canopy_area * site_area_veg_inv - - ! The fractional area of Canopy layer and PFTs can be used - ! do upscale the CLLLPF properties - hio_crownfrac_clllpf(io_si,cnlfpft_indx) = hio_crownfrac_clllpf(io_si,cnlfpft_indx) + & - cpatch%canopy_area_profile(ican,ipft,ileaf) * cpatch%total_canopy_area * site_area_veg_inv - - ! summarize across all PFTs - ! ---------------------------------------------------------------------------- - hio_parprof_dir_si_cnlf(io_si,cnlf_indx) = hio_parprof_dir_si_cnlf(io_si,cnlf_indx) + & - cpatch%parprof_pft_dir_z(ican,ipft,ileaf) * cpatch%canopy_area_profile(ican,ipft,ileaf) * & - cpatch%total_canopy_area * site_area_veg_inv - - hio_parprof_dif_si_cnlf(io_si,cnlf_indx) = hio_parprof_dif_si_cnlf(io_si,cnlf_indx) + & - cpatch%parprof_pft_dif_z(ican,ipft,ileaf) * cpatch%canopy_area_profile(ican,ipft,ileaf) * & - cpatch%total_canopy_area * site_area_veg_inv - - hio_parsun_z_si_cnlf(io_si,cnlf_indx) = hio_parsun_z_si_cnlf(io_si,cnlf_indx) + & - cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%canopy_area_profile(ican,ipft,ileaf) * & - cpatch%total_canopy_area * site_area_veg_inv - - hio_parsha_z_si_cnlf(io_si,cnlf_indx) = hio_parsha_z_si_cnlf(io_si,cnlf_indx) + & - cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%canopy_area_profile(ican,ipft,ileaf) * & - cpatch%total_canopy_area * site_area_veg_inv + hio_laisun_clllpf(io_si, clllpf_indx) = hio_laisun_clllpf(io_si, clllpf_indx) + & + cpatch%elai_profile(ican,ipft,ileaf)*cpatch%f_sun(ican,ipft,ileaf)*clllpf_area + + hio_laisha_clllpf(io_si,clllpf_indx) = hio_laisha_clllpf(io_si,clllpf_indx) + & + cpatch%elai_profile(ican,ipft,ileaf)*(1._r8-cpatch%f_sun(ican,ipft,ileaf))*clllpf_area + + hio_parprof_dir_si_cnlfpft(io_si,clllpf_indx) = hio_parprof_dir_si_cnlfpft(io_si,clllpf_indx) + & + cpatch%parprof_pft_dir_z(ican,ipft,ileaf) * clllpf_area + + hio_parprof_dif_si_cnlfpft(io_si,clllpf_indx) = hio_parprof_dif_si_cnlfpft(io_si,clllpf_indx) + & + cpatch%parprof_pft_dif_z(ican,ipft,ileaf) * clllpf_area + + ! The fractional area of Canopy layer and PFTs can be used + ! do upscale the CLLLPF properties + hio_crownfrac_clllpf(io_si,clllpf_indx) = hio_crownfrac_clllpf(io_si,clllpf_indx) + & + clllpf_area + + ! summarize across all PFTs + ! ---------------------------------------------------------------------------- + hio_parprof_dir_si_cnlf(io_si,cnlf_indx) = hio_parprof_dir_si_cnlf(io_si,cnlf_indx) + & + cpatch%parprof_pft_dir_z(ican,ipft,ileaf) * clllpf_area + + hio_parprof_dif_si_cnlf(io_si,cnlf_indx) = hio_parprof_dif_si_cnlf(io_si,cnlf_indx) + & + cpatch%parprof_pft_dif_z(ican,ipft,ileaf) * clllpf_area - hio_laisun_z_si_cnlf(io_si,cnlf_indx) = hio_laisun_z_si_cnlf(io_si,cnlf_indx) + & - cpatch%f_sun(ican,ipft,ileaf)*cpatch%elai_profile(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_parsun_z_si_cnlf(io_si,cnlf_indx) = hio_parsun_z_si_cnlf(io_si,cnlf_indx) + & + cpatch%ed_parsun_z(ican,ipft,ileaf) * clllpf_area + + hio_parsha_z_si_cnlf(io_si,cnlf_indx) = hio_parsha_z_si_cnlf(io_si,cnlf_indx) + & + cpatch%ed_parsha_z(ican,ipft,ileaf) * clllpf_area - hio_laisha_z_si_cnlf(io_si,cnlf_indx) = hio_laisha_z_si_cnlf(io_si,cnlf_indx) + & - (1._r8-cpatch%f_sun(ican,ipft,ileaf))*cpatch%elai_profile(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_laisun_z_si_cnlf(io_si,cnlf_indx) = hio_laisun_z_si_cnlf(io_si,cnlf_indx) + & + cpatch%f_sun(ican,ipft,ileaf)*clllpf_area - hio_fabd_sun_si_cnlf(io_si,cnlf_indx) = hio_fabd_sun_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_fabd_sha_si_cnlf(io_si,cnlf_indx) = hio_fabd_sha_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_fabi_sun_si_cnlf(io_si,cnlf_indx) = hio_fabi_sun_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_fabi_sha_si_cnlf(io_si,cnlf_indx) = hio_fabi_sha_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_laisha_z_si_cnlf(io_si,cnlf_indx) = hio_laisha_z_si_cnlf(io_si,cnlf_indx) + & + (1._r8-cpatch%f_sun(ican,ipft,ileaf))*clllpf_area + + hio_fabd_sun_si_cnlf(io_si,cnlf_indx) = hio_fabd_sun_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabd_sha_si_cnlf(io_si,cnlf_indx) = hio_fabd_sha_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabi_sun_si_cnlf(io_si,cnlf_indx) = hio_fabi_sun_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabi_sha_si_cnlf(io_si,cnlf_indx) = hio_fabi_sha_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - end do do_leaflev + end do do_leaflev + ! ! summarize just the top leaf level across all PFTs, for each canopy level hio_parsun_top_si_can(io_si,ican) = hio_parsun_top_si_can(io_si,ican) + & cpatch%ed_parsun_z(ican,ipft,1) * cpatch%total_canopy_area * site_area_veg_inv hio_parsha_top_si_can(io_si,ican) = hio_parsha_top_si_can(io_si,ican) + & - cpatch%ed_parsha_z(ican,ipft,1) * cpatch%total_canopy_area * site_area_veg_inv + cpatch%ed_parsha_z(ican,ipft,1) * cpatch%total_canopy_area * site_area_veg_inv hio_laisun_top_si_can(io_si,ican) = hio_laisun_top_si_can(io_si,ican) + & cpatch%f_sun(ican,ipft,1)*cpatch%elai_profile(ican,ipft,1) * cpatch%area * AREA_INV @@ -5028,35 +5038,80 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep ! end do do_canlev end do do_pft - end if if_zenith + !end if if_zenith cpatch => cpatch%younger end do !patch loop + + + ! Set values that are not represented by canopy to ignore do ican = 1,nclmax - do ipft = 1,numpft - do ileaf = 1,nlevleaf - cnlfpft_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax - if( hio_crownfrac_clllpf(io_si,cnlfpft_indx) Date: Wed, 18 Oct 2023 12:11:25 -0400 Subject: [PATCH 144/250] Cleaning two-stream and radiation drivers to get correct history diagnostics zeroing and ignores --- main/FatesHistoryInterfaceMod.F90 | 243 +-- radiation/FatesRadiationDriveMod.F90 | 2144 +++++++++++++------------- 2 files changed, 1123 insertions(+), 1264 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 438b1e51b8..cdf50d8730 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -695,10 +695,6 @@ module FatesHistoryInterfaceMod integer :: ih_parsha_z_si_cnlf integer :: ih_laisun_z_si_cnlf integer :: ih_laisha_z_si_cnlf - integer :: ih_fabd_sun_si_cnlf - integer :: ih_fabd_sha_si_cnlf - integer :: ih_fabi_sun_si_cnlf - integer :: ih_fabi_sha_si_cnlf integer :: ih_ts_net_uptake_si_cnlf integer :: ih_crownarea_clll integer :: ih_parprof_dir_si_cnlf @@ -713,13 +709,6 @@ module FatesHistoryInterfaceMod integer :: ih_parprof_dif_si_cnlfpft integer :: ih_crownfrac_clllpf - - integer :: ih_fabd_sun_si_cnlfpft - integer :: ih_fabd_sha_si_cnlfpft - integer :: ih_fabi_sun_si_cnlfpft - integer :: ih_fabi_sha_si_cnlfpft - - ! indices to site x crown damage variables ! site x crown damage x pft x sizeclass ! site x crown damage x size class @@ -744,14 +733,10 @@ module FatesHistoryInterfaceMod integer :: ih_crownarea_ustory_damage_si ! indices to (site x canopy layer) variables - integer :: ih_parsun_top_si_can - integer :: ih_parsha_top_si_can - integer :: ih_laisun_top_si_can - integer :: ih_laisha_top_si_can - integer :: ih_fabd_sun_top_si_can - integer :: ih_fabd_sha_top_si_can - integer :: ih_fabi_sun_top_si_can - integer :: ih_fabi_sha_top_si_can + integer :: ih_parsun_si_can + integer :: ih_parsha_si_can + integer :: ih_laisun_si_can + integer :: ih_laisha_si_can integer :: ih_crownarea_cl ! indices to (patch age x fuel size class) variables @@ -4728,9 +4713,8 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep real(r8) :: site_area_veg_inv ! 1/area of the site that is not bare-ground integer :: ipa2 ! patch incrementer integer :: clllpf_indx, cnlf_indx, ipft, ican, ileaf ! more iterators and indices - - real(r8),allocatable :: clllpf_area_vec(:) ! total area for the cl x ll x pft bin across all patches - real(r8) :: clllpf_area ! total area for the cl x ll x pft bin + real(r8) :: clllpf_area ! area footprint (m2) for the current cl x ll x pft bin + real(r8) :: clpf_area ! area footprint (m2) for the cl x pft bin (ie top ll bin) type(fates_patch_type),pointer :: cpatch type(fates_cohort_type),pointer :: ccohort @@ -4773,33 +4757,18 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep hio_crownfrac_clllpf => this%hvars(ih_crownfrac_clllpf)%r82d, & hio_laisun_top_si_can => this%hvars(ih_laisun_top_si_can)%r82d, & hio_laisha_top_si_can => this%hvars(ih_laisha_top_si_can)%r82d, & - hio_fabd_sun_si_cnlfpft => this%hvars(ih_fabd_sun_si_cnlfpft)%r82d, & - hio_fabd_sha_si_cnlfpft => this%hvars(ih_fabd_sha_si_cnlfpft)%r82d, & - hio_fabi_sun_si_cnlfpft => this%hvars(ih_fabi_sun_si_cnlfpft)%r82d, & - hio_fabi_sha_si_cnlfpft => this%hvars(ih_fabi_sha_si_cnlfpft)%r82d, & - hio_fabd_sun_si_cnlf => this%hvars(ih_fabd_sun_si_cnlf)%r82d, & - hio_fabd_sha_si_cnlf => this%hvars(ih_fabd_sha_si_cnlf)%r82d, & - hio_fabi_sun_si_cnlf => this%hvars(ih_fabi_sun_si_cnlf)%r82d, & - hio_fabi_sha_si_cnlf => this%hvars(ih_fabi_sha_si_cnlf)%r82d, & hio_parprof_dir_si_cnlf => this%hvars(ih_parprof_dir_si_cnlf)%r82d, & hio_parprof_dif_si_cnlf => this%hvars(ih_parprof_dif_si_cnlf)%r82d, & hio_parprof_dir_si_cnlfpft => this%hvars(ih_parprof_dir_si_cnlfpft)%r82d, & hio_parprof_dif_si_cnlfpft => this%hvars(ih_parprof_dif_si_cnlfpft)%r82d, & - hio_fabd_sun_top_si_can => this%hvars(ih_fabd_sun_top_si_can)%r82d, & - hio_fabd_sha_top_si_can => this%hvars(ih_fabd_sha_top_si_can)%r82d, & - hio_fabi_sun_top_si_can => this%hvars(ih_fabi_sun_top_si_can)%r82d, & - hio_fabi_sha_top_si_can => this%hvars(ih_fabi_sha_top_si_can)%r82d, & - hio_parsun_top_si_can => this%hvars(ih_parsun_top_si_can)%r82d, & - hio_parsha_top_si_can => this%hvars(ih_parsha_top_si_can)%r82d ) + hio_parsun_si_can => this%hvars(ih_parsun_si_can)%r82d, & + hio_parsha_si_can => this%hvars(ih_parsha_si_can)%r82d ) ! Flush the relevant history variables call this%flush_hvars(nc,upfreq_in=upfreq_hifr_multi) dt_tstep_inv = 1.0_r8/dt_tstep - allocate(clllpf_area_vec(numpft*nlevcan*nlevleaf)) - - do_sites: do s = 1,nsites site_area_veg_inv = 0._r8 @@ -4820,7 +4789,6 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep patch_area_by_age(1:nlevage) = 0._r8 canopy_area_by_age(1:nlevage) = 0._r8 - clllpf_area_vec(:) = 0._r8 call this%zero_site_hvars(sites(s), upfreq_in=upfreq_hifr_multi) @@ -4943,11 +4911,13 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep ccohort => ccohort%taller enddo ! cohort loop + ! summarize radiation profiles through the canopy + ! -------------------------------------------------------------------- - do_pft: do ipft=1,numpft - do_canlev: do ican=1,cpatch%ncl_p - do_leaflev: do ileaf=1,cpatch%ncan(ican,ipft) + do_pft1: do ipft=1,numpft + do_canlev1: do ican=1,cpatch%ncl_p + do_leaflev1: do ileaf=1,cpatch%ncan(ican,ipft) ! calculate where we are on multiplexed dimensions clllpf_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax @@ -4959,6 +4929,8 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep clllpf_area = cpatch%canopy_area_profile(ican,ipft,ileaf)*cpatch%total_canopy_area + ! Canopy by leaf by pft level diagnostics + ! ------------------------------------------------------------------- hio_parsun_z_si_cnlfpft(io_si,clllpf_indx) = hio_parsun_z_si_cnlfpft(io_si,clllpf_indx) + & cpatch%ed_parsun_z(ican,ipft,ileaf) * clllpf_area @@ -4984,7 +4956,8 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep hio_crownfrac_clllpf(io_si,clllpf_indx) = hio_crownfrac_clllpf(io_si,clllpf_indx) + & clllpf_area - ! summarize across all PFTs + + ! Canopy by leaf layer (mean across pfts) level diagnostics ! ---------------------------------------------------------------------------- hio_parprof_dir_si_cnlf(io_si,cnlf_indx) = hio_parprof_dir_si_cnlf(io_si,cnlf_indx) + & cpatch%parprof_pft_dir_z(ican,ipft,ileaf) * clllpf_area @@ -5003,55 +4976,39 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep hio_laisha_z_si_cnlf(io_si,cnlf_indx) = hio_laisha_z_si_cnlf(io_si,cnlf_indx) + & (1._r8-cpatch%f_sun(ican,ipft,ileaf))*clllpf_area + + ! Canopy mean diagnostics + ! -------------------------------------------------------------- - hio_fabd_sun_si_cnlf(io_si,cnlf_indx) = hio_fabd_sun_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_fabd_sha_si_cnlf(io_si,cnlf_indx) = hio_fabd_sha_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_fabi_sun_si_cnlf(io_si,cnlf_indx) = hio_fabi_sun_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_fabi_sha_si_cnlf(io_si,cnlf_indx) = hio_fabi_sha_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - - end do do_leaflev - - ! - ! summarize just the top leaf level across all PFTs, for each canopy level - hio_parsun_top_si_can(io_si,ican) = hio_parsun_top_si_can(io_si,ican) + & - cpatch%ed_parsun_z(ican,ipft,1) * cpatch%total_canopy_area * site_area_veg_inv - hio_parsha_top_si_can(io_si,ican) = hio_parsha_top_si_can(io_si,ican) + & - cpatch%ed_parsha_z(ican,ipft,1) * cpatch%total_canopy_area * site_area_veg_inv + hio_parsun_si_can(io_si,ican) = hio_parsun_si_can(io_si,ican) + & + cpatch%ed_parsun_z(ican,ipft,ileaf) * clllpf_area + hio_parsha_si_can(io_si,ican) = hio_parsha_si_can(io_si,ican) + & + cpatch%ed_parsha_z(ican,ipft,ileaf) * clllpf_area - hio_laisun_top_si_can(io_si,ican) = hio_laisun_top_si_can(io_si,ican) + & - cpatch%f_sun(ican,ipft,1)*cpatch%elai_profile(ican,ipft,1) * cpatch%area * AREA_INV - hio_laisha_top_si_can(io_si,ican) = hio_laisha_top_si_can(io_si,ican) + & - (1._r8-cpatch%f_sun(ican,ipft,1))*cpatch%elai_profile(ican,ipft,1) * cpatch%area * AREA_INV + hio_laisun_si_can(io_si,ican) = hio_laisun_si_can(io_si,ican) + & + cpatch%f_sun(ican,ipft,ileaf)*cpatch%elai_profile(ican,ipft,ileaf) * clllpf_area + hio_laisha_si_can(io_si,ican) = hio_laisha_si_can(io_si,ican) + & + (1._r8-cpatch%f_sun(ican,ipft,ileaf))*cpatch%elai_profile(ican,ipft,ileaf) * clllpf_area + - hio_fabd_sun_top_si_can(io_si,ican) = hio_fabd_sun_top_si_can(io_si,ican) + & - cpatch%fabd_sun_z(ican,ipft,1) * cpatch%area * AREA_INV - hio_fabd_sha_top_si_can(io_si,ican) = hio_fabd_sha_top_si_can(io_si,ican) + & - cpatch%fabd_sha_z(ican,ipft,1) * cpatch%area * AREA_INV - hio_fabi_sun_top_si_can(io_si,ican) = hio_fabi_sun_top_si_can(io_si,ican) + & - cpatch%fabi_sun_z(ican,ipft,1) * cpatch%area * AREA_INV - hio_fabi_sha_top_si_can(io_si,ican) = hio_fabi_sha_top_si_can(io_si,ican) + & - cpatch%fabi_sha_z(ican,ipft,1) * cpatch%area * AREA_INV - ! - end do do_canlev - end do do_pft - !end if if_zenith + end do do_leaflev1 + end do do_canlev1 + end do do_pft1 cpatch => cpatch%younger end do !patch loop + ! Normalize the radiation multiplexed diagnostics + ! Set values that dont have canopy elements to ignore + ! ---------------------------------------------------------------------------- + do_ican2: do ican = 1,nclmax - - ! Set values that are not represented by canopy to ignore - do ican = 1,nclmax - do ileaf = 1,nlevleaf + cl_area = 0._r8 + do_ileaf2: do ileaf = 1,nlevleaf - clll_area = 0. - do ipft = 1,numpft + clll_area = 0._r8 + do_ipft2: do ipft = 1,numpft clllpf_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax if( hio_crownfrac_clllpf(io_si,clllpf_indx) sites(s)%oldest_patch do while (associated(currentpatch)) + + ! Zero diagnostics + currentPatch%f_sun (:,:,:) = 0._r8 + currentPatch%fabd_sun_z (:,:,:) = 0._r8 + currentPatch%fabd_sha_z (:,:,:) = 0._r8 + currentPatch%fabi_sun_z (:,:,:) = 0._r8 + currentPatch%fabi_sha_z (:,:,:) = 0._r8 + currentPatch%fabd (:) = 0._r8 + currentPatch%fabi (:) = 0._r8 + currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 + + !cpatch%ed_parsun_z(ican,ipft,ileaf) + if_notbareground: if(currentpatch%nocomp_pft_label.ne.nocomp_bareground)then ! do not do albedo calculations for bare ground patch in SP mode ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein ! ifp=1 is the first vegetated patch. ifp = ifp+1 - currentPatch%f_sun (:,:,:) = 0._r8 - currentPatch%fabd_sun_z (:,:,:) = 0._r8 - currentPatch%fabd_sha_z (:,:,:) = 0._r8 - currentPatch%fabi_sun_z (:,:,:) = 0._r8 - currentPatch%fabi_sha_z (:,:,:) = 0._r8 - currentPatch%fabd (:) = 0._r8 - currentPatch%fabi (:) = 0._r8 - - ! zero diagnostic radiation profiles - currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 - currentPatch%solar_zenith_flag = bc_in(s)%filter_vegzen_pa(ifp) currentPatch%solar_zenith_angle = bc_in(s)%coszen_pa(ifp) currentPatch%gnd_alb_dif(1:hlm_numSWb) = bc_in(s)%albgr_dif_rb(1:hlm_numSWb) currentPatch%gnd_alb_dir(1:hlm_numSWb) = bc_in(s)%albgr_dir_rb(1:hlm_numSWb) currentPatch%fcansno = bc_in(s)%fcansno_pa(ifp) + currentPatch%solve_err(:) = hlm_hio_ignore_val + currentPatch%consv_err(:) = hlm_hio_ignore_val - currentPatch%solve_err(:) = hlm_hio_ignore_val - currentPatch%consv_err(:) = hlm_hio_ignore_val - - ! RGK: The ZenithPrep should only be necessary if the flag is true - ! Move and test this. if(radiation_model.eq.twostr_solver) then call currentPatch%twostr%CanopyPrep(bc_in(s)%fcansno_pa(ifp)) call currentPatch%twostr%ZenithPrep(bc_in(s)%coszen_pa(ifp)) end if - if_zenith_flag: if(currentPatch%solar_zenith_flag )then + if_zenith_flag: if(.not.currentPatch%solar_zenith_flag )then + + ! Sun below horizon, trivial solution + ! Note (RGK-MLO): Investigate twilight mechanics for + ! non-zero diffuse radiation when cosz<=0 + + bc_out(s)%albd_parb(ifp,:) = 1._r8 + bc_out(s)%albi_parb(ifp,:) = 1._r8 + bc_out(s)%fabi_parb(ifp,:) = 0._r8 + bc_out(s)%fabd_parb(ifp,:) = 0._r8 + bc_out(s)%ftdd_parb(ifp,:) = 0._r8 + bc_out(s)%ftid_parb(ifp,:) = 0._r8 + bc_out(s)%ftii_parb(ifp,:) = 0._r8 + + else if_nrad: if (maxval(currentPatch%nrad(1,:))==0)then - !there are no leaf layers in this patch. it is effectively bare ground. + ! there are no leaf layers in this patch. it is effectively bare ground. ! no radiation is absorbed currentPatch%radiation_error = 0.0_r8 @@ -148,11 +160,11 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) bc_out(s)%fabd_parb(ifp,ib) = 0.0_r8 bc_out(s)%fabi_parb(ifp,ib) = 0.0_r8 - bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 - bc_out(s)%ftid_parb(ifp,ib)= 0.0_r8 - bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 + bc_out(s)%ftdd_parb(ifp,ib) = 1.0_r8 + bc_out(s)%ftid_parb(ifp,ib) = 0.0_r8 + bc_out(s)%ftii_parb(ifp,ib) = 1.0_r8 enddo - + else if_solver: if(radiation_model.eq.norman_solver) then @@ -177,7 +189,7 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) twostr%band(ib)%albedo_grnd_diff = bc_in(s)%albgr_dif_rb(ib) twostr%band(ib)%albedo_grnd_beam = bc_in(s)%albgr_dir_rb(ib) - + call twostr%Solve(ib, & ! in normalized_upper_boundary, & ! in 1.0_r8,1.0_r8, & ! in @@ -201,7 +213,7 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) ib, bc_out(s)%fabd_parb(ifp,ib),bc_out(s)%fabi_parb(ifp,ib)) currentPatch%twostr%band(ib)%Rbeam_atm = fates_unset_r8 currentPatch%twostr%band(ib)%Rdiff_atm = fates_unset_r8 - + if(bc_out(s)%fabi_parb(ifp,ib)>1.0 .or. bc_out(s)%fabd_parb(ifp,ib)>1.0)then write(fates_log(),*) 'absorbed fraction > 1.0?' write(fates_log(),*) ifp,ib,bc_out(s)%fabi_parb(ifp,ib),bc_out(s)%fabd_parb(ifp,ib) @@ -215,17 +227,10 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) end if if_solver end if if_nrad - else - bc_out(s)%albd_parb(ifp,:) = 1._r8 - bc_out(s)%albi_parb(ifp,:) = 1._r8 - bc_out(s)%fabi_parb(ifp,:) = 0._r8 - bc_out(s)%fabd_parb(ifp,:) = 0._r8 - bc_out(s)%ftdd_parb(ifp,:) = 0._r8 - bc_out(s)%ftid_parb(ifp,:) = 0._r8 - bc_out(s)%ftii_parb(ifp,:) = 0._r8 + endif if_zenith_flag end if if_notbareground - + currentPatch => currentPatch%younger end do ! Loop linked-list patches enddo ! Loop Sites @@ -337,1098 +342,1049 @@ subroutine PatchNormanRadiation (currentPatch, & ! Initialize local arrays - weighted_dir_tr(:) = 0._r8 - weighted_dif_down(:) = 0._r8 - weighted_dif_up(:) = 0._r8 - - tr_dir_z(:,:,:) = 0._r8 - tr_dif_z(:,:,:) = 0._r8 - lai_change(:,:,:) = 0._r8 - Dif_up(:,:,:) = 0._r8 - Dif_dn(:,:,:) = 0._r8 - refl_dif(:,:,:,:) = 0.0_r8 - tran_dif(:,:,:,:) = 0.0_r8 - dif_ratio(:,:,:,:) = 0.0_r8 - - - ! Initialize the ouput arrays - ! --------------------------------------------------------------------------------- - albd_parb_out(1:hlm_numSWb) = 0.0_r8 - albi_parb_out(1:hlm_numSWb) = 0.0_r8 - fabd_parb_out(1:hlm_numSWb) = 0.0_r8 - fabi_parb_out(1:hlm_numSWb) = 0.0_r8 - ftdd_parb_out(1:hlm_numSWb) = 1.0_r8 - ftid_parb_out(1:hlm_numSWb) = 1.0_r8 - ftii_parb_out(1:hlm_numSWb) = 1.0_r8 - - ! Is this pft/canopy layer combination present in this patch? - rho_layer(:,:,:,:)=0.0_r8 - tau_layer(:,:,:,:)=0.0_r8 - f_abs(:,:,:,:)=0.0_r8 - f_abs_leaf(:,:,:,:)=0._r8 - do L = 1,nclmax - do ft = 1,numpft - currentPatch%canopy_mask(L,ft) = 0 - do iv = 1, currentPatch%nrad(L,ft) - if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then - currentPatch%canopy_mask(L,ft) = 1 - - if(currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv).gt.0.0_r8) then - frac_lai = currentPatch%elai_profile(L,ft,iv)/& - (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) + weighted_dir_tr(:) = 0._r8 + weighted_dif_down(:) = 0._r8 + weighted_dif_up(:) = 0._r8 + + tr_dir_z(:,:,:) = 0._r8 + tr_dif_z(:,:,:) = 0._r8 + lai_change(:,:,:) = 0._r8 + Dif_up(:,:,:) = 0._r8 + Dif_dn(:,:,:) = 0._r8 + refl_dif(:,:,:,:) = 0.0_r8 + tran_dif(:,:,:,:) = 0.0_r8 + dif_ratio(:,:,:,:) = 0.0_r8 + + + ! Initialize the ouput arrays + ! --------------------------------------------------------------------------------- + albd_parb_out(1:hlm_numSWb) = 0.0_r8 + albi_parb_out(1:hlm_numSWb) = 0.0_r8 + fabd_parb_out(1:hlm_numSWb) = 0.0_r8 + fabi_parb_out(1:hlm_numSWb) = 0.0_r8 + ftdd_parb_out(1:hlm_numSWb) = 1.0_r8 + ftid_parb_out(1:hlm_numSWb) = 1.0_r8 + ftii_parb_out(1:hlm_numSWb) = 1.0_r8 + + ! Is this pft/canopy layer combination present in this patch? + rho_layer(:,:,:,:)=0.0_r8 + tau_layer(:,:,:,:)=0.0_r8 + f_abs(:,:,:,:)=0.0_r8 + f_abs_leaf(:,:,:,:)=0._r8 + do L = 1,nclmax + do ft = 1,numpft + currentPatch%canopy_mask(L,ft) = 0 + do iv = 1, currentPatch%nrad(L,ft) + if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then + currentPatch%canopy_mask(L,ft) = 1 + + if(currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv).gt.0.0_r8) then + frac_lai = currentPatch%elai_profile(L,ft,iv)/& + (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) + else + frac_lai = 1.0_r8 + endif + !frac_lai = 1.0_r8 ! make the same as previous codebase, in theory. + frac_sai = 1.0_r8 - frac_lai + + ! layer level reflectance qualities + do ib = 1,hlm_numSWb !vis, nir + + rho_layer(L,ft,iv,ib)=frac_lai*rhol(ft,ib)+frac_sai*rhos(ft,ib) + tau_layer(L,ft,iv,ib)=frac_lai*taul(ft,ib)+frac_sai*taus(ft,ib) + + ! adjust reflectance and transmittance for canopy snow + rho_layer(L,ft,iv,ib)=rho_layer(L,ft,iv,ib)*(1.0_r8- currentPatch%fcansno) & + + rho_snow(ib) * currentPatch%fcansno + tau_layer(L,ft,iv,ib)=tau_layer(L,ft,iv,ib)*(1.0_r8- currentPatch%fcansno) & + + tau_snow(ib) * currentPatch%fcansno + + ! fraction of incoming light absorbed by leaves or stems. + f_abs(L,ft,iv,ib) = 1.0_r8 - tau_layer(L,ft,iv,ib) - rho_layer(L,ft,iv,ib) + + ! the fraction of the vegetation absorbed light which is absorbed by leaves + f_abs_leaf(L,ft,iv,ib) = (1.0_r8- currentPatch%fcansno) * frac_lai* & + (1.0_r8 - rhol(ft,ib) - taul(ft,ib))/f_abs(L,ft,iv,ib) + + end do !ib + endif + end do !iv + end do !ft + end do !L + + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Direct beam extinction coefficient, k_dir. PFT specific. + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + cosz = max(0.001_r8, currentPatch%solar_zenith_angle ) !copied from previous radiation code... + do ft = 1,numpft + sb = (90._r8 - (acos(cosz)*180._r8/pi_const)) * (pi_const / 180._r8) + phi1b(ft) = 0.5_r8 - 0.633_r8*xl(ft) - 0.330_r8*xl(ft)*xl(ft) + phi2b(ft) = 0.877_r8 * (1._r8 - 2._r8*phi1b(ft)) !0 = horiz leaves, 1 - vert leaves. + gdir = phi1b(ft) + phi2b(ft) * sin(sb) + !how much direct light penetrates a singleunit of lai? + k_dir(ft) = clumping_index(ft) * gdir / sin(sb) + end do !ft + + + + + !do this once for one unit of diffuse, and once for one unit of direct radiation + do radtype = 1, num_rad_stream_types + + ! Extract information that needs to be provided by ED into local array. + ! RGK: NOT SURE WHY WE NEED FTWEIGHT ... + ! ------------------------------------------------------------------------------ + + ftweight(:,:,:) = 0._r8 + do L = 1,currentPatch%ncl_p + do ft = 1,numpft + do iv = 1, currentPatch%nrad(L,ft) + !this is already corrected for area in CLAP + ftweight(L,ft,iv) = currentPatch%canopy_area_profile(L,ft,iv) + end do !iv + end do !ft1 + end do !L + + if(debug)then + if (sum(ftweight(1,:,1))<0.999_r8)then + write(fates_log(),*) 'canopy not full',ftweight(1,:,1) + endif + if (sum(ftweight(1,:,1))>1.0001_r8)then + write(fates_log(),*) 'canopy too full',ftweight(1,:,1) + endif + end if + + do L = 1,currentPatch%ncl_p !start at the top canopy layer (1 is the top layer.) + + weighted_dir_tr(L) = 0.0_r8 + weighted_fsun(L) = 0._r8 + weighted_dif_ratio(L,1:hlm_numSWb) = 0._r8 + + !Each canopy layer (canopy, understorey) has multiple 'parallel' pft's + + do ft =1,numpft + + if (currentPatch%canopy_mask(L,ft) == 1)then !only do calculation if there are the appropriate leaves. + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Diffuse transmittance, tr_dif, do each layer with thickness elai_z. + ! Estimated do nine sky angles in increments of 10 degrees + ! PFT specific... + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + tr_dif_z(L,ft,:) = 0._r8 + do iv = 1,currentPatch%nrad(L,ft) + do j = 1,9 + angle = (5._r8 + real(j - 1,r8) * 10._r8) * pi_const / 180._r8 + gdir = phi1b(ft) + phi2b(ft) * sin(angle) + tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-clumping_index(ft) * & + gdir / sin(angle) * & + (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))) * & + sin(angle)*cos(angle) + end do + + tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) * 2._r8 * (10._r8 * pi_const / 180._r8) + + end do + + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Direct beam transmittance, tr_dir_z, uses cumulative LAI above layer J to give + ! unscattered direct beam onto layer J. do each PFT section. + ! This is just an decay curve based on k_dir. (leaf & sun angle) + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + if (L==1)then + tr_dir_z(L,ft,1) = 1._r8 + else + tr_dir_z(L,ft,1) = weighted_dir_tr(L-1) + endif + laisum = 0.00_r8 + !total direct beam getting to the bottom of the top canopy. + do iv = 1,currentPatch%nrad(L,ft) + laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) + lai_change(L,ft,iv) = 0.0_r8 + if (( ftweight(L,ft,iv+1) > 0.0_r8 ) .and. ( ftweight(L,ft,iv+1) < ftweight(L,ft,iv) ))then + !where there is a partly empty leaf layer, some fluxes go straight through. + lai_change(L,ft,iv) = ftweight(L,ft,iv)-ftweight(L,ft,iv+1) + endif + if(debug)then + if (ftweight(L,ft,iv+1) - ftweight(L,ft,iv) > 1.e-10_r8)then + write(fates_log(),*) 'lower layer has more coverage. This is wrong' , & + ftweight(L,ft,iv),ftweight(L,ft,iv+1),ftweight(L,ft,iv+1)-ftweight(L,ft,iv) + endif + end if + + !n.b. in theory lai_change could be calculated daily in the ED code. + !This is light coming striaght through the canopy. + if (L==1)then + tr_dir_z(L,ft,iv+1) = exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + else + tr_dir_z(L,ft,iv+1) = weighted_dir_tr(L-1)*exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + endif + + if (iv == 1)then + !this is the top layer. + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & + ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) + else + !the lai_change(iv) affects the light incident on layer iv+2 not iv+1 + ! light coming from the layer above (iv-1) goes through iv and onto iv+1. + if (lai_change(L,ft,iv-1) > 0.0_r8)then + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv)* & + lai_change(L,ft,iv-1) / ftweight(L,ft,1) + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv-1)* & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) + else + !account fot the light that comes striaght down from unfilled layers above. + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & + ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) + endif + endif + + end do + + !add up all the weighted contributions from the different PFT columns. + weighted_dir_tr(L) = weighted_dir_tr(L) + tr_dir_z(L,ft,currentPatch%nrad(L,ft)+1)*ftweight(L,ft,1) + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Sunlit and shaded fraction of leaf layer + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + + !laisum = 0._r8 + do iv = 1,currentPatch%nrad(L,ft) + ! Cumulative leaf area. Original code uses cumulative lai do layer. + ! Now use cumulative lai at center of layer. + ! Same as tr_dir_z calcualtions, but in the middle of the layer? FIX(RF,032414)-WHY? + if (iv == 1) then + laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) + else + laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) + end if + + + if (L == 1)then !top canopy layer + currentPatch%f_sun(L,ft,iv) = exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + else + currentPatch%f_sun(L,ft,iv) = weighted_fsun(L-1)* exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + endif + + if ( iv > 1 ) then ! becasue we are looking at this layer (not the next) + ! we only ever add fluxes if iv>1 + if (lai_change(L,ft,iv-1) > 0.0_r8)then + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv) * & + lai_change(L,ft,iv-1)/ftweight(L,ft,1) + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv-1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) + else + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv-1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif + endif + + end do !iv + + weighted_fsun(L) = weighted_fsun(L) + currentPatch%f_sun(L,ft,currentPatch%nrad(L,ft))* & + ftweight(L,ft,1) + + ! instance where the first layer ftweight is used a proxy for the whole column. FTWA + ! this is possibly a source of slight error. If we use the ftweight at the top of the PFT column, + ! then we willl underestimate fsun, but if we use ftweight at the bottom of the column, we will + ! underestimate it. Really, we should be tracking the release of direct light from the column as it tapers + ! towards the ground. Is that necessary to get energy closure? It would be quite hard... + endif !present. + end do!pft loop + end do !L + + + do L = currentPatch%ncl_p,1, -1 !start at the bottom and work up. + do ft = 1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + + !==============================================================================! + ! Iterative solution do scattering + !==============================================================================! + + do ib = 1,hlm_numSWb !vis, nir + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Leaf scattering coefficient and terms do diffuse radiation reflected + ! and transmitted by a layer + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + + do iv = 1,currentPatch%nrad(L,ft) + !How much diffuse light is intercepted and then reflected? + refl_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * rho_layer(L,ft,iv,ib) + !How much diffuse light in this layer is transmitted? + tran_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * & + tau_layer(L,ft,iv,ib) + tr_dif_z(L,ft,iv) + end do + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Ratio of upward to forward diffuse fluxes, dif_ratio + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Soil diffuse reflectance (ratio of down to up radiation). + iv = currentPatch%nrad(L,ft) + 1 + if (L == currentPatch%ncl_p)then !nearest the soil + dif_ratio(L,ft,iv,ib) = currentPatch%gnd_alb_dif(ib) !bc_in(s)%albgr_dif_rb(ib) + else + dif_ratio(L,ft,iv,ib) = weighted_dif_ratio(L+1,ib) + end if + ! Canopy layers, working upwardfrom soil with dif_ratio(iv+1) known + ! FIX(RF,032414) ray tracing eqution - need to find derivation of this... + ! for each unit going down, there are x units going up. + do iv = currentPatch%nrad(L,ft),1, -1 + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv+1,ib) * & + tran_dif(L,ft,iv,ib)*tran_dif(L,ft,iv,ib) / & + (1._r8 - dif_ratio(L,ft,iv+1,ib) * refl_dif(L,ft,iv,ib)) & + + refl_dif(L,ft,iv,ib) + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) * & + ftweight(L,ft,iv)/ftweight(L,ft,1) + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) + dif_ratio(L,ft,iv+1,ib) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + end do + weighted_dif_ratio(L,ib) = weighted_dif_ratio(L,ib) + & + dif_ratio(L,ft,1,ib) * ftweight(L,ft,1) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + end do!hlm_numSWb + endif ! currentPatch%canopy_mask + end do!ft + end do!L + + ! Zero out the radiation error for the current patch before conducting the conservation check + currentPatch%radiation_error = 0.0_r8 + + do ib = 1,hlm_numSWb + Dif_dn(:,:,:) = 0.00_r8 + Dif_up(:,:,:) = 0.00_r8 + do L = 1, currentPatch%ncl_p !work down from the top of the canopy. + weighted_dif_down(L) = 0._r8 + do ft = 1, numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! First estimates do downward and upward diffuse flux + ! + ! Dif_dn = forward diffuse flux onto layer J + ! Dif_up = Upward diffuse flux above layer J + ! + ! Solved here without direct beam radiation and using dif_ratio = Dif_up / Dif_dn + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! downward diffuse flux onto the top surface of the canopy + + if (L == 1)then + Dif_dn(L,ft,1) = forc_dif(radtype) + else + Dif_dn(L,ft,1) = weighted_dif_down(L-1) + end if + ! forward diffuse flux within the canopy and at soil, working forward through canopy + do iv = 1,currentPatch%nrad(L,ft) + denom = refl_dif(L,ft,iv,ib) * dif_ratio(L,ft,iv,ib) + denom = 1._r8 - denom + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) / & + denom *ftweight(L,ft,iv)/ftweight(L,ft,1) + if (iv > 1)then + if (lai_change(L,ft,iv-1) > 0.0_r8)then + !here we are thinking about whether the layer above had an laichange, + !but calculating the flux onto the layer below. + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv)* & + lai_change(L,ft,iv-1)/ftweight(L,ft,1) + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv-1)* & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1)/ftweight(L,ft,1)) + else + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif + else + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif + end do + + weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & + ftweight(L,ft,1) + + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif !present + end do !ft + if (L == currentPatch%ncl_p.and.currentPatch%ncl_p > 1)then !is the the (incomplete) understorey? + !Add on the radiation going through the canopy gaps. + weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1)*(1.0-sum(ftweight(L,:,1))) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif + end do !L + + do L = currentPatch%ncl_p,1 ,-1 !work up from the bottom. + weighted_dif_up(L) = 0._r8 + do ft = 1, numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + !Bounce diffuse radiation off soil surface. + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%ncl_p)then !is this the bottom layer ? + Dif_up(L,ft,iv) = currentPatch%gnd_alb_dif(ib) * Dif_dn(L,ft,iv) + else + Dif_up(L,ft,iv) = weighted_dif_up(L+1) + end if + ! Upward diffuse flux within the canopy and above the canopy, working upward through canopy + + do iv = currentPatch%nrad(L,ft), 1, -1 + if (lai_change(L,ft,iv) > 0.0_r8)then + Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * & + ftweight(L,ft,iv) / ftweight(L,ft,1) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & + tran_dif(L,ft,iv,ib) * lai_change(L,ft,iv)/ftweight(L,ft,1) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + !nb is this the right constuction? + ! the radiation that hits the empty space is not reflected. + else + Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * ftweight(L,ft,iv) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * (1.0_r8-ftweight(L,ft,iv)) + endif + end do + weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif !present + end do !ft + if (L == currentPatch%ncl_p.and.currentPatch%ncl_p > 1)then !is this the (incomplete) understorey? + !Add on the radiation coming up through the canopy gaps. + !diffuse to diffuse + weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & + weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) + !direct to diffuse + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & + weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) * currentPatch%gnd_alb_dir(ib) + endif + end do !L + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! 3. Iterative calculation of forward and upward diffuse fluxes, incl_puding + ! scattered direct beam + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + + ! Flag to exit iteration loop: 0 = exit and 1 = iterate + irep = 1 + ! Iteration loop + iter = 0 + do while(irep ==1 .and. iter<50) + + iter = iter + 1 + irep = 0 + do L = 1,currentPatch%ncl_p !working from the top down + weighted_dif_down(L) = 0._r8 + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + ! forward diffuse flux within the canopy and at soil, working forward through canopy + ! with Dif_up -from previous iteration-. Dif_dn(1) is the forward diffuse flux onto the canopy. + ! Note: down = forward flux onto next layer + if (L == 1)then !is this the top layer? + Dif_dn(L,ft,1) = forc_dif(radtype) + else + Dif_dn(L,ft,1) = weighted_dif_down(L-1) + end if + down_rad = 0._r8 + + do iv = 1, currentPatch%nrad(L,ft) + ! down rad'n is the sum of the down and upwards reflected diffuse fluxes... + down_rad = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) + & + Dif_up(L,ft,iv+1) * refl_dif(L,ft,iv,ib) + + !... plus the direct beam intercepted and intransmitted by this layer. + down_rad = down_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - & + exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & + currentPatch%esai_profile(L,ft,iv)) )) * tau_layer(L,ft,iv,ib) + + + !... plus the direct beam intercepted and intransmitted by this layer. + ! modified to spread it out over the whole of incomplete layers. + + down_rad = down_rad *(ftweight(L,ft,iv)/ftweight(L,ft,1)) + + if (iv > 1)then + if (lai_change(L,ft,iv-1) > 0.0_r8)then + down_rad = down_rad + Dif_dn(L,ft,iv) * lai_change(L,ft,iv-1)/ftweight(L,ft,1) + down_rad = down_rad + Dif_dn(L,ft,iv-1) * (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ & + ftweight(L,ft,1) + else + down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & + ftweight(L,ft,1) + endif + else + down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & + ftweight(L,ft,1) + endif + + !this is just Dif down, plus refl up, plus dir intercepted and turned into dif... , + if (abs(down_rad - Dif_dn(L,ft,iv+1)) > tolerance)then + irep = 1 + end if + Dif_dn(L,ft,iv+1) = down_rad + + end do !iv + + weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & + ftweight(L,ft,1) + + endif !present + end do!ft + if (L == currentPatch%ncl_p.and.currentPatch%ncl_p > 1)then !is this the (incomplete) understorey? + weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1) * & + (1.0_r8-sum(ftweight(L,1:numpft,1))) + end if + end do ! do L loop + + do L = 1, currentPatch%ncl_p ! working from the top down. + weighted_dif_up(L) = 0._r8 + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + ! Upward diffuse flux at soil or from lower canopy (forward diffuse and unscattered direct beam) + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%ncl_p)then !In the bottom canopy layer, reflect off the soil + Dif_up(L,ft,iv) = Dif_dn(L,ft,iv) * currentPatch%gnd_alb_dif(ib) + & + forc_dir(radtype) * tr_dir_z(L,ft,iv) * currentPatch%gnd_alb_dir(ib) + else !In the other canopy layers, reflect off the underlying vegetation. + Dif_up(L,ft,iv) = weighted_dif_up(L+1) + end if + + ! Upward diffuse flux within and above the canopy, working upward through canopy + ! with Dif_dn from previous interation. Note: up = upward flux above current layer + do iv = currentPatch%nrad(L,ft),1,-1 + !this is radiation up, by layer transmittance, by + + !reflection of the lower layer, + up_rad = Dif_dn(L,ft,iv) * refl_dif(L,ft,iv,ib) + up_rad = up_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - exp(-k_dir(ft) * & + (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))))* & + rho_layer(L,ft,iv,ib) + up_rad = up_rad + Dif_up(L,ft,iv+1) * tran_dif(L,ft,iv,ib) + up_rad = up_rad * ftweight(L,ft,iv)/ftweight(L,ft,1) + up_rad = up_rad + Dif_up(L,ft,iv+1) *(ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + ! THE LOWER LAYER FLUX IS HOMOGENIZED, SO WE DON"T CONSIDER THE LAI_CHANGE HERE... + + if (abs(up_rad - Dif_up(L,ft,iv)) > tolerance) then !are we close to the tolerance level? + irep = 1 + end if + Dif_up(L,ft,iv) = up_rad + + end do !iv + weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) + end if !present + end do!ft + + if (L == currentPatch%ncl_p.and.currentPatch%ncl_p > 1)then !is this the (incomplete) understorey? + !Add on the radiation coming up through the canopy gaps. + weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & + weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & + weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1)))*currentPatch%gnd_alb_dir(ib) + end if + end do!L + end do ! do while over iter + + abs_rad(ib) = 0._r8 + tr_soili = 0._r8 + tr_soild = 0._r8 + + do L = 1, currentPatch%ncl_p !working from the top down. + abs_dir_z(:,:) = 0._r8 + abs_dif_z(:,:) = 0._r8 + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + !==============================================================================! + ! Compute absorbed flux densities + !==============================================================================! + + ! Absorbed direct beam and diffuse do leaf layers + do iv = 1, currentPatch%nrad(L,ft) + Abs_dir_z(ft,iv) = ftweight(L,ft,iv)* forc_dir(radtype) * tr_dir_z(L,ft,iv) * & + (1.00_r8 - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & + currentPatch%esai_profile(L,ft,iv)) )) * f_abs(L,ft,iv,ib) + Abs_dif_z(ft,iv) = ftweight(L,ft,iv)* ((Dif_dn(L,ft,iv) + & + Dif_up(L,ft,iv+1)) * (1.00_r8 - tr_dif_z(L,ft,iv)) * f_abs(L,ft,iv,ib)) + end do + + ! Absorbed direct beam and diffuse do soil + if (L == currentPatch%ncl_p)then + iv = currentPatch%nrad(L,ft) + 1 + Abs_dif_z(ft,iv) = ftweight(L,ft,1)*Dif_dn(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dif(ib) ) + Abs_dir_z(ft,iv) = ftweight(L,ft,1)*forc_dir(radtype) * & + tr_dir_z(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dir(ib) ) + tr_soild = tr_soild + ftweight(L,ft,1)*forc_dir(radtype) * tr_dir_z(L,ft,iv) + tr_soili = tr_soili + ftweight(L,ft,1)*Dif_dn(L,ft,iv) + end if + + ! Absorbed radiation, shaded and sunlit portions of leaf layers + !here we get one unit of diffuse radiation... how much of + !it is absorbed? + if (ib == ivis) then ! only set the absorbed PAR for the visible light band. + do iv = 1, currentPatch%nrad(L,ft) + if (radtype==idirect) then + if ( debug ) then + write(fates_log(),*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) + write(fates_log(),*) 'EDsurfAlb 731 ', currentPatch%fabd_sha_z(L,ft,iv), & + currentPatch%fabd_sun_z(L,ft,iv) + endif + currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + (1._r8 - currentPatch%f_sun(L,ft,iv))*f_abs_leaf(L,ft,iv,ib) + currentPatch%fabd_sun_z(L,ft,iv) =( Abs_dif_z(ft,iv) * & + currentPatch%f_sun(L,ft,iv) + & + Abs_dir_z(ft,iv))*f_abs_leaf(L,ft,iv,ib) + else + currentPatch%fabi_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + (1._r8 - currentPatch%f_sun(L,ft,iv))*f_abs_leaf(L,ft,iv,ib) + currentPatch%fabi_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + currentPatch%f_sun(L,ft,iv)*f_abs_leaf(L,ft,iv,ib) + endif + if ( debug ) then + write(fates_log(),*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & + currentPatch%fabd_sun_z(L,ft,iv) + endif + end do + endif ! ib + + + !==============================================================================! + ! Sum fluxes + !==============================================================================! + ! Solar radiation absorbed by ground + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%ncl_p)then + abs_rad(ib) = abs_rad(ib) + (Abs_dir_z(ft,iv) + Abs_dif_z(ft,iv)) + end if + ! Solar radiation absorbed by vegetation and sunlit/shaded leaves + do iv = 1,currentPatch%nrad(L,ft) + if (radtype == idirect)then + currentPatch%fabd(ib) = currentPatch%fabd(ib) + & + Abs_dir_z(ft,iv)+Abs_dif_z(ft,iv) + ! bc_out(s)%fabd_parb_out(ib) = currentPatch%fabd(ib) + else + currentPatch%fabi(ib) = currentPatch%fabi(ib) + Abs_dif_z(ft,iv) + ! bc_out(s)%fabi_parb_out(ib) = currentPatch%fabi(ib) + endif + end do + + ! Albefor + if (L==1)then !top canopy layer. + if (radtype == idirect)then + albd_parb_out(ib) = albd_parb_out(ib) + & + Dif_up(L,ft,1) * ftweight(L,ft,1) + else + albi_parb_out(ib) = albi_parb_out(ib) + & + Dif_up(L,ft,1) * ftweight(L,ft,1) + end if + end if + + ! pass normalized PAR profiles for use in diagnostic averaging for history fields + if (ib == ivis) then ! only diagnose PAR profiles for the visible band + do iv = 1, currentPatch%nrad(L,ft) + currentPatch%nrmlzd_parprof_pft_dir_z(radtype,L,ft,iv) = & + forc_dir(radtype) * tr_dir_z(L,ft,iv) + + currentPatch%nrmlzd_parprof_pft_dif_z(radtype,L,ft,iv) = & + Dif_dn(L,ft,iv) + Dif_up(L,ft,iv) + + end do + end if ! ib = visible + end if ! present + end do !ft + if (radtype == idirect)then + fabd_parb_out(ib) = currentPatch%fabd(ib) else - frac_lai = 1.0_r8 + fabi_parb_out(ib) = currentPatch%fabi(ib) endif - !frac_lai = 1.0_r8 ! make the same as previous codebase, in theory. - frac_sai = 1.0_r8 - frac_lai - - ! layer level reflectance qualities - do ib = 1,hlm_numSWb !vis, nir - - rho_layer(L,ft,iv,ib)=frac_lai*rhol(ft,ib)+frac_sai*rhos(ft,ib) - tau_layer(L,ft,iv,ib)=frac_lai*taul(ft,ib)+frac_sai*taus(ft,ib) - - ! adjust reflectance and transmittance for canopy snow - rho_layer(L,ft,iv,ib)=rho_layer(L,ft,iv,ib)*(1.0_r8- currentPatch%fcansno) & - + rho_snow(ib) * currentPatch%fcansno - tau_layer(L,ft,iv,ib)=tau_layer(L,ft,iv,ib)*(1.0_r8- currentPatch%fcansno) & - + tau_snow(ib) * currentPatch%fcansno - - ! fraction of incoming light absorbed by leaves or stems. - f_abs(L,ft,iv,ib) = 1.0_r8 - tau_layer(L,ft,iv,ib) - rho_layer(L,ft,iv,ib) - - ! the fraction of the vegetation absorbed light which is absorbed by leaves - f_abs_leaf(L,ft,iv,ib) = (1.0_r8- currentPatch%fcansno) * frac_lai* & - (1.0_r8 - rhol(ft,ib) - taul(ft,ib))/f_abs(L,ft,iv,ib) - - end do !ib - endif - end do !iv - end do !ft - end do !L - - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Direct beam extinction coefficient, k_dir. PFT specific. - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - cosz = max(0.001_r8, currentPatch%solar_zenith_angle ) !copied from previous radiation code... - do ft = 1,numpft - sb = (90._r8 - (acos(cosz)*180._r8/pi_const)) * (pi_const / 180._r8) - phi1b(ft) = 0.5_r8 - 0.633_r8*xl(ft) - 0.330_r8*xl(ft)*xl(ft) - phi2b(ft) = 0.877_r8 * (1._r8 - 2._r8*phi1b(ft)) !0 = horiz leaves, 1 - vert leaves. - gdir = phi1b(ft) + phi2b(ft) * sin(sb) - !how much direct light penetrates a singleunit of lai? - k_dir(ft) = clumping_index(ft) * gdir / sin(sb) - end do !FT - - - - - !do this once for one unit of diffuse, and once for one unit of direct radiation - do radtype = 1, num_rad_stream_types - - ! Extract information that needs to be provided by ED into local array. - ! RGK: NOT SURE WHY WE NEED FTWEIGHT ... - ! ------------------------------------------------------------------------------ - - ftweight(:,:,:) = 0._r8 - do L = 1,currentPatch%NCL_p - do ft = 1,numpft - do iv = 1, currentPatch%nrad(L,ft) - !this is already corrected for area in CLAP - ftweight(L,ft,iv) = currentPatch%canopy_area_profile(L,ft,iv) - end do !iv - end do !ft1 - end do !L - - if(debug)then - if (sum(ftweight(1,:,1))<0.999_r8)then - write(fates_log(),*) 'canopy not full',ftweight(1,:,1) - endif - if (sum(ftweight(1,:,1))>1.0001_r8)then - write(fates_log(),*) 'canopy too full',ftweight(1,:,1) - endif - end if - - do L = 1,currentPatch%NCL_p !start at the top canopy layer (1 is the top layer.) - - weighted_dir_tr(L) = 0.0_r8 - weighted_fsun(L) = 0._r8 - weighted_dif_ratio(L,1:hlm_numSWb) = 0._r8 - - !Each canopy layer (canopy, understorey) has multiple 'parallel' pft's - - do ft =1,numpft - - if (currentPatch%canopy_mask(L,ft) == 1)then !only do calculation if there are the appropriate leaves. - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Diffuse transmittance, tr_dif, do each layer with thickness elai_z. - ! Estimated do nine sky angles in increments of 10 degrees - ! PFT specific... - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - tr_dif_z(L,ft,:) = 0._r8 - do iv = 1,currentPatch%nrad(L,ft) - do j = 1,9 - angle = (5._r8 + real(j - 1,r8) * 10._r8) * pi_const / 180._r8 - gdir = phi1b(ft) + phi2b(ft) * sin(angle) - tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-clumping_index(ft) * & - gdir / sin(angle) * & - (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))) * & - sin(angle)*cos(angle) - end do - tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) * 2._r8 * (10._r8 * pi_const / 180._r8) - end do + !radiation absorbed from fluxes through unfilled part of lower canopy. + if (currentPatch%ncl_p > 1.and.L == currentPatch%ncl_p)then + abs_rad(ib) = abs_rad(ib) + weighted_dif_down(L-1) * & + (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dif(ib) ) + abs_rad(ib) = abs_rad(ib) + forc_dir(radtype) * weighted_dir_tr(L-1) * & + (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dir(ib) ) + tr_soili = tr_soili + weighted_dif_down(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) + tr_soild = tr_soild + forc_dir(radtype) * weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) + endif + if (radtype == idirect)then + currentPatch%tr_soil_dir(ib) = tr_soild + currentPatch%tr_soil_dir_dif(ib) = tr_soili + currentPatch%sabs_dir(ib) = abs_rad(ib) + ftdd_parb_out(ib) = tr_soild + ftid_parb_out(ib) = tr_soili + else + currentPatch%tr_soil_dif(ib) = tr_soili + currentPatch%sabs_dif(ib) = abs_rad(ib) + ftii_parb_out(ib) = tr_soili + end if + + end do!l + + + !==============================================================================! + ! Conservation check + !==============================================================================! + ! Total radiation balance: absorbed = incoming - outgoing + + if (radtype == idirect)then + error = abs(currentPatch%sabs_dir(ib) - (currentPatch%tr_soil_dir(ib) * & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + & + currentPatch%tr_soil_dir_dif(ib) * (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) + + if(debug)then + if ( abs(error) > 0.0001)then + write(fates_log(),*)'dir ground absorption error',error,currentPatch%sabs_dir(ib), & + currentPatch%tr_soil_dir(ib)* & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ),currentPatch%ncl_p,ib,sum(ftweight(1,1:numpft,1)) + write(fates_log(),*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + do ft =1,numpft + iv = currentPatch%nrad(1,ft) + 1 + write(fates_log(),*) 'abs soil fluxes', Abs_dir_z(ft,iv),Abs_dif_z(ft,iv) + end do + end if + end if + + else + if (debug) then + if ( abs(currentPatch%sabs_dif(ib)-(currentPatch%tr_soil_dif(ib) * & + (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) > 0.0001_r8)then + write(fates_log(),*)'dif ground absorption error',currentPatch%sabs_dif(ib) , & + (currentPatch%tr_soil_dif(ib)* & + (1.0_r8-currentPatch%gnd_alb_dif(ib) )),currentPatch%ncl_p,ib,sum(ftweight(1,1:numpft,1)) + endif + end if + endif + + if (radtype == idirect)then + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) + else + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) + endif + + ! ignore the current patch radiation error if the veg-covered fraction of the patch is really small + if ( (currentPatch%total_canopy_area / currentPatch%area) .gt. tolerance ) then + ! normalize rad error by the veg-covered fraction of the patch because that is + ! the only part that this code applies to + currentPatch%radiation_error = currentPatch%radiation_error + error & + * currentPatch%total_canopy_area / currentPatch%area + endif + + lai_reduction(:) = 0.0_r8 + do L = 1, currentPatch%ncl_p + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + do iv = 1, currentPatch%nrad(L,ft) + if (lai_change(L,ft,iv) > 0.0_r8)then + lai_reduction(L) = max(lai_reduction(L),lai_change(L,ft,iv)) + endif + enddo + endif + enddo + enddo + + if (radtype == idirect)then + !here we are adding a within-ED radiation scheme tolerance, and then adding the diffrence onto the albedo + !it is important that the lower boundary for this is ~1000 times smaller than the tolerance in surface albedo. + if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then + albd_parb_out(ib) = albd_parb_out(ib) + error + !this terms adds the error back on to the albedo. While this is partly inexcusable, it is + ! in the medium term a solution that + ! prevents the model from crashing with small and occasional energy balances issues. + ! These are extremely difficult to debug, many have been solved already, leading + ! to the complexity of this code, but where the system generates occasional errors, we + ! will deal with them for now. + end if + + if (abs(error) > 0.15_r8)then + if(debug)then + write(fates_log(),*) 'Large Dir Radn consvn error',error ,ib + write(fates_log(),*) 'diags', albd_parb_out(ib), ftdd_parb_out(ib), & + ftid_parb_out(ib), fabd_parb_out(ib) + write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'ftweight',ftweight(1,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) + end if + albd_parb_out(ib) = albd_parb_out(ib) + error + end if + else + + if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then + albi_parb_out(ib) = albi_parb_out(ib) + error + end if + + if (abs(error) > 0.15_r8)then + if(debug)then + write(fates_log(),*) 'lg Dif Radn consvn error',error ,ib + write(fates_log(),*) 'diags', albi_parb_out(ib), ftii_parb_out(ib), & + fabi_parb_out(ib) + !write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + !write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + !write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + !write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) + !write(fates_log(),*) 'rhol',rhol(1:numpft,:) + !write(fates_log(),*) 'ftw',sum(ftweight(1,1:numpft,1)),ftweight(1,1:numpft,1) + !write(fates_log(),*) 'present',currentPatch%canopy_mask(1,1:numpft) + !write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:numpft,1) + end if + albi_parb_out(ib) = albi_parb_out(ib) + error + end if + + if (radtype == idirect)then + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) + else + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) + endif - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Direct beam transmittance, tr_dir_z, uses cumulative LAI above layer J to give - ! unscattered direct beam onto layer J. do each PFT section. - ! This is just an decay curve based on k_dir. (leaf & sun angle) - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - if (L==1)then - tr_dir_z(L,ft,1) = 1._r8 - else - tr_dir_z(L,ft,1) = weighted_dir_tr(L-1) - endif - laisum = 0.00_r8 - !total direct beam getting to the bottom of the top canopy. - do iv = 1,currentPatch%nrad(L,ft) - laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) - lai_change(L,ft,iv) = 0.0_r8 - if (( ftweight(L,ft,iv+1) > 0.0_r8 ) .and. ( ftweight(L,ft,iv+1) < ftweight(L,ft,iv) ))then - !where there is a partly empty leaf layer, some fluxes go straight through. - lai_change(L,ft,iv) = ftweight(L,ft,iv)-ftweight(L,ft,iv+1) - endif - if(debug)then - if (ftweight(L,ft,iv+1) - ftweight(L,ft,iv) > 1.e-10_r8)then - write(fates_log(),*) 'lower layer has more coverage. This is wrong' , & - ftweight(L,ft,iv),ftweight(L,ft,iv+1),ftweight(L,ft,iv+1)-ftweight(L,ft,iv) - endif - end if - - !n.b. in theory lai_change could be calculated daily in the ED code. - !This is light coming striaght through the canopy. - if (L==1)then - tr_dir_z(L,ft,iv+1) = exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - else - tr_dir_z(L,ft,iv+1) = weighted_dir_tr(L-1)*exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - endif + if(debug) then + if (abs(error) > 0.00000001_r8)then + write(fates_log(),*) 'there is still error after correction',error ,ib + end if + end if - if (iv == 1)then - !this is the top layer. - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & - ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) - else - !the lai_change(iv) affects the light incident on layer iv+2 not iv+1 - ! light coming from the layer above (iv-1) goes through iv and onto iv+1. - if (lai_change(L,ft,iv-1) > 0.0_r8)then - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv)* & - lai_change(L,ft,iv-1) / ftweight(L,ft,1) - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv-1)* & - (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) - else - !account fot the light that comes striaght down from unfilled layers above. - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & - ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) - endif - endif + end if + end do !hlm_numSWb - end do + enddo ! rad-type - !add up all the weighted contributions from the different PFT columns. - weighted_dir_tr(L) = weighted_dir_tr(L) + tr_dir_z(L,ft,currentPatch%nrad(L,ft)+1)*ftweight(L,ft,1) + end associate + return + end subroutine PatchNormanRadiation - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Sunlit and shaded fraction of leaf layer - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! ====================================================================================== - !laisum = 0._r8 - do iv = 1,currentPatch%nrad(L,ft) - ! Cumulative leaf area. Original code uses cumulative lai do layer. - ! Now use cumulative lai at center of layer. - ! Same as tr_dir_z calcualtions, but in the middle of the layer? FIX(RF,032414)-WHY? - if (iv == 1) then - laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) - else - laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) - end if + subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) + + implicit none + + ! Arguments + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + + ! locals + type (fates_patch_type),pointer :: cpatch ! c"urrent" patch + real(r8) :: sunlai + real(r8) :: shalai + real(r8) :: elai + integer :: cl,ft + integer :: iv,ib + integer :: s + integer :: ifp + integer :: nv + integer :: icol + ! Fraction of the canopy area associated with each pft and layer + ! (used for weighting diagnostics) + real(r8) :: area_vlpfcl(nlevleaf,maxpft,nclmax) + real(r8) :: vai_top,vai_bot + real(r8) :: area_frac + real(r8) :: Rb_abs,Rd_abs,Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow,leaf_sun_frac + real(r8) :: vai + + do s = 1,nsites + ifp = 0 + cpatch => sites(s)%oldest_patch - if (L == 1)then !top canopy layer - currentPatch%f_sun(L,ft,iv) = exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - else - currentPatch%f_sun(L,ft,iv) = weighted_fsun(L-1)* exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - endif + do while (associated(cpatch)) - if ( iv > 1 ) then ! becasue we are looking at this layer (not the next) - ! we only ever add fluxes if iv>1 - if (lai_change(L,ft,iv-1) > 0.0_r8)then - currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & - currentPatch%f_sun(L,ft,iv) * & - lai_change(L,ft,iv-1)/ftweight(L,ft,1) - currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & - currentPatch%f_sun(L,ft,iv-1) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) - else - currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & - currentPatch%f_sun(L,ft,iv-1) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - endif - endif + ! Initialize diagnostics + cpatch%ed_parsun_z(:,:,:) = 0._r8 + cpatch%ed_parsha_z(:,:,:) = 0._r8 + cpatch%parprof_pft_dir_z(:,:,:) = 0._r8 + cpatch%parprof_pft_dif_z(:,:,:) = 0._r8 + bc_out(s)%fsun_pa(ifp) = 0._r8 + bc_out(s)%laisun_pa(ifp) = 0._r8 + bc_out(s)%laisha_pa(ifp) = calc_areaindex(cpatch,'elai') - end do !iv - - weighted_fsun(L) = weighted_fsun(L) + currentPatch%f_sun(L,ft,currentPatch%nrad(L,ft))* & - ftweight(L,ft,1) - - ! instance where the first layer ftweight is used a proxy for the whole column. FTWA - ! this is possibly a source of slight error. If we use the ftweight at the top of the PFT column, - ! then we willl underestimate fsun, but if we use ftweight at the bottom of the column, we will - ! underestimate it. Really, we should be tracking the release of direct light from the column as it tapers - ! towards the ground. Is that necessary to get energy closure? It would be quite hard... - endif !present. - end do!pft loop - end do !L - - - do L = currentPatch%NCL_p,1, -1 !start at the bottom and work up. - do ft = 1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - - !==============================================================================! - ! Iterative solution do scattering - !==============================================================================! - - do ib = 1,hlm_numSWb !vis, nir - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Leaf scattering coefficient and terms do diffuse radiation reflected - ! and transmitted by a layer - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - - do iv = 1,currentPatch%nrad(L,ft) - !How much diffuse light is intercepted and then reflected? - refl_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * rho_layer(L,ft,iv,ib) - !How much diffuse light in this layer is transmitted? - tran_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * & - tau_layer(L,ft,iv,ib) + tr_dif_z(L,ft,iv) - end do + if_notbareground:if(cpatch%nocomp_pft_label.ne.nocomp_bareground)then !only for veg patches + ! do not do albedo calculations for bare ground patch in SP mode + ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein + ! ifp=1 is the first vegetated patch. + ifp=ifp+1 - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Ratio of upward to forward diffuse fluxes, dif_ratio - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Soil diffuse reflectance (ratio of down to up radiation). - iv = currentPatch%nrad(L,ft) + 1 - if (L == currentPatch%NCL_p)then !nearest the soil - dif_ratio(L,ft,iv,ib) = currentPatch%gnd_alb_dif(ib) !bc_in(s)%albgr_dif_rb(ib) - else - dif_ratio(L,ft,iv,ib) = weighted_dif_ratio(L+1,ib) - end if - ! Canopy layers, working upwardfrom soil with dif_ratio(iv+1) known - ! FIX(RF,032414) ray tracing eqution - need to find derivation of this... - ! for each unit going down, there are x units going up. - do iv = currentPatch%nrad(L,ft),1, -1 - dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv+1,ib) * & - tran_dif(L,ft,iv,ib)*tran_dif(L,ft,iv,ib) / & - (1._r8 - dif_ratio(L,ft,iv+1,ib) * refl_dif(L,ft,iv,ib)) & - + refl_dif(L,ft,iv,ib) - dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) * & - ftweight(L,ft,iv)/ftweight(L,ft,1) - dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) + dif_ratio(L,ft,iv+1,ib) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - end do - weighted_dif_ratio(L,ib) = weighted_dif_ratio(L,ib) + & - dif_ratio(L,ft,1,ib) * ftweight(L,ft,1) - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - end do!hlm_numSWb - endif ! currentPatch%canopy_mask - end do!ft - end do!L - - ! Zero out the radiation error for the current patch before conducting the conservation check - currentPatch%radiation_error = 0.0_r8 - - do ib = 1,hlm_numSWb - Dif_dn(:,:,:) = 0.00_r8 - Dif_up(:,:,:) = 0.00_r8 - do L = 1, currentPatch%NCL_p !work down from the top of the canopy. - weighted_dif_down(L) = 0._r8 - do ft = 1, numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! First estimates do downward and upward diffuse flux - ! - ! Dif_dn = forward diffuse flux onto layer J - ! Dif_up = Upward diffuse flux above layer J - ! - ! Solved here without direct beam radiation and using dif_ratio = Dif_up / Dif_dn - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! downward diffuse flux onto the top surface of the canopy - - if (L == 1)then - Dif_dn(L,ft,1) = forc_dif(radtype) - else - Dif_dn(L,ft,1) = weighted_dif_down(L-1) - end if - ! forward diffuse flux within the canopy and at soil, working forward through canopy - do iv = 1,currentPatch%nrad(L,ft) - denom = refl_dif(L,ft,iv,ib) * dif_ratio(L,ft,iv,ib) - denom = 1._r8 - denom - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) / & - denom *ftweight(L,ft,iv)/ftweight(L,ft,1) - if (iv > 1)then - if (lai_change(L,ft,iv-1) > 0.0_r8)then - !here we are thinking about whether the layer above had an laichange, - !but calculating the flux onto the layer below. - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv)* & - lai_change(L,ft,iv-1)/ftweight(L,ft,1) - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv-1)* & - (ftweight(L,ft,1)-ftweight(L,ft,iv-1)/ftweight(L,ft,1)) - else - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - endif - else - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - endif - end do + ! If there is no sun out, we have a trivial solution + if_zenithflag: if(cpatch%solar_zenith_flag ) then - weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & - ftweight(L,ft,1) - - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - endif !present - end do !ft - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is the the (incomplete) understorey? - !Add on the radiation going through the canopy gaps. - weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1)*(1.0-sum(ftweight(L,:,1))) - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - endif - end do !L - - do L = currentPatch%NCL_p,1 ,-1 !work up from the bottom. - weighted_dif_up(L) = 0._r8 - do ft = 1, numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - !Bounce diffuse radiation off soil surface. - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%NCL_p)then !is this the bottom layer ? - Dif_up(L,ft,iv) = currentPatch%gnd_alb_dif(ib) * Dif_dn(L,ft,iv) - else - Dif_up(L,ft,iv) = weighted_dif_up(L+1) - end if - ! Upward diffuse flux within the canopy and above the canopy, working upward through canopy - - do iv = currentPatch%nrad(L,ft), 1, -1 - if (lai_change(L,ft,iv) > 0.0_r8)then - Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * & - ftweight(L,ft,iv) / ftweight(L,ft,1) - Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & - tran_dif(L,ft,iv,ib) * lai_change(L,ft,iv)/ftweight(L,ft,1) - Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - !nb is this the right constuction? - ! the radiation that hits the empty space is not reflected. - else - Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * ftweight(L,ft,iv) - Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * (1.0_r8-ftweight(L,ft,iv)) - endif - end do - weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - endif !present - end do !ft - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? - !Add on the radiation coming up through the canopy gaps. - !diffuse to diffuse - weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & - weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) - !direct to diffuse - weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & - weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) * currentPatch%gnd_alb_dir(ib) - endif - end do !L - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! 3. Iterative calculation of forward and upward diffuse fluxes, iNCL_puding - ! scattered direct beam - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - - ! Flag to exit iteration loop: 0 = exit and 1 = iterate - irep = 1 - ! Iteration loop - iter = 0 - do while(irep ==1 .and. iter<50) - - iter = iter + 1 - irep = 0 - do L = 1,currentPatch%NCL_p !working from the top down - weighted_dif_down(L) = 0._r8 - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - ! forward diffuse flux within the canopy and at soil, working forward through canopy - ! with Dif_up -from previous iteration-. Dif_dn(1) is the forward diffuse flux onto the canopy. - ! Note: down = forward flux onto next layer - if (L == 1)then !is this the top layer? - Dif_dn(L,ft,1) = forc_dif(radtype) - else - Dif_dn(L,ft,1) = weighted_dif_down(L-1) - end if - down_rad = 0._r8 - - do iv = 1, currentPatch%nrad(L,ft) - ! down rad'n is the sum of the down and upwards reflected diffuse fluxes... - down_rad = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) + & - Dif_up(L,ft,iv+1) * refl_dif(L,ft,iv,ib) - - !... plus the direct beam intercepted and intransmitted by this layer. - down_rad = down_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - & - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & - currentPatch%esai_profile(L,ft,iv)) )) * tau_layer(L,ft,iv,ib) - - - !... plus the direct beam intercepted and intransmitted by this layer. - ! modified to spread it out over the whole of incomplete layers. - - down_rad = down_rad *(ftweight(L,ft,iv)/ftweight(L,ft,1)) - - if (iv > 1)then - if (lai_change(L,ft,iv-1) > 0.0_r8)then - down_rad = down_rad + Dif_dn(L,ft,iv) * lai_change(L,ft,iv-1)/ftweight(L,ft,1) - down_rad = down_rad + Dif_dn(L,ft,iv-1) * (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ & - ftweight(L,ft,1) - else - down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & - ftweight(L,ft,1) - endif - else - down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & - ftweight(L,ft,1) - endif - - !this is just Dif down, plus refl up, plus dir intercepted and turned into dif... , - if (abs(down_rad - Dif_dn(L,ft,iv+1)) > tolerance)then - irep = 1 - end if - Dif_dn(L,ft,iv+1) = down_rad - - end do !iv - - weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & - ftweight(L,ft,1) - - endif !present - end do!ft - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? - weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1) * & - (1.0_r8-sum(ftweight(L,1:numpft,1))) - end if - end do ! do L loop - - do L = 1, currentPatch%NCL_p ! working from the top down. - weighted_dif_up(L) = 0._r8 - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - ! Upward diffuse flux at soil or from lower canopy (forward diffuse and unscattered direct beam) - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%NCL_p)then !In the bottom canopy layer, reflect off the soil - Dif_up(L,ft,iv) = Dif_dn(L,ft,iv) * currentPatch%gnd_alb_dif(ib) + & - forc_dir(radtype) * tr_dir_z(L,ft,iv) * currentPatch%gnd_alb_dir(ib) - else !In the other canopy layers, reflect off the underlying vegetation. - Dif_up(L,ft,iv) = weighted_dif_up(L+1) - end if - - ! Upward diffuse flux within and above the canopy, working upward through canopy - ! with Dif_dn from previous interation. Note: up = upward flux above current layer - do iv = currentPatch%nrad(L,ft),1,-1 - !this is radiation up, by layer transmittance, by - - !reflection of the lower layer, - up_rad = Dif_dn(L,ft,iv) * refl_dif(L,ft,iv,ib) - up_rad = up_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - exp(-k_dir(ft) * & - (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))))* & - rho_layer(L,ft,iv,ib) - up_rad = up_rad + Dif_up(L,ft,iv+1) * tran_dif(L,ft,iv,ib) - up_rad = up_rad * ftweight(L,ft,iv)/ftweight(L,ft,1) - up_rad = up_rad + Dif_up(L,ft,iv+1) *(ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - ! THE LOWER LAYER FLUX IS HOMOGENIZED, SO WE DON"T CONSIDER THE LAI_CHANGE HERE... - - if (abs(up_rad - Dif_up(L,ft,iv)) > tolerance) then !are we close to the tolerance level? - irep = 1 - end if - Dif_up(L,ft,iv) = up_rad - - end do !iv - weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) - end if !present - end do!ft - - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? - !Add on the radiation coming up through the canopy gaps. - weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & - weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) - weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & - weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1)))*currentPatch%gnd_alb_dir(ib) - end if - end do!L - end do ! do while over iter - - abs_rad(ib) = 0._r8 - tr_soili = 0._r8 - tr_soild = 0._r8 - - do L = 1, currentPatch%NCL_p !working from the top down. - abs_dir_z(:,:) = 0._r8 - abs_dif_z(:,:) = 0._r8 - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - !==============================================================================! - ! Compute absorbed flux densities - !==============================================================================! - - ! Absorbed direct beam and diffuse do leaf layers - do iv = 1, currentPatch%nrad(L,ft) - Abs_dir_z(ft,iv) = ftweight(L,ft,iv)* forc_dir(radtype) * tr_dir_z(L,ft,iv) * & - (1.00_r8 - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & - currentPatch%esai_profile(L,ft,iv)) )) * f_abs(L,ft,iv,ib) - Abs_dif_z(ft,iv) = ftweight(L,ft,iv)* ((Dif_dn(L,ft,iv) + & - Dif_up(L,ft,iv+1)) * (1.00_r8 - tr_dif_z(L,ft,iv)) * f_abs(L,ft,iv,ib)) - end do + sunlai = 0._r8 + shalai = 0._r8 + if_norm_twostr: if (radiation_model.eq.norman_solver) then - ! Absorbed direct beam and diffuse do soil - if (L == currentPatch%NCL_p)then - iv = currentPatch%nrad(L,ft) + 1 - Abs_dif_z(ft,iv) = ftweight(L,ft,1)*Dif_dn(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dif(ib) ) - Abs_dir_z(ft,iv) = ftweight(L,ft,1)*forc_dir(radtype) * & - tr_dir_z(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dir(ib) ) - tr_soild = tr_soild + ftweight(L,ft,1)*forc_dir(radtype) * tr_dir_z(L,ft,iv) - tr_soili = tr_soili + ftweight(L,ft,1)*Dif_dn(L,ft,iv) - end if + ! Loop over patches to calculate laisun_z and laisha_z for each layer. + ! Derive canopy laisun, laisha, and fsun from layer sums. + ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from + ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. - ! Absorbed radiation, shaded and sunlit portions of leaf layers - !here we get one unit of diffuse radiation... how much of - !it is absorbed? - if (ib == ivis) then ! only set the absorbed PAR for the visible light band. - do iv = 1, currentPatch%nrad(L,ft) - if (radtype==idirect) then - if ( debug ) then - write(fates_log(),*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) - write(fates_log(),*) 'EDsurfAlb 731 ', currentPatch%fabd_sha_z(L,ft,iv), & - currentPatch%fabd_sun_z(L,ft,iv) - endif - currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - (1._r8 - currentPatch%f_sun(L,ft,iv))*f_abs_leaf(L,ft,iv,ib) - currentPatch%fabd_sun_z(L,ft,iv) =( Abs_dif_z(ft,iv) * & - currentPatch%f_sun(L,ft,iv) + & - Abs_dir_z(ft,iv))*f_abs_leaf(L,ft,iv,ib) - else - currentPatch%fabi_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - (1._r8 - currentPatch%f_sun(L,ft,iv))*f_abs_leaf(L,ft,iv,ib) - currentPatch%fabi_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - currentPatch%f_sun(L,ft,iv)*f_abs_leaf(L,ft,iv,ib) - endif - if ( debug ) then - write(fates_log(),*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & - currentPatch%fabd_sun_z(L,ft,iv) - endif - end do - endif ! ib + ! cpatch%f_sun is calculated in the surface_albedo routine... + do cl = 1, cpatch%ncl_p + do ft = 1,numpft - !==============================================================================! - ! Sum fluxes - !==============================================================================! - ! Solar radiation absorbed by ground - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%NCL_p)then - abs_rad(ib) = abs_rad(ib) + (Abs_dir_z(ft,iv) + Abs_dif_z(ft,iv)) - end if - ! Solar radiation absorbed by vegetation and sunlit/shaded leaves - do iv = 1,currentPatch%nrad(L,ft) - if (radtype == idirect)then - currentPatch%fabd(ib) = currentPatch%fabd(ib) + & - Abs_dir_z(ft,iv)+Abs_dif_z(ft,iv) - ! bc_out(s)%fabd_parb_out(ib) = currentPatch%fabd(ib) - else - currentPatch%fabi(ib) = currentPatch%fabi(ib) + Abs_dif_z(ft,iv) - ! bc_out(s)%fabi_parb_out(ib) = currentPatch%fabi(ib) - endif + !needed for the VOC emissions, etc. + sunlai = sunlai + sum(cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%f_sun(cl,ft,1:cpatch%nrad(cl,ft))) + shalai = shalai + sum(cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + + end do end do - ! Albefor - if (L==1)then !top canopy layer. - if (radtype == idirect)then - albd_parb_out(ib) = albd_parb_out(ib) + & - Dif_up(L,ft,1) * ftweight(L,ft,1) - else - albi_parb_out(ib) = albi_parb_out(ib) + & - Dif_up(L,ft,1) * ftweight(L,ft,1) - end if + shalai = shalai-sunlai + + if(sunlai+shalai > 0._r8)then + bc_out(s)%fsun_pa(ifp) = sunlai / (sunlai+shalai) + else + bc_out(s)%fsun_pa(ifp) = 0._r8 + endif + + if(debug)then + if(bc_out(s)%fsun_pa(ifp) > 1._r8)then + write(fates_log(),*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & + sunlai,shalai + endif end if - ! pass normalized PAR profiles for use in diagnostic averaging for history fields - if (ib == ivis) then ! only diagnose PAR profiles for the visible band - do iv = 1, currentPatch%nrad(L,ft) - currentPatch%nrmlzd_parprof_pft_dir_z(radtype,L,ft,iv) = & - forc_dir(radtype) * tr_dir_z(L,ft,iv) - - currentPatch%nrmlzd_parprof_pft_dif_z(radtype,L,ft,iv) = & - Dif_dn(L,ft,iv) + Dif_up(L,ft,iv) + elai = calc_areaindex(cpatch,'elai') - end do - end if ! ib = visible - end if ! present - end do !ft - if (radtype == idirect)then - fabd_parb_out(ib) = currentPatch%fabd(ib) - else - fabi_parb_out(ib) = currentPatch%fabi(ib) - endif - - - !radiation absorbed from fluxes through unfilled part of lower canopy. - if (currentPatch%NCL_p > 1.and.L == currentPatch%NCL_p)then - abs_rad(ib) = abs_rad(ib) + weighted_dif_down(L-1) * & - (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dif(ib) ) - abs_rad(ib) = abs_rad(ib) + forc_dir(radtype) * weighted_dir_tr(L-1) * & - (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dir(ib) ) - tr_soili = tr_soili + weighted_dif_down(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) - tr_soild = tr_soild + forc_dir(radtype) * weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) - endif - - if (radtype == idirect)then - currentPatch%tr_soil_dir(ib) = tr_soild - currentPatch%tr_soil_dir_dif(ib) = tr_soili - currentPatch%sabs_dir(ib) = abs_rad(ib) - ftdd_parb_out(ib) = tr_soild - ftid_parb_out(ib) = tr_soili - else - currentPatch%tr_soil_dif(ib) = tr_soili - currentPatch%sabs_dif(ib) = abs_rad(ib) - ftii_parb_out(ib) = tr_soili - end if + bc_out(s)%laisun_pa(ifp) = elai*bc_out(s)%fsun_pa(ifp) + bc_out(s)%laisha_pa(ifp) = elai*(1.0_r8-bc_out(s)%fsun_pa(ifp)) - end do!l - - - !==============================================================================! - ! Conservation check - !==============================================================================! - ! Total radiation balance: absorbed = incoming - outgoing - - if (radtype == idirect)then - error = abs(currentPatch%sabs_dir(ib) - (currentPatch%tr_soil_dir(ib) * & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + & - currentPatch%tr_soil_dir_dif(ib) * (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) - - if(debug)then - if ( abs(error) > 0.0001)then - write(fates_log(),*)'dir ground absorption error',error,currentPatch%sabs_dir(ib), & - currentPatch%tr_soil_dir(ib)* & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) - write(fates_log(),*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ) - do ft =1,numpft - iv = currentPatch%nrad(1,ft) + 1 - write(fates_log(),*) 'abs soil fluxes', Abs_dir_z(ft,iv),Abs_dif_z(ft,iv) - end do - end if - end if - - else - if (debug) then - if ( abs(currentPatch%sabs_dif(ib)-(currentPatch%tr_soil_dif(ib) * & - (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) > 0.0001_r8)then - write(fates_log(),*)'dif ground absorption error',currentPatch%sabs_dif(ib) , & - (currentPatch%tr_soil_dif(ib)* & - (1.0_r8-currentPatch%gnd_alb_dif(ib) )),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) - endif - end if - endif - - if (radtype == idirect)then - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) - else - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) - endif - - ! ignore the current patch radiation error if the veg-covered fraction of the patch is really small - if ( (currentPatch%total_canopy_area / currentPatch%area) .gt. tolerance ) then - ! normalize rad error by the veg-covered fraction of the patch because that is - ! the only part that this code applies to - currentPatch%radiation_error = currentPatch%radiation_error + error & - * currentPatch%total_canopy_area / currentPatch%area - endif - - lai_reduction(:) = 0.0_r8 - do L = 1, currentPatch%NCL_p - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - do iv = 1, currentPatch%nrad(L,ft) - if (lai_change(L,ft,iv) > 0.0_r8)then - lai_reduction(L) = max(lai_reduction(L),lai_change(L,ft,iv)) - endif - enddo - endif - enddo - enddo - - if (radtype == idirect)then - !here we are adding a within-ED radiation scheme tolerance, and then adding the diffrence onto the albedo - !it is important that the lower boundary for this is ~1000 times smaller than the tolerance in surface albedo. - if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then - albd_parb_out(ib) = albd_parb_out(ib) + error - !this terms adds the error back on to the albedo. While this is partly inexcusable, it is - ! in the medium term a solution that - ! prevents the model from crashing with small and occasional energy balances issues. - ! These are extremely difficult to debug, many have been solved already, leading - ! to the complexity of this code, but where the system generates occasional errors, we - ! will deal with them for now. - end if - - if (abs(error) > 0.15_r8)then - if(debug)then - write(fates_log(),*) 'Large Dir Radn consvn error',error ,ib - write(fates_log(),*) 'diags', albd_parb_out(ib), ftdd_parb_out(ib), & - ftid_parb_out(ib), fabd_parb_out(ib) - write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'ftweight',ftweight(1,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno - write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) - end if - albd_parb_out(ib) = albd_parb_out(ib) + error - end if - else + ! Absorbed PAR profile through canopy + ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo + ! are canopy integrated so that layer values equal big leaf values. - if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then - albi_parb_out(ib) = albi_parb_out(ib) + error - end if + do cl = 1, cpatch%ncl_p + do ft = 1,numpft + do iv = 1, cpatch%nrad(cl,ft) - if (abs(error) > 0.15_r8)then - if(debug)then - write(fates_log(),*) 'lg Dif Radn consvn error',error ,ib - write(fates_log(),*) 'diags', albi_parb_out(ib), ftii_parb_out(ib), & - fabi_parb_out(ib) - !write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - !write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - !write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - !write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno - write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) - !write(fates_log(),*) 'rhol',rhol(1:numpft,:) - !write(fates_log(),*) 'ftw',sum(ftweight(1,1:numpft,1)),ftweight(1,1:numpft,1) - !write(fates_log(),*) 'present',currentPatch%canopy_mask(1,1:numpft) - !write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:numpft,1) - end if - albi_parb_out(ib) = albi_parb_out(ib) + error - end if + cpatch%ed_parsun_z(cl,ft,iv) = & + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(cl,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(cl,ft,iv) - if (radtype == idirect)then - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) - else - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) - endif - - if(debug) then - if (abs(error) > 0.00000001_r8)then - write(fates_log(),*) 'there is still error after correction',error ,ib - end if - end if - - end if - end do !hlm_numSWb + if ( debug )write(fates_log(),*) 'edsurfRad 663 ', cpatch%ed_parsun_z(cl,ft,iv) - enddo ! rad-type + cpatch%ed_parsha_z(cl,ft,iv) = & + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sha_z(cl,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sha_z(cl,ft,iv) - end associate - return -end subroutine PatchNormanRadiation + if ( debug ) write(fates_log(),*) 'edsurfRad 669 ', cpatch%ed_parsha_z(cl,ft,iv) -! ====================================================================================== + end do !iv + end do !ft + end do !cl -subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) + ! Convert normalized radiation error units from fraction of radiation to W/m2 + cpatch%radiation_error = cpatch%radiation_error * (bc_in(s)%solad_parb(ifp,ipar) + & + bc_in(s)%solai_parb(ifp,ipar)) - implicit none + ! output the actual PAR profiles through the canopy for diagnostic purposes + do cl = 1, cpatch%ncl_p + do ft = 1,numpft + do iv = 1, cpatch%nrad(cl,ft) + cpatch%parprof_pft_dir_z(cl,ft,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dir_z(idirect,cl,ft,iv)) + & + (bc_in(s)%solai_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dir_z(idiffuse,cl,ft,iv)) - ! Arguments - integer,intent(in) :: nsites - type(ed_site_type),intent(inout),target :: sites(nsites) - type(bc_in_type),intent(in) :: bc_in(nsites) - type(bc_out_type),intent(inout) :: bc_out(nsites) - - ! locals - type (fates_patch_type),pointer :: cpatch ! c"urrent" patch - real(r8) :: sunlai - real(r8) :: shalai - real(r8) :: elai - integer :: CL - integer :: FT - integer :: iv,ib - integer :: s - integer :: ifp - integer :: nv - integer :: icol - ! Fraction of the canopy area associated with each pft and layer - ! (used for weighting diagnostics) - real(r8) :: area_vlpfcl(nlevleaf,maxpft,nclmax) - real(r8) :: vai_top,vai_bot - real(r8) :: area_frac - real(r8) :: Rb_abs,Rd_abs,Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow,leaf_sun_frac - real(r8) :: vai - - do s = 1,nsites - - ifp = 0 - cpatch => sites(s)%oldest_patch - - do while (associated(cpatch)) - - if_notbareground:if(cpatch%nocomp_pft_label.ne.nocomp_bareground)then !only for veg patches - ! do not do albedo calculations for bare ground patch in SP mode - ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein - ! ifp=1 is the first vegetated patch. - ifp=ifp+1 - - ! If there is no sun out, we have a trivial solution - if_zenithflag: if( .not.cpatch%solar_zenith_flag ) then - - cpatch%ed_parsun_z(1:cpatch%ncl_p,1:numpft,:) = 0._r8 - cpatch%ed_parsha_z(1:cpatch%ncl_p,1:numpft,:) = 0._r8 - cpatch%parprof_pft_dir_z(1:cpatch%ncl_p,1:numpft,:) = hlm_hio_ignore_val - cpatch%parprof_pft_dif_z(1:cpatch%ncl_p,1:numpft,:) = hlm_hio_ignore_val - - !cpatch%f_sun(1:cpatch%ncl_p,1:numpft,:) = hlm_hio_ignore_val - - bc_out(s)%fsun_pa(ifp) = 0._r8 - bc_out(s)%laisun_pa(ifp) = 0._r8 - bc_out(s)%laisha_pa(ifp) = calc_areaindex(cpatch,'elai') - - else - - ! zero out arrays - cpatch%ed_parsun_z(:,:,:) = 0._r8 - cpatch%ed_parsha_z(:,:,:) = 0._r8 - bc_out(s)%fsun_pa(ifp) = 0._r8 - sunlai = 0._r8 - shalai = 0._r8 - cpatch%parprof_pft_dir_z(:,:,:) = 0._r8 - cpatch%parprof_pft_dif_z(:,:,:) = 0._r8 - - if_norm_twostr: if (radiation_model.eq.norman_solver) then - - ! Loop over patches to calculate laisun_z and laisha_z for each layer. - ! Derive canopy laisun, laisha, and fsun from layer sums. - ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from - ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. - - ! cpatch%f_sun is calculated in the surface_albedo routine... - - do CL = 1, cpatch%NCL_p - do FT = 1,numpft - - !needed for the VOC emissions, etc. - sunlai = sunlai + sum(cpatch%elai_profile(CL,ft,1:cpatch%nrad(CL,ft))*cpatch%f_sun(CL,ft,1:cpatch%nrad(CL,ft))) - shalai = shalai + sum(cpatch%elai_profile(CL,ft,1:cpatch%nrad(CL,ft))) - - end do - end do - - shalai = shalai-sunlai - - if(sunlai+shalai > 0._r8)then - bc_out(s)%fsun_pa(ifp) = sunlai / (sunlai+shalai) - else - bc_out(s)%fsun_pa(ifp) = 0._r8 - endif - - if(debug)then - if(bc_out(s)%fsun_pa(ifp) > 1._r8)then - write(fates_log(),*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & - sunlai,shalai - endif - end if - - elai = calc_areaindex(cpatch,'elai') - - bc_out(s)%laisun_pa(ifp) = elai*bc_out(s)%fsun_pa(ifp) - bc_out(s)%laisha_pa(ifp) = elai*(1.0_r8-bc_out(s)%fsun_pa(ifp)) - - ! Absorbed PAR profile through canopy - ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo - ! are canopy integrated so that layer values equal big leaf values. - - if ( debug ) write(fates_log(),*) 'edsurfRad 645 ',cpatch%NCL_p,numpft - - do CL = 1, cpatch%NCL_p - do FT = 1,numpft - - if ( debug ) write(fates_log(),*) 'edsurfRad 649 ',cpatch%nrad(CL,ft) - - do iv = 1, cpatch%nrad(CL,ft) - - cpatch%ed_parsun_z(CL,ft,iv) = & - bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(CL,ft,iv) + & - bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(CL,ft,iv) - - if ( debug )write(fates_log(),*) 'edsurfRad 663 ', cpatch%ed_parsun_z(CL,ft,iv) - - cpatch%ed_parsha_z(CL,ft,iv) = & - bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sha_z(CL,ft,iv) + & - bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sha_z(CL,ft,iv) - - if ( debug ) write(fates_log(),*) 'edsurfRad 669 ', cpatch%ed_parsha_z(CL,ft,iv) - - end do !iv - end do !FT - end do !CL - - ! Convert normalized radiation error units from fraction of radiation to W/m2 - cpatch%radiation_error = cpatch%radiation_error * (bc_in(s)%solad_parb(ifp,ipar) + & - bc_in(s)%solai_parb(ifp,ipar)) - - ! output the actual PAR profiles through the canopy for diagnostic purposes - do CL = 1, cpatch%NCL_p - do FT = 1,numpft - do iv = 1, cpatch%nrad(CL,ft) - cpatch%parprof_pft_dir_z(CL,FT,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dir_z(idirect,CL,FT,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dir_z(idiffuse,CL,FT,iv)) - - cpatch%parprof_pft_dif_z(CL,FT,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dif_z(idirect,CL,FT,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dif_z(idiffuse,CL,FT,iv)) - - end do ! iv - end do ! FT - end do ! CL - - else - - ! Two-stream - ! ----------------------------------------------------------- - do ib = 1,hlm_numSWb - cpatch%twostr%band(ib)%Rbeam_atm = bc_in(s)%solad_parb(ifp,ib) - cpatch%twostr%band(ib)%Rdiff_atm = bc_in(s)%solai_parb(ifp,ib) - end do - - area_vlpfcl(:,:,:) = 0._r8 - cpatch%parprof_pft_dir_z(:,:,:) = 0._r8 - cpatch%parprof_pft_dif_z(:,:,:) = 0._r8 - cpatch%f_sun(:,:,:) = 0._r8 - cpatch%ed_parsun_z(:,:,:) = 0._r8 - cpatch%ed_parsha_z(:,:,:) = 0._r8 - - call FatesPatchFSun(cpatch, & - bc_out(s)%fsun_pa(ifp), & - bc_out(s)%laisun_pa(ifp), & - bc_out(s)%laisha_pa(ifp)) - - associate(twostr => cpatch%twostr) - - do cl = 1,twostr%n_lyr - do icol = 1,twostr%n_col(cl) - - ft = twostr%scelg(cl,icol)%pft - if_notair: if (ft>0) then - area_frac = twostr%scelg(cl,icol)%area - vai = twostr%scelg(cl,icol)%sai+twostr%scelg(cl,icol)%lai - nv = minloc(dlower_vai, DIM=1, MASK=(dlower_vai>vai)) - do iv = 1, nv - - vai_top = dlower_vai(iv)-dinc_vai(iv) - vai_bot = min(dlower_vai(iv),twostr%scelg(cl,icol)%sai+twostr%scelg(cl,icol)%lai) - - cpatch%parprof_pft_dir_z(cl,ft,iv) = cpatch%parprof_pft_dir_z(cl,ft,iv) + & - area_frac*twostr%GetRb(cl,icol,ivis,vai_top) - cpatch%parprof_pft_dif_z(cl,ft,iv) = cpatch%parprof_pft_dif_z(cl,ft,iv) + & - area_frac*twostr%GetRdDn(cl,icol,ivis,vai_top) + & - area_frac*twostr%GetRdUp(cl,icol,ivis,vai_top) - - call twostr%GetAbsRad(cl,icol,ipar,vai_top,vai_bot, & - Rb_abs,Rd_abs,Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow,leaf_sun_frac) - - cpatch%f_sun(cl,ft,iv) = cpatch%f_sun(cl,ft,iv) + & - area_frac*leaf_sun_frac - cpatch%ed_parsun_z(cl,ft,iv) = cpatch%ed_parsun_z(cl,ft,iv) + & - area_frac*(rd_abs_leaf*leaf_sun_frac + rb_abs_leaf) - cpatch%ed_parsha_z(cl,ft,iv) = cpatch%ed_parsha_z(cl,ft,iv) + & - area_frac*rd_abs_leaf*(1._r8-leaf_sun_frac) - - area_vlpfcl(iv,ft,cl) = area_vlpfcl(iv,ft,cl) + area_frac - end do - end if if_notair - end do - - do ft = 1,numpft - do_iv: do iv = 1, nlevleaf - if(area_vlpfcl(iv,ft,cl) cpatch%younger - enddo - - - enddo - return - -end subroutine FatesSunShadeFracs - - -! ! MOVE TO THE INTERFACE -! subroutine ED_CheckSolarBalance(g,filter_nourbanp,num_nourbanp,fsa,fsr,forc_solad,forc_solai) - - -! implicit none -! integer,intent(in),dimension(:) :: gridcell ! => gridcell index -! integer,intent(in),dimension(:) :: filter_nourbanp ! => patch filter for non-urban points -! integer, intent(in) :: num_nourbanp ! number of patches in non-urban points in patch filter -! real(r8),intent(in),dimension(:,:) :: forc_solad ! => atm2lnd_inst%forc_solad_grc, direct radiation (W/m**2 -! real(r8),intent(in),dimension(:,:) :: forc_solai ! => atm2lnd_inst%forc_solai_grc, diffuse radiation (W/m**2) -! real(r8),intent(in),dimension(:,:) :: fsa ! => solarabs_inst%fsa_patch, solar radiation absorbed (total) (W/m**2) -! real(r8),intent(in),dimension(:,:) :: fsr ! => solarabs_inst%fsr_patch, solar radiation reflected (W/m**2) - -! integer :: p -! integer :: fp -! integer :: g -! real(r8) :: errsol - -! do fp = 1,num_nourbanp -! p = filter_nourbanp(fp) -! g = gridcell(p) -! errsol = (fsa(p) + fsr(p) - (forc_solad(g,1) + forc_solad(g,2) + forc_solai(g,1) + forc_solai(g,2))) -! if(abs(errsol) > 0.1_r8)then -! write(fates_log(),*) 'sol error in surf rad',p,g, errsol -! endif -! end do -! return -! end subroutine ED_CheckSolarBalance + area_vlpfcl(:,:,:) = 0._r8 + cpatch%f_sun(:,:,:) = 0._r8 + + call FatesPatchFSun(cpatch, & + bc_out(s)%fsun_pa(ifp), & + bc_out(s)%laisun_pa(ifp), & + bc_out(s)%laisha_pa(ifp)) + + associate(twostr => cpatch%twostr) + + do_cl: do cl = 1,twostr%n_lyr + do_icol: do icol = 1,twostr%n_col(cl) + + ft = twostr%scelg(cl,icol)%pft + if_notair: if (ft>0) then + area_frac = twostr%scelg(cl,icol)%area + vai = twostr%scelg(cl,icol)%sai+twostr%scelg(cl,icol)%lai + nv = minloc(dlower_vai, DIM=1, MASK=(dlower_vai>vai)) + do iv = 1, nv + + vai_top = dlower_vai(iv)-dinc_vai(iv) + vai_bot = min(dlower_vai(iv),twostr%scelg(cl,icol)%sai+twostr%scelg(cl,icol)%lai) + + cpatch%parprof_pft_dir_z(cl,ft,iv) = cpatch%parprof_pft_dir_z(cl,ft,iv) + & + area_frac*twostr%GetRb(cl,icol,ivis,vai_top) + cpatch%parprof_pft_dif_z(cl,ft,iv) = cpatch%parprof_pft_dif_z(cl,ft,iv) + & + area_frac*twostr%GetRdDn(cl,icol,ivis,vai_top) + & + area_frac*twostr%GetRdUp(cl,icol,ivis,vai_top) + + call twostr%GetAbsRad(cl,icol,ipar,vai_top,vai_bot, & + Rb_abs,Rd_abs,Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow,leaf_sun_frac) + + cpatch%f_sun(cl,ft,iv) = cpatch%f_sun(cl,ft,iv) + & + area_frac*leaf_sun_frac + cpatch%ed_parsun_z(cl,ft,iv) = cpatch%ed_parsun_z(cl,ft,iv) + & + area_frac*(rd_abs_leaf*leaf_sun_frac + rb_abs_leaf) + cpatch%ed_parsha_z(cl,ft,iv) = cpatch%ed_parsha_z(cl,ft,iv) + & + area_frac*rd_abs_leaf*(1._r8-leaf_sun_frac) + + area_vlpfcl(iv,ft,cl) = area_vlpfcl(iv,ft,cl) + area_frac + end do + end if if_notair + end do do_icol + + do ft = 1,numpft + do iv = 1, nlevleaf + if(area_vlpfcl(iv,ft,cl) cpatch%younger + enddo + + + enddo + return + + end subroutine FatesSunShadeFracs end module FatesRadiationDriveMod From 460645d0843e542fc728b26c230157d2667e5ffe Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 18 Oct 2023 12:38:37 -0400 Subject: [PATCH 145/250] more cleaning of radiation history --- main/FatesHistoryInterfaceMod.F90 | 34 +++++++++++++++++-------------- 1 file changed, 19 insertions(+), 15 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index cdf50d8730..68d91d1a26 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -4755,14 +4755,14 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep hio_laisun_clllpf => this%hvars(ih_laisun_clllpf)%r82d, & hio_laisha_clllpf => this%hvars(ih_laisha_clllpf)%r82d, & hio_crownfrac_clllpf => this%hvars(ih_crownfrac_clllpf)%r82d, & - hio_laisun_top_si_can => this%hvars(ih_laisun_top_si_can)%r82d, & - hio_laisha_top_si_can => this%hvars(ih_laisha_top_si_can)%r82d, & hio_parprof_dir_si_cnlf => this%hvars(ih_parprof_dir_si_cnlf)%r82d, & hio_parprof_dif_si_cnlf => this%hvars(ih_parprof_dif_si_cnlf)%r82d, & hio_parprof_dir_si_cnlfpft => this%hvars(ih_parprof_dir_si_cnlfpft)%r82d, & hio_parprof_dif_si_cnlfpft => this%hvars(ih_parprof_dif_si_cnlfpft)%r82d, & hio_parsun_si_can => this%hvars(ih_parsun_si_can)%r82d, & - hio_parsha_si_can => this%hvars(ih_parsha_si_can)%r82d ) + hio_parsha_si_can => this%hvars(ih_parsha_si_can)%r82d, & + hio_laisun_si_can => this%hvars(ih_laisun_si_can)%r82d, & + hio_laisha_si_can => this%hvars(ih_laisha_si_can)%r82d ) ! Flush the relevant history variables call this%flush_hvars(nc,upfreq_in=upfreq_hifr_multi) @@ -5080,10 +5080,14 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep hio_laisha_si_can(io_si,ican) = hlm_hio_ignore_val else - hio_parsun_si_can(io_si,ican) = hio_parsun_si_can(io_si,ican)/cl_area - hio_parsha_si_can(io_si,ican) = hio_parsha_si_can(io_si,ican)/cl_area - hio_laisun_si_can(io_si,ican) = hio_laisun_si_can(io_si,ican)/cl_area - hio_laisha_si_can(io_si,ican) = hio_laisha_si_can(io_si,ican)/cl_area + ! Since these are integrated metrics, ie absorbed over depth + ! and total leaf over depth, we just want to normalize by the + ! the area of the footprint. The weightings they had + ! recieved were always in m2 (ie the footprint of the bin) + hio_parsun_si_can(io_si,ican) = hio_parsun_si_can(io_si,ican) * site_area_veg_inv + hio_parsha_si_can(io_si,ican) = hio_parsha_si_can(io_si,ican) * site_area_veg_inv + hio_laisun_si_can(io_si,ican) = hio_laisun_si_can(io_si,ican) * site_area_veg_inv + hio_laisha_si_can(io_si,ican) = hio_laisha_si_can(io_si,ican) * site_area_veg_inv end if end do do_ican2 @@ -7042,13 +7046,13 @@ subroutine define_history_vars(this, initialize_variables) long='PAR absorbed by sunlit leaves in each canopy layer', & use_default='inactive', avgflag='A', vtype=site_can_r8, & hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_parsun_top_si_can ) + index = ih_parsun_si_can ) call this%set_history_var(vname='FATES_PARSHA_CL', units='W m-2', & long='PAR absorbed by shaded leaves in each canopy layer', & use_default='inactive', avgflag='A', vtype=site_can_r8, & hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_parsha_top_si_can) + index = ih_parsha_si_can) call this%set_history_var(vname='FATES_LAISUN_CLLL', units='m2 m-2', & long='LAI in the sun by each canopy and leaf layer', & @@ -7086,17 +7090,17 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & index = ih_parprof_dif_si_cnlfpft) - call this%set_history_var(vname='FATES_LAISUN_TOP_CL', units='m2 m-2', & - long='LAI in the sun by the top leaf layer of each canopy layer', & + call this%set_history_var(vname='FATES_LAISUN_CL', units='m2 m-2', & + long='LAI of sunlit leaves by canopy layer', & use_default='inactive', avgflag='A', vtype=site_can_r8, & hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_laisun_top_si_can) + index = ih_laisun_si_can) - call this%set_history_var(vname='FATES_LAISHA_TOP_CL', units='m2 m-2', & - long='LAI in the shade by the top leaf layer of each canopy layer', & + call this%set_history_var(vname='FATES_LAISHA_CL', units='m2 m-2', & + long='LAI of shaded leaves by canopy layer', & use_default='inactive', avgflag='A', vtype=site_can_r8, & hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_laisha_top_si_can) + index = ih_laisha_si_can) call this%set_history_var(vname='FATES_PARPROF_DIR_CLLL', units='W m-2', & long='radiative profile of direct PAR through each canopy and leaf layer (averaged across PFTs)', & From bd33520c463cfd11438365a3d49df78841fad563 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 18 Oct 2023 13:45:09 -0600 Subject: [PATCH 146/250] updates to the radiation history diagnostics --- main/FatesHistoryInterfaceMod.F90 | 3 ++- radiation/FatesRadiationDriveMod.F90 | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 68d91d1a26..72c12e04db 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -4714,7 +4714,8 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep integer :: ipa2 ! patch incrementer integer :: clllpf_indx, cnlf_indx, ipft, ican, ileaf ! more iterators and indices real(r8) :: clllpf_area ! area footprint (m2) for the current cl x ll x pft bin - real(r8) :: clpf_area ! area footprint (m2) for the cl x pft bin (ie top ll bin) + real(r8) :: clll_area ! area footprint (m2) for the cl x ll bin (ie adds up pfts in parallel) + real(r8) :: cl_area ! total weight of all ll x pft bins in the canopy layer type(fates_patch_type),pointer :: cpatch type(fates_cohort_type),pointer :: ccohort diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index 160a726810..6c083e62b8 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -1358,7 +1358,7 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) end do do_icol do ft = 1,numpft - do iv = 1, nlevleaf + do_iv: do iv = 1, nlevleaf if(area_vlpfcl(iv,ft,cl) Date: Wed, 18 Oct 2023 16:03:45 -0400 Subject: [PATCH 147/250] Changed the avmu radiation parameter to a constant remembered in the rad_params structure, so it doesnt have to be recalculated over and over again --- radiation/TwoStreamMLPEMod.F90 | 21 ++++++++------------- 1 file changed, 8 insertions(+), 13 deletions(-) diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index 9149e15a0e..2f313b25f8 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -96,6 +96,7 @@ Module TwoStreamMLPEMod ! Derived parameters real(r8), allocatable :: phi1(:) ! intermediate term for kd and kb real(r8), allocatable :: phi2(:) ! intermediate term for kd and kb + real(r8), allocatable :: avmu(:) ! average "av" inverse optical depth "mu" per unit leaf and stem area real(r8), allocatable :: kd_leaf(:) ! Mean optical depth per unit area leaves in diffuse real(r8), allocatable :: kd_stem(:) ! Mean optical depth per unit area stems in diffuse real(r8), allocatable :: om_leaf(:,:) ! Leaf scattering coefficient (band x pft) @@ -338,6 +339,7 @@ subroutine AllocateRadParams(n_pft,n_bands) allocate(rad_params%phi1(n_pft)) allocate(rad_params%phi2(n_pft)) + allocate(rad_params%avmu(n_pft)) allocate(rad_params%kd_leaf(n_pft)) allocate(rad_params%kd_stem(n_pft)) allocate(rad_params%om_leaf(n_bands,n_pft)) @@ -641,7 +643,6 @@ end subroutine Dump subroutine ParamPrep() - real(r8) :: avmu ! average inverse optical depth (see Eq 3.4 CLM50 tech man) integer :: ft integer :: nbands integer :: numpft @@ -674,13 +675,14 @@ subroutine ParamPrep() ! There must be protections on xl to prevent div0 and other weirdness rad_params%phi1(ft) = 0.5_r8 - 0.633_r8*rad_params%xl(ft) - 0.330_r8*rad_params%xl(ft)*rad_params%xl(ft) rad_params%phi2(ft) = 0.877_r8 * (1._r8 - 2._r8*rad_params%phi1(ft)) !0 = horiz leaves, 1 - vert leaves. - - avmu = (1._r8/rad_params%phi2(ft))* & + + ! Eq. 3.4 CLM50 Tech Man + rad_params%avmu(ft) = (1._r8/rad_params%phi2(ft))* & (1._r8-(rad_params%phi1(ft)/rad_params%phi2(ft))* & log((rad_params%phi2(ft)+rad_params%phi1(ft))/rad_params%phi1(ft))) do ib = 1, nbands - rad_params%Kd_leaf(ft) = rad_params%clumping_index(ft)/avmu + rad_params%Kd_leaf(ft) = rad_params%clumping_index(ft)/rad_params%avmu(ft) rad_params%Kd_stem(ft) = 1._r8 ! Isotropic assumption rad_params%om_leaf(ib,ft) = rad_params%rhol(ib,ft) + rad_params%taul(ib,ft) @@ -856,7 +858,6 @@ subroutine ZenithPrep(this,cosz) integer :: ican ! scattering element canopy layer index (top down) integer :: icol ! scattering element column real(r8) :: asu ! single scattering albedo - real(r8) :: avmu ! Average inverse diffuse optical depth per unit leaf area real(r8) :: gdir real(r8) :: tmp0,tmp1,tmp2 real(r8) :: betab_veg ! beam backscatter for vegetation (no snow) @@ -906,12 +907,6 @@ subroutine ZenithPrep(this,cosz) scelg%Kb = min(kb_max,(scelg%lai*scelg%Kb_leaf + scelg%sai*1.0)/(scelg%lai+scelg%sai)) - ! Eq. 3.4 CLM50 Tech Man - ! avmu is the average "av" inverse optical depth "mu" per unit leaf and stem area - - avmu = (1._r8 - rad_params%phi1(ft)/rad_params%phi2(ft) * & - log((rad_params%phi1(ft)+rad_params%phi2(ft))/rad_params%phi1(ft))) / rad_params%phi2(ft) - ! Component terms for asu (single scatering albedo) tmp0 = gdir + rad_params%phi2(ft) * cosz tmp1 = rad_params%phi1(ft) * cosz @@ -936,7 +931,7 @@ subroutine ZenithPrep(this,cosz) asu = 0.5_r8 * gdir / tmp0 * tmp2 - betab_veg = (1._r8 + avmu*scelg%Kb) / (avmu*scelg%Kb) * asu + betab_veg = (1._r8 + rad_params%avmu(ft)*scelg%Kb) / (rad_params%avmu(ft)*scelg%Kb) * asu om_veg = (scelg%lai*rad_params%om_leaf(ib,ft) + & scelg%sai*rad_params%om_stem(ib,ft))/(scelg%lai+scelg%sai) @@ -950,7 +945,7 @@ subroutine ZenithPrep(this,cosz) if(debug)then if( .not.(scelb%betab==scelb%betab))then write(log_unit,*)"Beam backscatter fraction is NaN" - write(log_unit,*) betab_om,scelb%om,om_veg,this%frac_snow,betab_veg,asu,avmu,scelg%Kb + write(log_unit,*) betab_om,scelb%om,om_veg,this%frac_snow,betab_veg,asu,rad_params%avmu(ft),scelg%Kb call endrun(msg=errMsg(sourcefile, __LINE__)) end if end if From b3eb3f1f2034c29b2c4eee8a82472f2f876669e9 Mon Sep 17 00:00:00 2001 From: jessica needham Date: Wed, 18 Oct 2023 16:57:30 -0700 Subject: [PATCH 148/250] remove unnecessary columns from inventory init --- main/FatesInventoryInitMod.F90 | 56 ++++++++++------------------------ 1 file changed, 16 insertions(+), 40 deletions(-) diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index ec099860f1..edfa97cf59 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -16,7 +16,12 @@ module FatesInventoryInitMod ! See: https://github.com/EDmodel/ED2/blob/master/ED/src/io/ed_read_ed10_20_history.f90 ! At the time of writing this ED2 is unlicensed, and only concepts were borrowed with no direct ! code copied. - !----------------------------------------------------------------------------------------------- + ! + ! + ! Update: Jessica Needham October 2023 + ! As discussed in FATES issue #1062 we decided to remove columns not used in FATES from the + ! PSS and CSS files. + !----------------------------------------------------------------------------------------------- ! CIME GLOBALS @@ -744,14 +749,6 @@ subroutine set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name ! trk (integer) LU type index (0 non-forest, 1 secondary, 2 primary ! age (years) Time since this patch was disturbed (created) ! area (fraction) Fraction of the site occupied by this patch - ! water (NA) Water content of soil (NOT USED) - ! fsc (kg/m2) Fast Soil Carbon - ! stsc (kg/m2) Structural Soil Carbon - ! stsl (kg/m2) Structural Soil Lignin - ! ssc (kg/m2) Slow Soil Carbon - ! psc (NA) Passive Soil Carbon (NOT USED) - ! msn (kg/m2) Mineralized Soil Nitrogen - ! fsn (kg/m2) Fast Soil Nitrogen ! -------------------------------------------------------------------------------------------- use FatesSizeAgeTypeIndicesMod, only: get_age_class_index @@ -772,14 +769,6 @@ subroutine set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name character(len=patchname_strlen) :: p_name ! unique string identifier of patch real(r8) :: p_age ! Patch age [years] real(r8) :: p_area ! Patch area [fraction] - real(r8) :: p_water ! Patch water (unused) - real(r8) :: p_fsc ! Patch fast soil carbon - real(r8) :: p_stsc ! Patch structural soil carbon - real(r8) :: p_stsl ! Patch structural soil lignins - real(r8) :: p_ssc ! Patch slow soil carbon - real(r8) :: p_psc ! Patch P soil carbon - real(r8) :: p_msn ! Patch mean soil nitrogen - real(r8) :: p_fsn ! Patch fast soil nitrogen integer :: icwd ! index for counting CWD pools integer :: ipft ! index for counting PFTs real(r8) :: pftfrac ! the inverse of the total number of PFTs @@ -788,9 +777,7 @@ subroutine set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name '(F5.2,2X,A4,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2)' - read(pss_file_unit,fmt=*,iostat=ios) p_time, p_name, p_trk, p_age, p_area, & - p_water,p_fsc, p_stsc, p_stsl, p_ssc, & - p_psc, p_msn, p_fsn + read(pss_file_unit,fmt=*,iostat=ios) p_time, p_name, p_trk, p_age, p_area if (ios/=0) return @@ -798,9 +785,7 @@ subroutine set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name if( debug_inv) then write(*,fmt=wr_fmt) & - p_time, p_name, p_trk, p_age, p_area, & - p_water,p_fsc, p_stsc, p_stsl, p_ssc, & - p_psc, p_msn, p_fsn + p_time, p_name, p_trk, p_age, p_area end if ! Fill in the patch's memory structures @@ -859,12 +844,8 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & ! patch (string) patch id string associated with this cohort ! index (integer) cohort index ! dbh (cm) diameter at breast height - ! height (m) height of the tree - ! pft (integer) the plant functional type index (must be consistent with param file) + ! pft (integer) the plant functional type index (must be consistent with param file) ! n (/m2) The plant number density - ! bdead (kgC/plant)The dead biomass per indiv of this cohort (NOT USED) - ! balive (kgC/plant)The live biomass per indiv of this cohort (NOT USED) - ! avgRG (cm/yr?) Average Radial Growth (NOT USED) ! -------------------------------------------------------------------------------------------- use FatesAllometryMod , only : h_allom @@ -895,12 +876,8 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & character(len=patchname_strlen) :: p_name ! The patch associated with this cohort character(len=cohortname_strlen) :: c_name ! cohort index real(r8) :: c_dbh ! diameter at breast height (cm) - real(r8) :: c_height ! tree height (m) integer :: c_pft ! plant functional type index real(r8) :: c_nplant ! plant density (/m2) - real(r8) :: c_bdead ! dead biomass (kg) - real(r8) :: c_balive ! live biomass (kg) - real(r8) :: c_avgRG ! avg radial growth (NOT USED) real(r8) :: site_spread ! initial guess of site spread ! should be quickly re-calculated integer,parameter :: rstatus = 0 ! recruit status @@ -938,13 +915,12 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & integer, parameter :: recruitstatus = 0 - read(css_file_unit,fmt=*,iostat=ios) c_time, p_name, c_name, c_dbh, c_height, & - c_pft, c_nplant, c_bdead, c_balive, c_avgRG + read(css_file_unit,fmt=*,iostat=ios) c_time, p_name, c_name, c_dbh, & + c_pft, c_nplant if( debug_inv) then write(*,fmt=wr_fmt) & - c_time, p_name, c_name, c_dbh, c_height, & - c_pft, c_nplant, c_bdead, c_balive, c_avgRG + c_time, p_name, c_name, c_dbh, c_pft, c_nplant end if if (ios/=0) return @@ -961,8 +937,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & if(.not.matched_patch)then write(fates_log(), *) 'could not match a cohort with a patch' write(fates_log(),fmt=wr_fmt) & - c_time, p_name, c_name, c_dbh, c_height, & - c_pft, c_nplant, c_bdead, c_balive, c_avgRG + c_time, p_name, c_name, c_dbh, c_pft, c_nplant call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1215,6 +1190,7 @@ subroutine write_inventory_type1(currentSite) ! a recommended file type for restarting a run. ! The files will have a lat/long tag added to their name, and will be ! generated in the run folder. + ! JFN Oct 2023 - updated to get rid of unused ED columns ! -------------------------------------------------------------------------------- use shr_file_mod, only : shr_file_getUnit @@ -1267,8 +1243,8 @@ subroutine write_inventory_type1(currentSite) open(unit=pss_file_out,file=trim(pss_name_out), status='UNKNOWN',action='WRITE',form='FORMATTED') open(unit=css_file_out,file=trim(css_name_out), status='UNKNOWN',action='WRITE',form='FORMATTED') - write(pss_file_out,*) 'time patch trk age area water fsc stsc stsl ssc psc msn fsn' - write(css_file_out,*) 'time patch cohort dbh height pft nplant bdead alive Avgrg' + write(pss_file_out,*) 'time patch trk age area' + write(css_file_out,*) 'time patch cohort dbh pft nplant' ipatch=0 currentpatch => currentSite%youngest_patch From 10a724c2de48083607cababc290deffdfe1b91ce Mon Sep 17 00:00:00 2001 From: jessica needham Date: Wed, 18 Oct 2023 21:09:23 -0700 Subject: [PATCH 149/250] remove cohort index from inventory init files --- main/FatesInventoryInitMod.F90 | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index edfa97cf59..d1af0be58f 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -842,7 +842,6 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & ! FILE FORMAT: ! time (year) year of measurement ! patch (string) patch id string associated with this cohort - ! index (integer) cohort index ! dbh (cm) diameter at breast height ! pft (integer) the plant functional type index (must be consistent with param file) ! n (/m2) The plant number density @@ -874,7 +873,6 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & class(prt_vartypes), pointer :: prt_obj real(r8) :: c_time ! Time patch was recorded character(len=patchname_strlen) :: p_name ! The patch associated with this cohort - character(len=cohortname_strlen) :: c_name ! cohort index real(r8) :: c_dbh ! diameter at breast height (cm) integer :: c_pft ! plant functional type index real(r8) :: c_nplant ! plant density (/m2) @@ -915,12 +913,12 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & integer, parameter :: recruitstatus = 0 - read(css_file_unit,fmt=*,iostat=ios) c_time, p_name, c_name, c_dbh, & + read(css_file_unit,fmt=*,iostat=ios) c_time, p_name, c_dbh, & c_pft, c_nplant if( debug_inv) then write(*,fmt=wr_fmt) & - c_time, p_name, c_name, c_dbh, c_pft, c_nplant + c_time, p_name, c_dbh, c_pft, c_nplant end if if (ios/=0) return @@ -937,7 +935,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & if(.not.matched_patch)then write(fates_log(), *) 'could not match a cohort with a patch' write(fates_log(),fmt=wr_fmt) & - c_time, p_name, c_name, c_dbh, c_pft, c_nplant + c_time, p_name, c_dbh, c_pft, c_nplant call endrun(msg=errMsg(sourcefile, __LINE__)) end if From 97707c0275d22f95ba8a15b2a87a345eb9f5dcc0 Mon Sep 17 00:00:00 2001 From: jessica needham Date: Wed, 18 Oct 2023 21:58:10 -0700 Subject: [PATCH 150/250] add script to convert ed to fates inventory init files --- tools/ed2_to_fates_inventory_init.py | 46 ++++++++++++++++++++++++++++ 1 file changed, 46 insertions(+) create mode 100644 tools/ed2_to_fates_inventory_init.py diff --git a/tools/ed2_to_fates_inventory_init.py b/tools/ed2_to_fates_inventory_init.py new file mode 100644 index 0000000000..a8959134ee --- /dev/null +++ b/tools/ed2_to_fates_inventory_init.py @@ -0,0 +1,46 @@ +#!/usr/bin/env python + +### This script takes a ED2 style inventory init file and converts it to a file compatible with FATES. +# It accepts the following flags: +# --type : patch or cohort +# --fin : input filename +# --fout : output file name + +import argparse +import pandas as pd +import sys + +def main(): + parser = argparse.ArgumentParser(description='Parse command line arguments to this script.') + # + parser.add_argument('--type', dest='fatestype', type=str, help="patch or cohort. Required.", required=True) + parser.add_argument('--fin', dest='fnamein', type=str, help="Input filename. Required.", required=True) + parser.add_argument('--fout', dest='fnameout', type=str, help="Output filename. Required.", required=True) + + args = parser.parse_args() + + # open the input data + dsin = pd.read_csv(args.fnamein, delim_whitespace=True) + + # if patch file delete unnecessary patch columns + if args.fatestype == 'patch' : + keep_col = ['time', 'patch', 'trk', 'age', 'area'] + newds = dsin[keep_col] + + + # if cohort file delete unnecessary cohort columns + elif args.fatestype == 'cohort' : + keep_col = ['time', 'patch', 'dbh', 'pft', 'nplant'] + newds = dsin[keep_col] + + else : + print("type must be one of patch or cohort") + + + newds.to_csv(args.fnameout , index=False, sep=' ') +# ======================================================================================================== +# This is the actual call to main + +if __name__ == "__main__": + main() + From 156a17a821a4ca6760b7f9e27e234da58290120d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 19 Oct 2023 12:15:28 -0400 Subject: [PATCH 151/250] Added isnan() functions instead of comparing to self --- radiation/TwoStreamMLPEMod.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index 2f313b25f8..f52f037215 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -372,7 +372,7 @@ function GetRdDn(this,ican,icol,ib,vai) result(r_diff_dn) scelb%B2d*scelb%lambda2_diff*exp(-scelb%a*vai)) if(debug)then - if(r_diff_dn.ne.r_diff_dn)then + if(isnan(r_diff_dn))then write(log_unit,*)"GETRDN" write(log_unit,*)scelg%Kb write(log_unit,*)scelb%a @@ -805,9 +805,11 @@ subroutine CanopyPrep(this,frac_snow) scelb%betad = betad_om / scelb%om if(debug)then - if(scelb%betad /= scelb%betad)then + if(isnan(scelb%betad))then write(log_unit,*)"nans in canopy prep" - write(log_unit,*) ib,ican,icol,ft,scelb%betad,scelb%om,lai,sai,this%frac_snow,om_snow(ib),vai,om_veg + write(log_unit,*) ib,ican,icol,ft, + write(log_unit,*) scelb%betad,scelb%om,lai,sai + write(log_unit,*) this%frac_snow,om_snow(ib),vai,om_veg write(log_unit,*)"TwoStreamMLPEMod.F90:CanopyPrep" call endrun(msg=errMsg(sourcefile, __LINE__)) end if From c541a74d4ca57492ce146ea66ddc2a46c79be1d8 Mon Sep 17 00:00:00 2001 From: jessica needham Date: Thu, 19 Oct 2023 10:18:04 -0700 Subject: [PATCH 152/250] clean up python script -make simpler --- tools/ed2_to_fates_inventory_init.py | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/tools/ed2_to_fates_inventory_init.py b/tools/ed2_to_fates_inventory_init.py index a8959134ee..a4a00475f4 100644 --- a/tools/ed2_to_fates_inventory_init.py +++ b/tools/ed2_to_fates_inventory_init.py @@ -2,9 +2,7 @@ ### This script takes a ED2 style inventory init file and converts it to a file compatible with FATES. # It accepts the following flags: -# --type : patch or cohort # --fin : input filename -# --fout : output file name import argparse import pandas as pd @@ -13,23 +11,28 @@ def main(): parser = argparse.ArgumentParser(description='Parse command line arguments to this script.') # - parser.add_argument('--type', dest='fatestype', type=str, help="patch or cohort. Required.", required=True) parser.add_argument('--fin', dest='fnamein', type=str, help="Input filename. Required.", required=True) - parser.add_argument('--fout', dest='fnameout', type=str, help="Output filename. Required.", required=True) - + args = parser.parse_args() + # is it a pss or css file? + filetype = args.fnamein.split('.')[1] + + # make the new file name + base_filename = args.fnamein.split('.')[0] + output_filename = f"{base_filename}_{'fates'}.{filetype}" + # open the input data dsin = pd.read_csv(args.fnamein, delim_whitespace=True) # if patch file delete unnecessary patch columns - if args.fatestype == 'patch' : + if filetype == 'pss' : keep_col = ['time', 'patch', 'trk', 'age', 'area'] newds = dsin[keep_col] # if cohort file delete unnecessary cohort columns - elif args.fatestype == 'cohort' : + elif filetype == 'css' : keep_col = ['time', 'patch', 'dbh', 'pft', 'nplant'] newds = dsin[keep_col] @@ -37,7 +40,7 @@ def main(): print("type must be one of patch or cohort") - newds.to_csv(args.fnameout , index=False, sep=' ') + newds.to_csv(output_filename, index=False, sep=' ') # ======================================================================================================== # This is the actual call to main From 1108024d67d3a8bfc9775c66694508ced91c8b49 Mon Sep 17 00:00:00 2001 From: jessica needham Date: Mon, 23 Oct 2023 13:49:38 -0700 Subject: [PATCH 153/250] add height back in --- main/FatesInventoryInitMod.F90 | 10 ++++++---- tools/ed2_to_fates_inventory_init.py | 4 ++-- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index d1af0be58f..fdef68cf11 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -843,6 +843,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & ! time (year) year of measurement ! patch (string) patch id string associated with this cohort ! dbh (cm) diameter at breast height + ! height (m) height of vegetation in m. Currently not used. ! pft (integer) the plant functional type index (must be consistent with param file) ! n (/m2) The plant number density ! -------------------------------------------------------------------------------------------- @@ -874,6 +875,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & real(r8) :: c_time ! Time patch was recorded character(len=patchname_strlen) :: p_name ! The patch associated with this cohort real(r8) :: c_dbh ! diameter at breast height (cm) + real(r8) :: c_height ! tree height (m) integer :: c_pft ! plant functional type index real(r8) :: c_nplant ! plant density (/m2) real(r8) :: site_spread ! initial guess of site spread @@ -914,11 +916,11 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & read(css_file_unit,fmt=*,iostat=ios) c_time, p_name, c_dbh, & - c_pft, c_nplant + c_height, c_pft, c_nplant if( debug_inv) then write(*,fmt=wr_fmt) & - c_time, p_name, c_dbh, c_pft, c_nplant + c_time, p_name, c_dbh, c_height, c_pft, c_nplant end if if (ios/=0) return @@ -935,7 +937,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & if(.not.matched_patch)then write(fates_log(), *) 'could not match a cohort with a patch' write(fates_log(),fmt=wr_fmt) & - c_time, p_name, c_dbh, c_pft, c_nplant + c_time, p_name, c_dbh, c_height, c_pft, c_nplant call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1242,7 +1244,7 @@ subroutine write_inventory_type1(currentSite) open(unit=css_file_out,file=trim(css_name_out), status='UNKNOWN',action='WRITE',form='FORMATTED') write(pss_file_out,*) 'time patch trk age area' - write(css_file_out,*) 'time patch cohort dbh pft nplant' + write(css_file_out,*) 'time patch cohort dbh height pft nplant' ipatch=0 currentpatch => currentSite%youngest_patch diff --git a/tools/ed2_to_fates_inventory_init.py b/tools/ed2_to_fates_inventory_init.py index a4a00475f4..b258341a08 100644 --- a/tools/ed2_to_fates_inventory_init.py +++ b/tools/ed2_to_fates_inventory_init.py @@ -33,11 +33,11 @@ def main(): # if cohort file delete unnecessary cohort columns elif filetype == 'css' : - keep_col = ['time', 'patch', 'dbh', 'pft', 'nplant'] + keep_col = ['time', 'patch', 'dbh', 'height', 'pft', 'nplant'] newds = dsin[keep_col] else : - print("type must be one of patch or cohort") + print("file type must be one of patch (pss) or cohort (css)") newds.to_csv(output_filename, index=False, sep=' ') From a26146d869619891703370e7de89352dea422ed2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 24 Oct 2023 10:56:17 -0400 Subject: [PATCH 154/250] Removed old optional two-stream derivations and now using only B1 and B2 instead of up and down components of them --- .../radiation/RadiationUTestDriver.py | 4 +- .../radiation/build_radiation_f90_objects.sh | 1 + radiation/TwoStreamMLPEMod.F90 | 158 +++++++----------- 3 files changed, 61 insertions(+), 102 deletions(-) diff --git a/functional_unit_testing/radiation/RadiationUTestDriver.py b/functional_unit_testing/radiation/RadiationUTestDriver.py index 278b80d644..f8ab759ed2 100644 --- a/functional_unit_testing/radiation/RadiationUTestDriver.py +++ b/functional_unit_testing/radiation/RadiationUTestDriver.py @@ -164,10 +164,10 @@ def main(argv): if(False): SunFracTests() - if(False): + if(True): SingleElementPerturbTest() - if(True): + if(False): SerialParallelCanopyTest() plt.show() diff --git a/functional_unit_testing/radiation/build_radiation_f90_objects.sh b/functional_unit_testing/radiation/build_radiation_f90_objects.sh index 3b11d4c0bc..0f10a98f64 100755 --- a/functional_unit_testing/radiation/build_radiation_f90_objects.sh +++ b/functional_unit_testing/radiation/build_radiation_f90_objects.sh @@ -15,6 +15,7 @@ rm -f bld/*.mod # Build the new file with constants +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/FatesConstantsMod.o ../../main/FatesConstantsMod.F90 ${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/WrapShrMod.o f90_src/WrapShrMod.F90 ${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/FatesRadiationMemMod.o ../../radiation/FatesRadiationMemMod.F90 ${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/TwoStreamMLPEMod.o ../../radiation/TwoStreamMLPEMod.F90 diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index f52f037215..cfec744480 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -33,7 +33,6 @@ Module TwoStreamMLPEMod real(r8),parameter :: nearzero = 1.e-20_r8 logical, parameter :: debug=.true. - logical, parameter :: use_derivation1 = .true. real(r8), parameter :: unset_r8 = 1.e-36_r8 real(r8), parameter :: unset_int = -999 integer, parameter :: twostr_vis = 1 ! Named index of visible shortwave radiation @@ -135,14 +134,12 @@ Module TwoStreamMLPEMod ! Terms used in the final solution, also used for decomposing solution real(r8) :: Au ! Compound intercept term real(r8) :: Ad ! Compound intercept term - real(r8) :: B1u ! Compound term w/ lambdas - real(r8) :: B2u ! Compound term w/ lambdas - real(r8) :: B1d ! Compound term w/ lambdas - real(r8) :: B2d ! Compound term w/ lambdas - real(r8) :: lambda1_diff ! Compount term w/ B1d and B1u for diffuse forcing - real(r8) :: lambda2_diff ! Compound term w/ B2d and B2u for diffuse forcing - real(r8) :: lambda1_beam ! Compount term w/ B1d and B1u for beam forcing - real(r8) :: lambda2_beam ! Compound term w/ B2d and B2u for beam forcing + real(r8) :: B1 ! Compound term w/ lambdas (operates on e^{av}) + real(r8) :: B2 ! Compound term w/ lambdas (operates on e^{-av}) + real(r8) :: lambda1_diff ! Compount term w/ B for diffuse forcing + real(r8) :: lambda2_diff ! Compound term w/ B for diffuse forcing + real(r8) :: lambda1_beam ! Compount term w/ B for beam forcing + real(r8) :: lambda2_beam ! Compound term w/ B for beam forcing real(r8) :: a ! Complex term operating on veg area index real(r8) :: om ! scattering coefficient for media as a whole @@ -358,18 +355,18 @@ function GetRdDn(this,ican,icol,ib,vai) result(r_diff_dn) integer,intent(in) :: ib real(r8) :: r_diff_dn - ! Rdn = Ad e−(Kbv) + Re + λ1 B1d e^(av) + λ2 B2d e^(−av) + ! Rdn = Ad e−(Kbv) + Re + λ1 B2 e^(av) + λ2 B1 e^(−av) associate(scelb => this%band(ib)%scelb(ican,icol), & scelg => this%scelg(ican,icol) ) r_diff_dn = this%band(ib)%Rbeam_atm*( & scelb%Ad*exp(-scelg%Kb*vai) + & - scelb%B1d*scelb%lambda1_beam*exp(scelb%a*vai) + & - scelb%B2d*scelb%lambda2_beam*exp(-scelb%a*vai)) + & + scelb%B2*scelb%lambda1_beam*exp(scelb%a*vai) + & + scelb%B1*scelb%lambda2_beam*exp(-scelb%a*vai)) + & this%band(ib)%Rdiff_atm*( & - scelb%B1d*scelb%lambda1_diff*exp(scelb%a*vai) + & - scelb%B2d*scelb%lambda2_diff*exp(-scelb%a*vai)) + scelb%B2*scelb%lambda1_diff*exp(scelb%a*vai) + & + scelb%B1*scelb%lambda2_diff*exp(-scelb%a*vai)) if(debug)then if(isnan(r_diff_dn))then @@ -378,7 +375,7 @@ function GetRdDn(this,ican,icol,ib,vai) result(r_diff_dn) write(log_unit,*)scelb%a write(log_unit,*)vai write(log_unit,*)scelb%Ad - write(log_unit,*)scelb%B1d,scelb%B2d + write(log_unit,*)scelb%B1,scelb%B2 write(log_unit,*)scelb%lambda1_beam,scelb%lambda2_beam write(log_unit,*)scelb%lambda1_diff,scelb%lambda2_diff write(log_unit,*)this%band(ib)%Rbeam_atm @@ -401,18 +398,18 @@ function GetRdUp(this,ican,icol,ib,vai) result(r_diff_up) integer,intent(in) :: ib real(r8) :: r_diff_up - ! Rup = Au e−(Kbv) + Re + λ1 B1u e^(av) + λ2 B2u e^(−av) + ! Rup = Au e−(Kbv) + Re + λ1 B1 e^(av) + λ2 B2 e^(−av) associate(scelb => this%band(ib)%scelb(ican,icol), & scelg => this%scelg(ican,icol) ) r_diff_up = this%band(ib)%Rbeam_atm*( & scelb%Au*exp(-scelg%Kb*vai) + & - scelb%B1u*scelb%lambda1_beam*exp(scelb%a*vai) + & - scelb%B2u*scelb%lambda2_beam*exp(-scelb%a*vai)) + & + scelb%B1*scelb%lambda1_beam*exp(scelb%a*vai) + & + scelb%B2*scelb%lambda2_beam*exp(-scelb%a*vai)) + & this%band(ib)%Rdiff_atm*( & - scelb%B1u*scelb%lambda1_diff*exp(scelb%a*vai) + & - scelb%B2u*scelb%lambda2_diff*exp(-scelb%a*vai)) + scelb%B1*scelb%lambda1_diff*exp(scelb%a*vai) + & + scelb%B2*scelb%lambda2_diff*exp(-scelb%a*vai)) end associate end function GetRdUp @@ -444,8 +441,8 @@ subroutine GetAbsRad(this,ican,icol,ib,vai_top,vai_bot, & ! which includes an assumption of the leaf/stem proportionality. ! --------------------------------------------------------------------------- ! Solution for radiative intensity of diffuse up and down at tai=v - ! Rup = Au e−(Kbv) + Re + λ1 B1u e^(av) + λ2 B2u e^(−av) - ! Rdn = Ad e−(Kbv) + Re + λ1 B1d e^(av) + λ2 B2d e^(−av) + ! Rup = Au e−(Kbv) + Re + λ1 B1 e^(av) + λ2 B2 e^(−av) + ! Rdn = Ad e−(Kbv) + Re + λ1 B2 e^(av) + λ2 B1 e^(−av) ! --------------------------------------------------------------------------- ! Arguments @@ -807,7 +804,7 @@ subroutine CanopyPrep(this,frac_snow) if(debug)then if(isnan(scelb%betad))then write(log_unit,*)"nans in canopy prep" - write(log_unit,*) ib,ican,icol,ft, + write(log_unit,*) ib,ican,icol,ft write(log_unit,*) scelb%betad,scelb%om,lai,sai write(log_unit,*) this%frac_snow,om_snow(ib),vai,om_veg write(log_unit,*)"TwoStreamMLPEMod.F90:CanopyPrep" @@ -1077,7 +1074,7 @@ subroutine Solve(this, ib, & integer :: n_eq ! Total number of equations integer :: ilem_off ! Offset, or total number of elements above layer of interest - real(r8) :: b1,b2,a2,nu_sqrd,nu ! intermediate terms, see documentation + real(r8) :: b1,b2,a2,nu_sqrd ! intermediate terms, see documentation real(r8) :: Rbeam_top ! Mean beam radiation at top of layer [W/m2] real(r8) :: Rbeam_bot ! Mean beam radiation at bottom of layer [W/m2] real(r8) :: vai ! Vegetation area index [m2 vegetation / m2 ground] @@ -1193,71 +1190,32 @@ subroutine Solve(this, ib, & scelbp%a = sqrt(a2) - b1 = (scelgp%Kd*(1._r8-scelbp%om)*(1._r8-2._r8*scelbp%betab)+scelgp%Kb) * & + b2 = -(scelgp%Kd*(1._r8-scelbp%om)*(1._r8-2._r8*scelbp%betab)+scelgp%Kb) * & scelbp%om*scelgp%Kb*scelbp%Rbeam0 - b2 = (scelgp%Kd*(scelbp%om-1._r8-2._r8*scelbp%om*scelbp%betad) - & + + b1 = -(scelgp%Kd*(1._r8-scelbp%om+2._r8*scelbp%om*scelbp%betad) + & (1._r8-2._r8*scelbp%betab)*scelgp%Kb) * & scelbp%om*scelgp%Kb*scelbp%Rbeam0 - - if(use_derivation1) then - - nu_sqrd = (1._r8-scelbp%om+2._r8*scelbp%om*scelbp%betad)/(1._r8-scelbp%om) - - if(nu_sqrd<0._r8)then - write(log_unit,*)'nu_sqrd is less than zero' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! B_1 up term from documentation: - scelbp%B1u = 0.5_r8*(1._r8+sqrt(nu_sqrd)) - - ! B_2 up term from documentation - scelbp%B2u = 0.5_r8*(1._r8-sqrt(nu_sqrd)) - - ! B_1 down term from documentation: - scelbp%B1d = -0.5_r8*(1._r8-sqrt(nu_sqrd)) - - ! B_2 down term from documentation - scelbp%B2d = -0.5_r8*(1._r8+sqrt(nu_sqrd)) - - ! A_2 term from documentation - scelbp%Ad = -0.5_r8*(b2-b1)/(scelbp%a*scelbp%a-scelgp%Kb*scelgp%Kb) ! aka half b2 minus b1 - - ! A_1 term from documentation - scelbp%Au = -0.5_r8*(b2+b1)/(scelbp%a*scelbp%a-scelgp%Kb*scelgp%Kb) ! aka half b1 plus b2 - - else - - nu_sqrd = (scelbp%om-1._r8)/(scelbp%om - 1._r8-2._r8*scelbp%om*scelbp%betad) - - nu = (scelgp%Kd*(scelbp%om-1._r8))/scelbp%a - - b1 = -b1 - - ! B 1 up term from documentation - !scelbp%B1u = 0.5_r8*(1._r8-nu) - scelbp%B1u = 0.5_r8*(1._r8-sqrt(nu_sqrd)) - - ! B_2 term from documentation - !scelbp%B2u = 0.5_r8*(1._r8+nu) - scelbp%B2u = 0.5_r8*(1._r8+sqrt(nu_sqrd)) - - ! B 1 up term from documentation - !scelbp%B1d = 0.5_r8*(1._r8+nu) - scelbp%B1d = 0.5_r8*(1._r8+sqrt(nu_sqrd)) - - ! B_2 term from documentation - !scelbp%B2d = 0.5_r8*(1._r8-nu) - scelbp%B2d = 0.5_r8*(1._r8-sqrt(nu_sqrd)) - - ! A_2 term from documentation - scelbp%Ad = -0.5_r8*(b2+b1)/(scelbp%a*scelbp%a-scelgp%Kb*scelgp%Kb) ! aka half b2 minus b1 - - ! A_1 term from documentation - scelbp%Au = -0.5_r8*(b2-b1)/(scelbp%a*scelbp%a-scelgp%Kb*scelgp%Kb) ! aka half b1 plus b2 - - + + nu_sqrd = (1._r8-scelbp%om)/(1._r8-scelbp%om+2._r8*scelbp%om*scelbp%betad) + + if(nu_sqrd<0._r8)then + write(log_unit,*)'nu_sqrd is less than zero' + call endrun(msg=errMsg(sourcefile, __LINE__)) end if + + ! B_1 term from documentation: + scelbp%B1 = 0.5_r8*(1._r8+sqrt(nu_sqrd)) + + ! B_2 term from documentation + scelbp%B2 = 0.5_r8*(1._r8-sqrt(nu_sqrd)) + + ! A_2 term from documentation + scelbp%Ad = -0.5_r8*(b1+b2)/(scelbp%a*scelbp%a-scelgp%Kb*scelgp%Kb) ! aka half b2 minus b1 + + ! A_1 term from documentation + scelbp%Au = -0.5_r8*(b1-b2)/(scelbp%a*scelbp%a-scelgp%Kb*scelgp%Kb) ! aka half b1 plus b2 + end do end do @@ -1326,8 +1284,8 @@ subroutine Solve(this, ib, & k1 = 2*(ilem-1)+1 k2 = k1+1 taulamb(qp) = this%band(ib)%Rdiff_atm - this%band(ib)%Rbeam_atm*scelbp%Ad - omega(qp,k1) = scelbp%B1d - omega(qp,k2) = scelbp%B2d + omega(qp,k1) = scelbp%B2 + omega(qp,k2) = scelbp%B1 end do @@ -1367,8 +1325,8 @@ subroutine Solve(this, ib, & ! This term is at v=0 taulamb(qp) = this%band(ib)%Rbeam_atm*this%band(ib)%scelb(ibot,jcol)%Ad - omega(qp,k1) = omega(qp,k1) - this%band(ib)%scelb(ibot,jcol)%B1d - omega(qp,k2) = omega(qp,k2) - this%band(ib)%scelb(ibot,jcol)%B2d + omega(qp,k1) = omega(qp,k1) - this%band(ib)%scelb(ibot,jcol)%B2 + omega(qp,k2) = omega(qp,k2) - this%band(ib)%scelb(ibot,jcol)%B1 ! We need to include the terms from ! all elements above the current element of interest @@ -1385,8 +1343,8 @@ subroutine Solve(this, ib, & vai = scelgp%lai + scelgp%sai taulamb(qp) = taulamb(qp) - scelgp%area * this%band(ib)%Rbeam_atm*scelbp%Ad *exp(-scelgp%Kb*vai) - omega(qp,k1) = omega(qp,k1) + scelgp%area * scelbp%B1d*exp(scelbp%a*vai) - omega(qp,k2) = omega(qp,k2) + scelgp%area * scelbp%B2d*exp(-scelbp%a*vai) + omega(qp,k1) = omega(qp,k1) + scelgp%area * scelbp%B2*exp(scelbp%a*vai) + omega(qp,k2) = omega(qp,k2) + scelgp%area * scelbp%B1*exp(-scelbp%a*vai) end do @@ -1428,8 +1386,8 @@ subroutine Solve(this, ib, & vai = scelgp%lai + scelgp%sai taulamb(qp) = this%band(ib)%Rbeam_atm*scelbp%Au*exp(-scelgp%Kb*vai) - omega(qp,k1) = omega(qp,k1) - scelbp%B1u*exp(scelbp%a*vai) - omega(qp,k2) = omega(qp,k2) - scelbp%B2u*exp(-scelbp%a*vai) + omega(qp,k1) = omega(qp,k1) - scelbp%B1*exp(scelbp%a*vai) + omega(qp,k2) = omega(qp,k2) - scelbp%B2*exp(-scelbp%a*vai) ! Terms for mean diffuse exiting lower elements (move out of this loop for efficiency) do jcol = 1,this%n_col(ibot) @@ -1440,8 +1398,8 @@ subroutine Solve(this, ib, & scelbp => this%band(ib)%scelb(ibot,jcol) taulamb(qp) = taulamb(qp) - this%band(ib)%Rbeam_atm*scelgp%area*scelbp%Au - omega(qp,k1) = omega(qp,k1) + scelgp%area*scelbp%B1u - omega(qp,k2) = omega(qp,k2) + scelgp%area*scelbp%B2u + omega(qp,k1) = omega(qp,k1) + scelgp%area*scelbp%B1 + omega(qp,k2) = omega(qp,k2) + scelgp%area*scelbp%B2 end do end do @@ -1476,11 +1434,11 @@ subroutine Solve(this, ib, & - this%band(ib)%albedo_grnd_diff*scelbp%Ad*exp(-scelgp%Kb*vai) & - this%band(ib)%albedo_grnd_beam*scelbp%Rbeam0*exp(-scelgp%Kb*vai)) - omega(qp,k1) = omega(qp,k1) - scelbp%B1u*exp(scelbp%a*vai) - omega(qp,k2) = omega(qp,k2) - scelbp%B2u*exp(-scelbp%a*vai) + omega(qp,k1) = omega(qp,k1) - scelbp%B1*exp(scelbp%a*vai) + omega(qp,k2) = omega(qp,k2) - scelbp%B2*exp(-scelbp%a*vai) - omega(qp,k1) = omega(qp,k1) + this%band(ib)%albedo_grnd_diff*scelbp%B1d*exp(scelbp%a*vai) - omega(qp,k2) = omega(qp,k2) + this%band(ib)%albedo_grnd_diff*scelbp%B2d*exp(-scelbp%a*vai) + omega(qp,k1) = omega(qp,k1) + this%band(ib)%albedo_grnd_diff*scelbp%B2*exp(scelbp%a*vai) + omega(qp,k2) = omega(qp,k2) + this%band(ib)%albedo_grnd_diff*scelbp%B1*exp(-scelbp%a*vai) end do @@ -1671,7 +1629,7 @@ subroutine Solve(this, ib, & write(log_unit,*)" ",scelbp%om*(1.0-scelbp%betad) write(log_unit,*)" ",scelbp%lambda1_beam,scelbp%lambda2_beam write(log_unit,*)" ",scelbp%lambda1_diff,scelbp%lambda2_diff - write(log_unit,*)"AB TERMS: ",scelbp%Ad,scelbp%Au,scelbp%B1d,scelbp%B2d,scelbp%B2d,scelbp%B2u,scelbp%a + write(log_unit,*)"AB TERMS: ",scelbp%Ad,scelbp%Au,scelbp%B1,scelbp%B2,scelbp%a write(log_unit,*)"LAMBDA TERMS: ",scelbp%lambda1_diff,scelbp%lambda2_diff,scelbp%lambda1_beam,scelbp%lambda2_beam end do end do From a9260d087f6ccd90b1ab3903bf36d05a3a5e7c67 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 25 Oct 2023 11:40:23 -0400 Subject: [PATCH 155/250] Added checks on scattering coefficient --- radiation/TwoStreamMLPEMod.F90 | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index f52f037215..a23e4acfff 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -683,10 +683,34 @@ subroutine ParamPrep() do ib = 1, nbands rad_params%Kd_leaf(ft) = rad_params%clumping_index(ft)/rad_params%avmu(ft) - rad_params%Kd_stem(ft) = 1._r8 ! Isotropic assumption + rad_params%Kd_stem(ft) = 1._r8 rad_params%om_leaf(ib,ft) = rad_params%rhol(ib,ft) + rad_params%taul(ib,ft) rad_params%om_stem(ib,ft) = rad_params%rhos(ib,ft) + rad_params%taus(ib,ft) + + if( rad_params%om_leaf(ib,ft) > 0.99_r8 ) then + write(log_unit,*) "In: TwoStreamMLPEMod.F90:ParamPrep()" + write(log_unit,*) "An extremely high leaf scattering coefficient was generated:" + write(log_unit,*) "om = tau + rho" + write(log_unit,*) "band = ",ib + write(log_unit,*) "pft = ",ft + write(log_unit,*) "om_leaf = ",rad_params%om_leaf(ib,ft) + write(log_unit,*) "rhol = ",rad_params%rhol(ib,ft) + write(log_unit,*) "taul = ",rad_params%taul(ib,ft) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if( rad_params%om_stem(ib,ft) > 0.99_r8 ) then + write(log_unit,*) "In: TwoStreamMLPEMod.F90:ParamPrep()" + write(log_unit,*) "An extremely high stem scattering coefficient was generated:" + write(log_unit,*) "om = tau + rho" + write(log_unit,*) "band = ",ib + write(log_unit,*) "pft = ",ft + write(log_unit,*) "om_stem = ",rad_params%om_stem(ib,ft) + write(log_unit,*) "rhos = ",rad_params%rhos(ib,ft) + write(log_unit,*) "taus = ",rad_params%taus(ib,ft) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do end do From 3d0e54df146ec1dd005ffcad2987ebc8ffc6e50c Mon Sep 17 00:00:00 2001 From: John Alex Date: Wed, 25 Oct 2023 09:51:11 -0600 Subject: [PATCH 156/250] Remove is_host_file from new fates_param_reader_type API. (because in practice, all callers use the FatesParametersInterface::RegisterParameter() default of false). Note this parameter is also called sync_with_host elsewhere. --- main/FatesInterfaceMod.F90 | 7 +------ main/FatesParametersInterface.F90 | 6 +++--- 2 files changed, 4 insertions(+), 9 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 4f569fc140..fc5a549cd5 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2169,7 +2169,6 @@ subroutine FatesReadParameters(param_reader) character(len=32) :: subname = 'FatesReadParameters' class(fates_parameters_type), allocatable :: fates_params - logical :: is_host_file if ( hlm_masterproc == itrue ) then write(fates_log(), *) 'FatesParametersInterface.F90::'//trim(subname)//' :: CLM reading ED/FATES '//' parameters ' @@ -2182,11 +2181,7 @@ subroutine FatesReadParameters(param_reader) call PRTRegisterParams(fates_params) ! PRT mod, only operates on fates_params class call FatesSynchronizedParamsInst%RegisterParams(fates_params) !Synchronized params class in Synchronized params mod, only operates on fates_params class - is_host_file = .false. - call param_reader%Read(is_host_file, fates_params) - - is_host_file = .true. - call param_reader%Read(is_host_file, fates_params) + call param_reader%Read(fates_params) call FatesReceiveParams(fates_params) call SpitFireReceiveParams(fates_params) diff --git a/main/FatesParametersInterface.F90 b/main/FatesParametersInterface.F90 index 3a220e1066..c559ec4cb4 100644 --- a/main/FatesParametersInterface.F90 +++ b/main/FatesParametersInterface.F90 @@ -93,17 +93,17 @@ module FatesParametersInterface end type fates_param_reader_type abstract interface - subroutine Read_interface(this, is_host_file, fates_params ) + subroutine Read_interface(this, fates_params ) ! ! !DESCRIPTION: - ! Read 'fates_params' parameters from appropriate filename given 'is_host_file'. + ! Read 'fates_params' parameters from (HLM-provided) storage. Note this ignores + ! the legacy parameter_type.sync_with_host setting. ! ! USES import :: fates_param_reader_type import :: fates_parameters_type ! !ARGUMENTS: class(fates_param_reader_type) :: this - logical, intent(in) :: is_host_file class(fates_parameters_type), intent(inout) :: fates_params !----------------------------------------------------------------------- From df2dee107fe428e20773ed21634ca3e227dd11fa Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 25 Oct 2023 15:35:06 -0400 Subject: [PATCH 157/250] fixed typo --- radiation/TwoStreamMLPEMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index a23e4acfff..45043cd65e 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -831,7 +831,7 @@ subroutine CanopyPrep(this,frac_snow) if(debug)then if(isnan(scelb%betad))then write(log_unit,*)"nans in canopy prep" - write(log_unit,*) ib,ican,icol,ft, + write(log_unit,*) ib,ican,icol,ft write(log_unit,*) scelb%betad,scelb%om,lai,sai write(log_unit,*) this%frac_snow,om_snow(ib),vai,om_veg write(log_unit,*)"TwoStreamMLPEMod.F90:CanopyPrep" From c3da9e62d6ef0706845598406c996f966284bfcd Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 26 Oct 2023 13:55:51 -0400 Subject: [PATCH 158/250] Updated messaging on the param check failure if the fates_rad_model is not 1 or 2 --- main/EDPftvarcon.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 8ea678811c..1353ad7464 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -1792,9 +1792,9 @@ subroutine FatesCheckParams(is_master) if(.not.is_master) return if(.not.any(radiation_model == [norman_solver,twostr_solver])) then - write(fates_log(),*) 'The only available canopy radiation model' - write(fates_log(),*) 'is the Norman scheme: fates_rad_model = 1' - write(fates_log(),*) 'The two-stream scheme is not available yet' + write(fates_log(),*) 'The only available canopy radiation models' + write(fates_log(),*) 'are the Norman and Two-stream schemes, ' + write(fates_log(),*) 'fates_rad_model = 1 or 2 ...' write(fates_log(),*) 'You specified fates_rad_model = ',radiation_model write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) From 789c36aa39fa2babd345dfafddc2f95d0d388f1f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 26 Oct 2023 13:59:51 -0400 Subject: [PATCH 159/250] Updated fail message on rad parameter bounds --- main/EDPftvarcon.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 1353ad7464..5745141c70 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -1920,7 +1920,7 @@ subroutine FatesCheckParams(is_master) ! xl must be between -0.4 and 0.6 according to Bonan (2019) doi:10.1017/9781107339217 pg. 238 !----------------------------------------------------------------------------------- if (EDPftvarcon_inst%xl(ipft) < -0.4 .or. EDPftvarcon_inst%xl(ipft) > 0.6) then - write(fates_log(),*) 'fates_rad_leaf_xl for pft ', ipft, ' is outside the allowed range of -0.6 to 0.4' + write(fates_log(),*) 'fates_rad_leaf_xl for pft ', ipft, ' is outside the allowed range of -0.4 to 0.6' write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if From 7f14138c1c9bb5073e9fcc2a70f8c52efd279d58 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 26 Oct 2023 15:55:46 -0400 Subject: [PATCH 160/250] Addressing reviewer comments --- biogeochem/EDCanopyStructureMod.F90 | 7 +++++-- main/FatesRestartInterfaceMod.F90 | 9 +++++---- radiation/FatesRadiationDriveMod.F90 | 10 ++++++---- radiation/FatesTwoStreamInterfaceMod.F90 | 4 +--- 4 files changed, 17 insertions(+), 13 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 74660dcd88..0944b6d366 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -25,6 +25,7 @@ module EDCanopyStructureMod use FatesCohortMod, only : fates_cohort_type use EDParamsMod , only : nclmax use EDParamsMod , only : nlevleaf + use EDParamsMod , only : radiation_model use EDtypesMod , only : AREA use EDLoggingMortalityMod , only : UpdateHarvestC use FatesGlobals , only : endrun => fates_endrun @@ -46,6 +47,7 @@ module EDCanopyStructureMod use PRTGenericMod, only : carbon12_element use FatesAllometryMod , only : VegAreaLayer use FatesTwoStreamInterfaceMod, only : FatesConstructRadElements + use FatesRadiationMemMod , only : twostr_solver ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -1436,9 +1438,10 @@ subroutine canopy_summarization( nsites, sites, bc_in ) end do !patch loop call leaf_area_profile(sites(s)) - - call FatesConstructRadElements(sites(s),bc_in(s)%fcansno_pa,bc_in(s)%coszen_pa) + if(radiation_model.eq.twostr_solver) then + call FatesConstructRadElements(sites(s),bc_in(s)%fcansno_pa,bc_in(s)%coszen_pa) + end if end do ! site loop diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 797f1d02e2..fbe1f58cd1 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -47,7 +47,7 @@ module FatesRestartInterfaceMod use PRTGenericMod, only : num_elements use FatesRunningMeanMod, only : rmean_type use FatesRunningMeanMod, only : ema_lpa - use FatesRadiationMemMod, only : num_swb,norman_solver + use FatesRadiationMemMod, only : num_swb,norman_solver,twostr_solver use TwoStreamMLPEMod, only : normalized_upper_boundary use EDParamsMod, only : regeneration_model use EDParamsMod, only : radiation_model @@ -3655,7 +3655,8 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) enddo else - if_solver: if(radiation_model.eq.norman_solver) then + select case(radiation_model) + case(norman_solver) call PatchNormanRadiation (currentPatch, & bc_out(s)%albd_parb(ifp,:), & @@ -3667,7 +3668,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftii_parb(ifp,:)) - else + case(twostr_solver) associate( twostr => currentPatch%twostr) call twostr%CanopyPrep(currentPatch%fcansno) @@ -3698,7 +3699,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) end associate - end if if_solver + end select endif ! is there vegetation? diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index 6c083e62b8..6a84e0fb17 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -167,7 +167,8 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) else - if_solver: if(radiation_model.eq.norman_solver) then + select case(radiation_model) + case(norman_solver) call PatchNormanRadiation (currentPatch, & bc_out(s)%albd_parb(ifp,:), & ! Surface Albedo direct @@ -178,9 +179,9 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) bc_out(s)%ftid_parb(ifp,:), & ! Down diffuse flux below canopy per unit direct at top bc_out(s)%ftii_parb(ifp,:)) ! Down diffuse flux below canopy per unit diffuse at top - else + case(twostr_solver) - associate( twostr => currentPatch%twostr) + associate( twostr => currentPatch%twostr) !call twostr%CanopyPrep(bc_in(s)%fcansno_pa(ifp)) !call twostr%ZenithPrep(bc_in(s)%coszen_pa(ifp)) @@ -225,7 +226,8 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) end do end associate - end if if_solver + end select + end if if_nrad endif if_zenith_flag diff --git a/radiation/FatesTwoStreamInterfaceMod.F90 b/radiation/FatesTwoStreamInterfaceMod.F90 index 3840715912..aca508782b 100644 --- a/radiation/FatesTwoStreamInterfaceMod.F90 +++ b/radiation/FatesTwoStreamInterfaceMod.F90 @@ -26,9 +26,7 @@ Module FatesTwoStreamInterfaceMod use TwoStreamMLPEMod , only : AllocateRadParams use TwoStreamMLPEMod , only : rel_err_thresh,area_err_thresh use EDPftvarcon , only : EDPftvarcon_inst - use FatesRadiationMemMod , only : twostr_solver use FatesAllometryMod , only : VegAreaLayer - use EDParamsMod , only : radiation_model implicit none @@ -89,7 +87,7 @@ subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) !type(fates_cohort_type), pointer :: elem_co_ptrs(ncl*max_el_per_layer,100) - if(radiation_model.ne.twostr_solver)return + max_elements = -1 ifp=0 From 1aa2ead8e72a3cb93976e066240b718005f33fb4 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 26 Oct 2023 16:00:51 -0400 Subject: [PATCH 161/250] removed unused alias in fateshistoryinterface --- main/FatesHistoryInterfaceMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index f92bcdb091..fbcbb53b51 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2479,7 +2479,6 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_nplant_si_scag => this%hvars(ih_nplant_si_scag)%r82d, & hio_nplant_canopy_si_scag => this%hvars(ih_nplant_canopy_si_scag)%r82d, & hio_nplant_understory_si_scag => this%hvars(ih_nplant_understory_si_scag)%r82d, & - hio_crownarea_si_can => this%hvars(ih_crownarea_si_can)%r82d, & hio_ddbh_canopy_si_scag => this%hvars(ih_ddbh_canopy_si_scag)%r82d, & hio_ddbh_understory_si_scag => this%hvars(ih_ddbh_understory_si_scag)%r82d, & hio_mortality_canopy_si_scag => this%hvars(ih_mortality_canopy_si_scag)%r82d, & From dbb2cfe28b560365bd837a9f4694bc51e803dd20 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 26 Oct 2023 16:05:59 -0400 Subject: [PATCH 162/250] fixes to lingering merge conflict resolutions --- biogeochem/EDCanopyStructureMod.F90 | 2 +- biogeophys/FatesPlantRespPhotosynthMod.F90 | 2 +- radiation/FatesTwoStreamInterfaceMod.F90 | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 0944b6d366..eca4b4a0ed 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1584,7 +1584,7 @@ subroutine leaf_area_profile( currentSite ) call VegAreaLayer(currentCohort%treelai, & currentCohort%treesai, & - currentCohort%hite, & + currentCohort%height, & iv,currentCohort%nv,currentCohort%pft, & currentSite%snow_depth, & vai_top,vai_bot, & diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index fddf9ca3d3..47b61e8e48 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -431,7 +431,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) do iv = 1,currentCohort%nv call VegAreaLayer(currentCohort%treelai, & currentCohort%treesai, & - currentCohort%hite, & + currentCohort%height, & iv, & currentCohort%nv, & currentCohort%pft, & diff --git a/radiation/FatesTwoStreamInterfaceMod.F90 b/radiation/FatesTwoStreamInterfaceMod.F90 index aca508782b..3a52978ed8 100644 --- a/radiation/FatesTwoStreamInterfaceMod.F90 +++ b/radiation/FatesTwoStreamInterfaceMod.F90 @@ -193,7 +193,7 @@ subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) ! it will return the total plant LAIs and SAIs call VegAreaLayer(cohort%treelai, & cohort%treesai, & - cohort%hite, & + cohort%height, & 0, & cohort%nv, & cohort%pft, & @@ -413,7 +413,7 @@ subroutine CheckPatchRadiationBalance(patch, snow_depth, ib, fabd, fabi) do iv = 1,cohort%nv call VegAreaLayer(cohort%treelai, & cohort%treesai, & - cohort%hite, & + cohort%height, & iv, & cohort%nv, & cohort%pft, & From 078003df72eef69db66cabcc5f492dd894f4be92 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 29 Oct 2023 10:28:15 -0600 Subject: [PATCH 163/250] Added yearly net uptake vector to restart, added a filter on trimming so it doesnt happen an extra time on the restart call (unlikely but possible) --- main/EDMainMod.F90 | 10 +++++----- main/FatesRestartInterfaceMod.F90 | 12 ++++++++++++ 2 files changed, 17 insertions(+), 5 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 6a360352ab..52176e199f 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -784,7 +784,8 @@ subroutine ed_update_site( currentSite, bc_in, bc_out, is_restart ) ! !LOCAL VARIABLES: type (fates_patch_type) , pointer :: currentPatch !----------------------------------------------------------------------- - if(hlm_use_sp.eq.ifalse)then + + if(hlm_use_sp.eq.ifalse .and. (.not.is_restart))then call canopy_spread(currentSite) end if @@ -831,10 +832,9 @@ subroutine ed_update_site( currentSite, bc_in, bc_out, is_restart ) ! FIX(RF,032414). This needs to be monthly, not annual ! If this is the second to last day of the year, then perform trimming - if( hlm_day_of_year == hlm_days_per_year-1) then - - if(hlm_use_sp.eq.ifalse)then - call trim_canopy(currentSite) + if( hlm_day_of_year == hlm_days_per_year-1 .and. (.not.is_restart)) then + if(hlm_use_sp.eq.ifalse)then + call trim_canopy(currentSite) endif endif diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 05fa063601..8c08c88c93 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -104,6 +104,8 @@ module FatesRestartInterfaceMod integer :: ir_canopy_trim_co integer :: ir_l2fr_co + integer :: ir_year_net_up_co + integer :: ir_cx_int_co integer :: ir_emadcxdt_co integer :: ir_cx0_co @@ -1011,6 +1013,12 @@ subroutine define_restart_vars(this, initialize_variables) hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_litter_moisture_pa_nfsc) end if + + call this%RegisterCohortVector(symbol_base='fates_year_net_up', vtype=cohort_r8, & + long_name_base='yearly net uptake at leaf layers', & + units='kg/m2/year', veclength=nlevleaf, flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_year_net_up_co ) + ! Site Level Diagnostics over multiple nutrients @@ -2271,6 +2279,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end do end do + call this%SetCohortRealVector(ccohort%year_net_uptake,nlevleaf,ir_year_net_up_co,io_idx_co) + rio_l2fr_co(io_idx_co) = ccohort%l2fr if(hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then @@ -3205,6 +3215,8 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%canopy_trim = rio_canopy_trim_co(io_idx_co) ccohort%l2fr = rio_l2fr_co(io_idx_co) + call this%GetCohortRealVector(ccohort%year_net_uptake,nlevleaf,ir_year_net_up_co,io_idx_co) + if(hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then ccohort%cx_int = this%rvars(ir_cx_int_co)%r81d(io_idx_co) ccohort%ema_dcxdt = this%rvars(ir_emadcxdt_co)%r81d(io_idx_co) From 701a47172f70ceca27d8015039218877283c42f0 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 31 Oct 2023 12:30:47 -0400 Subject: [PATCH 164/250] Removed some ed syntax conventions, enabled using height in the inventory data --- main/FatesInventoryInitMod.F90 | 51 +++++++++++++++++++++------------- 1 file changed, 31 insertions(+), 20 deletions(-) diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index fdef68cf11..92ed690786 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -11,9 +11,7 @@ module FatesInventoryInitMod ! site, or a small collection of sparse/irregularly spaced group of sites ! ! Created: Ryan Knox June 2017 - ! This code borrows heavily in concept from what is done in ED2. We will also do our best to - ! maintain compatibility with the PSS/CSS file formats that were used in ED2. - ! See: https://github.com/EDmodel/ED2/blob/master/ED/src/io/ed_read_ed10_20_history.f90 + ! This code borrows heavily in concept from what is done in ED2. ! At the time of writing this ED2 is unlicensed, and only concepts were borrowed with no direct ! code copied. ! @@ -295,7 +293,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) if( inv_format_list(invsite) == 1 ) then - call set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name) + call set_inventory_patch_type1(newpatch,pss_file_unit,ipa,ios,patch_name) end if ! Add it to the site's patch list @@ -384,7 +382,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) invcohortloop: do if ( inv_format_list(invsite) == 1 ) then - call set_inventory_edcohort_type1(sites(s),bc_in(s),css_file_unit, & + call set_inventory_cohort_type1(sites(s),bc_in(s),css_file_unit, & npatches, patch_pointer_vec,patch_name_vec, ios) end if if ( ios/=0 ) exit @@ -621,8 +619,8 @@ subroutine assess_inventory_sites(sitelist_file_unit,nsites, inv_format_list, & ! ! type integer We will accomodate different file format with different ! field values as the need arises. format 1 will read in - ! datasets via "set_inventory_edpatch_type1()", - ! "set_inventory_edcohort_type1()" + ! datasets via "set_inventory_patch_type1()", + ! "set_inventory_cohort_type1()" ! ! latitude float The geographic latitude coordinate of the site ! longitude float The geogarphic longitude coordinate of the site @@ -734,7 +732,7 @@ end subroutine assess_inventory_sites ! ============================================================================================== - subroutine set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name) + subroutine set_inventory_patch_type1(newpatch,pss_file_unit,ipa,ios,patch_name) ! -------------------------------------------------------------------------------------------- ! This subroutine reads in a line of an inventory patch file (pss) @@ -823,12 +821,12 @@ subroutine set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name end do return - end subroutine set_inventory_edpatch_type1 + end subroutine set_inventory_patch_type1 ! ============================================================================================== - subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & + subroutine set_inventory_cohort_type1(csite,bc_in,css_file_unit,npatches, & patch_pointer_vec,patch_name_vec,ios) ! -------------------------------------------------------------------------------------------- @@ -842,8 +840,8 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & ! FILE FORMAT: ! time (year) year of measurement ! patch (string) patch id string associated with this cohort - ! dbh (cm) diameter at breast height - ! height (m) height of vegetation in m. Currently not used. + ! dbh (cm) diameter at breast height. Optional, set height to negative if used + ! height (m) height of vegetation in m. Optional, set dbh to negative if used ! pft (integer) the plant functional type index (must be consistent with param file) ! n (/m2) The plant number density ! -------------------------------------------------------------------------------------------- @@ -912,6 +910,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & real(r8), parameter :: abnormal_large_nplant = 1000.0_r8 ! Used to catch bad values real(r8), parameter :: abnormal_large_dbh = 500.0_r8 ! I've never heard of a tree > 3m + real(r8), parameter :: abnormal_large_height = 500.0_r8 ! I've never heard of a tree > 500m tall integer, parameter :: recruitstatus = 0 @@ -958,9 +957,10 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if (c_dbh <=0 ) then + if (c_dbh < 0._r8 .and. c_height < 0._r8) then write(fates_log(), *) 'inventory dbh: ', c_dbh - write(fates_log(), *) 'The inventory produced a cohort with <= 0 dbh' + write(fates_log(), *) 'and inventory height: ',c_height + write(fates_log(), *) 'are both zero. One must be positive.' call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -970,6 +970,12 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if (c_height > abnormal_large_height ) then + write(fates_log(), *) 'inventory height: ', c_height + write(fates_log(), *) 'The inventory produced a cohort with very large height [m]' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (c_nplant <=0 ) then write(fates_log(), *) 'inventory nplant: ', c_nplant write(fates_log(), *) 'The inventory produced a cohort with <= 0 density /m2' @@ -1005,10 +1011,17 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & endif temp_cohort%n = c_nplant * cpatch%area / real(ncohorts_to_create,r8) - temp_cohort%dbh = c_dbh + temp_cohort%crowndamage = 1 ! assume undamaged - call h_allom(c_dbh,temp_cohort%pft,temp_cohort%height) + if( c_dbh> 0._r8)then + temp_cohort%dbh = c_dbh + call h_allom(c_dbh,temp_cohort%pft,temp_cohort%height) + else + temp_cohort%height = c_height + call h2d_allom(c_height,temp_cohort%pft,temp_cohort%dbh) + end if + temp_cohort%canopy_trim = 1.0_r8 ! Determine the phenology status and the elongation factors. @@ -1177,7 +1190,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & end do return - end subroutine set_inventory_edcohort_type1 + end subroutine set_inventory_cohort_type1 ! ==================================================================================== @@ -1185,9 +1198,7 @@ subroutine write_inventory_type1(currentSite) ! -------------------------------------------------------------------------------- ! This subroutine writes the cohort/patch inventory type files in the "type 1" - ! format. Note that for compatibility with ED2, we chose an old type that has - ! both extra unused fields and is missing fields from FATES. THis is not - ! a recommended file type for restarting a run. + ! format. ! The files will have a lat/long tag added to their name, and will be ! generated in the run folder. ! JFN Oct 2023 - updated to get rid of unused ED columns From 9c556ff03413be1241ca40e08187d751c6669321 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 31 Oct 2023 12:37:23 -0400 Subject: [PATCH 165/250] added check in inventory init to make sure at least on of dbh or height is positive --- main/FatesInventoryInitMod.F90 | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 92ed690786..962e05212f 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -957,13 +957,20 @@ subroutine set_inventory_cohort_type1(csite,bc_in,css_file_unit,npatches, & call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if (c_dbh < 0._r8 .and. c_height < 0._r8) then + if (c_dbh < nearzero .and. c_height < nearzero) then write(fates_log(), *) 'inventory dbh: ', c_dbh write(fates_log(), *) 'and inventory height: ',c_height - write(fates_log(), *) 'are both zero. One must be positive.' + write(fates_log(), *) 'are both zero or negative. One must be positive.' call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if (c_dbh > nearzero .and. c_height > nearzero) then + write(fates_log(), *) 'inventory dbh: ', c_dbh + write(fates_log(), *) 'and inventory height: ',c_height + write(fates_log(), *) 'are both positive. One must be zero or negative.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (c_dbh > abnormal_large_dbh ) then write(fates_log(), *) 'inventory dbh: ', c_nplant write(fates_log(), *) 'The inventory produced a cohort with very large diameter [cm]' From 6dfe90a595a0521bb9f08dabe2a834b6144b2a9b Mon Sep 17 00:00:00 2001 From: jessica needham Date: Wed, 1 Nov 2023 10:18:42 -0700 Subject: [PATCH 166/250] add nearzero to inventory initialization mod --- main/FatesInventoryInitMod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 962e05212f..fef10084f3 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -29,6 +29,7 @@ module FatesInventoryInitMod use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : pi_const use FatesConstantsMod, only : itrue + use FatesConstantsMod, only : nearzero use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : fates_log use EDParamsMod , only : regeneration_model From 3c7837755329238d98506ee59a6909e729362d56 Mon Sep 17 00:00:00 2001 From: John Alex Date: Wed, 1 Nov 2023 12:27:20 -0600 Subject: [PATCH 167/250] Remove the old code path altogether; CESM will be updated at the same time, and E3SM will not reference this new FATES version until it's also updated. --- main/FatesInterfaceMod.F90 | 13 ++----------- 1 file changed, 2 insertions(+), 11 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index fc5a549cd5..a158340ca5 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -70,8 +70,6 @@ module FatesInterfaceMod use SFParamsMod , only : SpitFireRegisterParams, SpitFireReceiveParams use PRTInitParamsFATESMod , only : PRTRegisterParams, PRTReceiveParams use FatesSynchronizedParamsMod, only : FatesSynchronizedParamsInst - ! TODO(jpalex): remove this direct reference to HLM code. - use CLMFatesParamInterfaceMod , only : HLM_FatesReadParameters => FatesReadParameters use EDParamsMod , only : p_uptake_mode use EDParamsMod , only : n_uptake_mode use EDTypesMod , only : ed_site_type @@ -750,21 +748,14 @@ subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft,param_reade logical, intent(in) :: use_fates ! Is fates turned on? integer, intent(in) :: surf_numpft ! Number of PFTs in surface dataset integer, intent(in) :: surf_numcft ! Number of CFTs in surface dataset - ! TODO(jpalex): make non-optional once all HLMs pass it in. - class(fates_param_reader_type), optional, intent(in) :: param_reader ! HLM-provided param file reader + class(fates_param_reader_type), intent(in) :: param_reader ! HLM-provided param file reader integer :: fates_numpft ! Number of PFTs tracked in FATES if (use_fates) then ! Self explanatory, read the fates parameter file - if (present(param_reader)) then - ! new, Fates-side. - call FatesReadParameters(param_reader) - else - ! old, HLM-side. - call HLM_FatesReadParameters() - end if + call FatesReadParameters(param_reader) fates_numpft = size(prt_params%wood_density,dim=1) From f3c9b54e698bb951ea1e4f87c9b3175b2db92714 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 1 Nov 2023 16:32:02 -0700 Subject: [PATCH 168/250] add timesince to correct "YEAR" calculation for landuse data tool --- tools/luh2/luh2.py | 6 ++++-- tools/luh2/luh2mod.py | 3 +++ 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/tools/luh2/luh2.py b/tools/luh2/luh2.py index d0cd91afec..c5f3983e3e 100644 --- a/tools/luh2/luh2.py +++ b/tools/luh2/luh2.py @@ -59,10 +59,12 @@ def main(): # Add additional required variables for the host land model # Add 'YEAR' as a variable. - # This is an old requirement of the HLM and should simply be a copy of the `time` dimension # If we are merging, we might not need to do this, so check to see if its there already + # This is a requirement of the HLM dyn_subgrid module and should be the actual year. + # Note that the time variable from the LUH2 data is 'years since ...' so we need to + # add the input data year if (not "YEAR" in list(regrid_luh2.variables)): - regrid_luh2["YEAR"] = regrid_luh2.time + regrid_luh2["YEAR"] = regrid_luh2.time + regrid_luh2.timesince regrid_luh2["LONGXY"] = ds_regrid_target["LONGXY"] # TO DO: double check if this is strictly necessary regrid_luh2["LATIXY"] = ds_regrid_target["LATIXY"] # TO DO: double check if this is strictly necessary diff --git a/tools/luh2/luh2mod.py b/tools/luh2/luh2mod.py index c8534d42a9..d0f21b9060 100644 --- a/tools/luh2/luh2mod.py +++ b/tools/luh2/luh2mod.py @@ -66,6 +66,9 @@ def PrepDataset(input_dataset,start=None,stop=None,merge_flag=False): # the start/stop is out of range input_dataset = input_dataset.sel(time=slice(years_since_start,years_since_stop)) + # Save the timesince as a variable for future use + input_dataset["timesince"] = time_since + # Correct the necessary variables for both datasets # We don't need to Prep the incoming dataset if it's being opened to merge if(not merge_flag): From e7e9367176c192b5f341f7be4860431eda4faaf4 Mon Sep 17 00:00:00 2001 From: jessica needham Date: Wed, 1 Nov 2023 20:58:41 -0700 Subject: [PATCH 169/250] fix LL logic to allow case where all patches and cohorts are identical --- main/FatesInventoryInitMod.F90 | 56 ++++++++++++++++++++++++++++++++-- 1 file changed, 54 insertions(+), 2 deletions(-) diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index fef10084f3..544cb3fc7f 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -168,6 +168,11 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) character(len=patchname_strlen), allocatable :: patch_name_vec(:) ! vector of patch ID strings real(r8) :: basal_area_postf ! basal area before fusion (m2/ha) real(r8) :: basal_area_pref ! basal area after fusion (m2/ha) + real(r8) :: min_patch_age + real(r8) :: max_patch_age + real(r8) :: min_cohort_dbh + real(r8) :: max_cohort_dbh + ! I. Load the inventory list file, do some file handle checks ! ------------------------------------------------------------------------------------------ @@ -367,6 +372,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) enddo end if + ! OPEN THE CSS FILE ! --------------------------------------------------------------------------------------- css_file_unit = shr_file_getUnit() @@ -399,8 +405,53 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) deallocate(patch_pointer_vec,patch_name_vec) - ! now that we've read in the patch and cohort info, check to see if there is any real age info - if ( abs(sites(s)%youngest_patch%age - sites(s)%oldest_patch%age) <= nearzero .and. & + + ! if all patches are identical in age and biomass then don't change the order of the LL + min_patch_age = 0._r8 + max_patch_age = 0._r8 + min_cohort_dbh = 100000._r8 + max_cohort_dbh = 0._r8 + + ! get min and max patch age and cohort dbh + currentpatch => sites(s)%youngest_patch + do while(associated(currentpatch)) + + if ( currentpatch%age > max_patch_age ) then + max_patch_age = currentpatch%age + else if ( currentpatch%age < min_patch_age ) then + min_patch_age = currentpatch%age + end if + + currentcohort => currentpatch%tallest + do while(associated(currentcohort)) + + if ( currentcohort%dbh > max_cohort_dbh ) then + max_cohort_dbh = currentcohort%dbh + else if ( currentcohort%dbh < min_cohort_dbh ) then + min_cohort_dbh = currentcohort%dbh + end if + + currentcohort => currentcohort%shorter + end do + currentPatch => currentpatch%older + enddo + + if (debug_inv) then + write(fates_log(),*) 'min patch age', min_patch_age + write(fates_log(),*) 'max patch age', max_patch_age + write(fates_log(),*) 'min cohort dbh', min_cohort_dbh + write(fates_log(),*) 'max cohort dbh', max_cohort_dbh + end if + + if ( min_patch_age .eq. max_patch_age .and. min_cohort_dbh .eq. max_cohort_dbh ) then + + if(debug_inv)then + write(fates_log(), *) 'All patches and cohorts are identical' + end if + + + ! now that we've read in the patch and cohort info, check to see if there is any real age info + else if ( abs(sites(s)%youngest_patch%age - sites(s)%oldest_patch%age) <= nearzero .and. & associated(sites(s)%youngest_patch%older) ) then ! so there are at least two patches and the oldest and youngest are the same age. @@ -501,6 +552,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! ---------------------------------------------------------------------------------------- ipa=1 total_cohorts = 0 + currentpatch => sites(s)%youngest_patch do while(associated(currentpatch)) currentpatch%patchno = ipa From 8e2e9f74e83ef2bc9082a5a4e67fee9936b98f4d Mon Sep 17 00:00:00 2001 From: jessica needham Date: Thu, 2 Nov 2023 14:42:58 -0700 Subject: [PATCH 170/250] remove sorting of ll after init data read --- main/FatesInventoryInitMod.F90 | 254 +++++++++++++++++---------------- 1 file changed, 132 insertions(+), 122 deletions(-) diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 544cb3fc7f..f713102998 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -168,10 +168,12 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) character(len=patchname_strlen), allocatable :: patch_name_vec(:) ! vector of patch ID strings real(r8) :: basal_area_postf ! basal area before fusion (m2/ha) real(r8) :: basal_area_pref ! basal area after fusion (m2/ha) - real(r8) :: min_patch_age - real(r8) :: max_patch_age - real(r8) :: min_cohort_dbh - real(r8) :: max_cohort_dbh + real(r8) :: n_pref + real(r8) :: n_postf + ! real(r8) :: min_patch_age +! real(r8) :: max_patch_age +! real(r8) :: min_cohort_dbh +! real(r8) :: max_cohort_dbh ! I. Load the inventory list file, do some file handle checks @@ -406,137 +408,139 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) deallocate(patch_pointer_vec,patch_name_vec) - ! if all patches are identical in age and biomass then don't change the order of the LL - min_patch_age = 0._r8 - max_patch_age = 0._r8 - min_cohort_dbh = 100000._r8 - max_cohort_dbh = 0._r8 - - ! get min and max patch age and cohort dbh - currentpatch => sites(s)%youngest_patch - do while(associated(currentpatch)) - - if ( currentpatch%age > max_patch_age ) then - max_patch_age = currentpatch%age - else if ( currentpatch%age < min_patch_age ) then - min_patch_age = currentpatch%age - end if - - currentcohort => currentpatch%tallest - do while(associated(currentcohort)) - - if ( currentcohort%dbh > max_cohort_dbh ) then - max_cohort_dbh = currentcohort%dbh - else if ( currentcohort%dbh < min_cohort_dbh ) then - min_cohort_dbh = currentcohort%dbh - end if - - currentcohort => currentcohort%shorter - end do - currentPatch => currentpatch%older - enddo - - if (debug_inv) then - write(fates_log(),*) 'min patch age', min_patch_age - write(fates_log(),*) 'max patch age', max_patch_age - write(fates_log(),*) 'min cohort dbh', min_cohort_dbh - write(fates_log(),*) 'max cohort dbh', max_cohort_dbh - end if + ! ! if all patches are identical in age and biomass then don't change the order of the LL + ! min_patch_age = 0._r8 + ! max_patch_age = 0._r8 + ! min_cohort_dbh = 100000._r8 + ! max_cohort_dbh = 0._r8 + + ! ! get min and max patch age and cohort dbh + ! currentpatch => sites(s)%youngest_patch + ! do while(associated(currentpatch)) + + ! if ( currentpatch%age > max_patch_age ) then + ! max_patch_age = currentpatch%age + ! else if ( currentpatch%age < min_patch_age ) then + ! min_patch_age = currentpatch%age + ! end if + + ! currentcohort => currentpatch%tallest + ! do while(associated(currentcohort)) + + ! if ( currentcohort%dbh > max_cohort_dbh ) then + ! max_cohort_dbh = currentcohort%dbh + ! else if ( currentcohort%dbh < min_cohort_dbh ) then + ! min_cohort_dbh = currentcohort%dbh + ! end if + + ! currentcohort => currentcohort%shorter + ! end do + ! currentPatch => currentpatch%older + ! enddo + + ! if (debug_inv) then + ! write(fates_log(),*) 'min patch age', min_patch_age + ! write(fates_log(),*) 'max patch age', max_patch_age + ! write(fates_log(),*) 'min cohort dbh', min_cohort_dbh + ! write(fates_log(),*) 'max cohort dbh', max_cohort_dbh + ! end if - if ( min_patch_age .eq. max_patch_age .and. min_cohort_dbh .eq. max_cohort_dbh ) then + ! if ( min_patch_age .eq. max_patch_age .and. min_cohort_dbh .eq. max_cohort_dbh ) then - if(debug_inv)then - write(fates_log(), *) 'All patches and cohorts are identical' - end if + ! if(debug_inv)then + ! write(fates_log(), *) 'All patches and cohorts are identical' + ! end if - ! now that we've read in the patch and cohort info, check to see if there is any real age info - else if ( abs(sites(s)%youngest_patch%age - sites(s)%oldest_patch%age) <= nearzero .and. & - associated(sites(s)%youngest_patch%older) ) then - - ! so there are at least two patches and the oldest and youngest are the same age. - ! this means that sorting by age wasn't very useful. try sorting by total biomass instead - - ! first calculate the biomass in each patch. simplest way is to use the patch fusion criteria - currentpatch => sites(s)%youngest_patch - do while(associated(currentpatch)) - call patch_pft_size_profile(currentPatch) - currentPatch => currentpatch%older - enddo - - ! now we need to sort them. - ! first generate a new head of the linked list. - head_of_unsorted_patch_list => sites(s)%youngest_patch%older - - ! reset the site-level patch linked list, keeping only the youngest patch. - sites(s)%youngest_patch%older => null() - sites(s)%youngest_patch%younger => null() - sites(s)%oldest_patch => sites(s)%youngest_patch - - ! loop through each patch in the unsorted LL, peel it off, - ! and insert it into the new, sorted LL - do while(associated(head_of_unsorted_patch_list)) - - ! first keep track of the next patch in the old (unsorted) linked list - next_in_unsorted_patch_list => head_of_unsorted_patch_list%older - - ! check the two end-cases - - ! Youngest Patch - if(sum(head_of_unsorted_patch_list%pft_agb_profile(:,:)) <= & - sum(sites(s)%youngest_patch%pft_agb_profile(:,:)))then - head_of_unsorted_patch_list%older => sites(s)%youngest_patch - head_of_unsorted_patch_list%younger => null() - sites(s)%youngest_patch%younger => head_of_unsorted_patch_list - sites(s)%youngest_patch => head_of_unsorted_patch_list - - ! Oldest Patch - else if(sum(head_of_unsorted_patch_list%pft_agb_profile(:,:)) > & - sum(sites(s)%oldest_patch%pft_agb_profile(:,:)))then - head_of_unsorted_patch_list%older => null() - head_of_unsorted_patch_list%younger => sites(s)%oldest_patch - sites(s)%oldest_patch%older => head_of_unsorted_patch_list - sites(s)%oldest_patch => head_of_unsorted_patch_list - - ! Somewhere in the middle - else - currentpatch => sites(s)%youngest_patch - do while(associated(currentpatch)) - olderpatch => currentpatch%older - if(associated(currentpatch%older)) then - if(sum(head_of_unsorted_patch_list%pft_agb_profile(:,:)) >= & - sum(currentpatch%pft_agb_profile(:,:)) .and. & - sum(head_of_unsorted_patch_list%pft_agb_profile(:,:)) < & - sum(olderpatch%pft_agb_profile(:,:))) then - ! Set the new patches pointers - head_of_unsorted_patch_list%older => currentpatch%older - head_of_unsorted_patch_list%younger => currentpatch - ! Fix the patch's older pointer - currentpatch%older => head_of_unsorted_patch_list - ! Fix the older patch's younger pointer - olderpatch%younger => head_of_unsorted_patch_list - ! Exit the loop once head sorted to avoid later re-sort - exit - end if - end if - currentPatch => olderpatch - enddo - end if - - ! now work through to the next element in the unsorted linked list - head_of_unsorted_patch_list => next_in_unsorted_patch_list - end do - endif + ! ! now that we've read in the patch and cohort info, check to see if there is any real age info + ! else if ( abs(sites(s)%youngest_patch%age - sites(s)%oldest_patch%age) <= nearzero .and. & + ! associated(sites(s)%youngest_patch%older) ) then + + ! ! so there are at least two patches and the oldest and youngest are the same age. + ! ! this means that sorting by age wasn't very useful. try sorting by total biomass instead + + ! ! first calculate the biomass in each patch. simplest way is to use the patch fusion criteria + ! currentpatch => sites(s)%youngest_patch + ! do while(associated(currentpatch)) + ! call patch_pft_size_profile(currentPatch) + ! currentPatch => currentpatch%older + ! enddo + + ! ! now we need to sort them. + ! ! first generate a new head of the linked list. + ! head_of_unsorted_patch_list => sites(s)%youngest_patch%older + + ! ! reset the site-level patch linked list, keeping only the youngest patch. + ! sites(s)%youngest_patch%older => null() + ! sites(s)%youngest_patch%younger => null() + ! sites(s)%oldest_patch => sites(s)%youngest_patch + + ! ! loop through each patch in the unsorted LL, peel it off, + ! ! and insert it into the new, sorted LL + ! do while(associated(head_of_unsorted_patch_list)) + + ! ! first keep track of the next patch in the old (unsorted) linked list + ! next_in_unsorted_patch_list => head_of_unsorted_patch_list%older + + ! ! check the two end-cases + + ! ! Youngest Patch + ! if(sum(head_of_unsorted_patch_list%pft_agb_profile(:,:)) <= & + ! sum(sites(s)%youngest_patch%pft_agb_profile(:,:)))then + ! head_of_unsorted_patch_list%older => sites(s)%youngest_patch + ! head_of_unsorted_patch_list%younger => null() + ! sites(s)%youngest_patch%younger => head_of_unsorted_patch_list + ! sites(s)%youngest_patch => head_of_unsorted_patch_list + + ! ! Oldest Patch + ! else if(sum(head_of_unsorted_patch_list%pft_agb_profile(:,:)) > & + ! sum(sites(s)%oldest_patch%pft_agb_profile(:,:)))then + ! head_of_unsorted_patch_list%older => null() + ! head_of_unsorted_patch_list%younger => sites(s)%oldest_patch + ! sites(s)%oldest_patch%older => head_of_unsorted_patch_list + ! sites(s)%oldest_patch => head_of_unsorted_patch_list + + ! ! Somewhere in the middle + ! else + ! currentpatch => sites(s)%youngest_patch + ! do while(associated(currentpatch)) + ! olderpatch => currentpatch%older + ! if(associated(currentpatch%older)) then + ! if(sum(head_of_unsorted_patch_list%pft_agb_profile(:,:)) >= & + ! sum(currentpatch%pft_agb_profile(:,:)) .and. & + ! sum(head_of_unsorted_patch_list%pft_agb_profile(:,:)) < & + ! sum(olderpatch%pft_agb_profile(:,:))) then + ! ! Set the new patches pointers + ! head_of_unsorted_patch_list%older => currentpatch%older + ! head_of_unsorted_patch_list%younger => currentpatch + ! ! Fix the patch's older pointer + ! currentpatch%older => head_of_unsorted_patch_list + ! ! Fix the older patch's younger pointer + ! olderpatch%younger => head_of_unsorted_patch_list + ! ! Exit the loop once head sorted to avoid later re-sort + ! exit + ! end if + ! end if + ! currentPatch => olderpatch + ! enddo + ! end if + + ! ! now work through to the next element in the unsorted linked list + ! head_of_unsorted_patch_list => next_in_unsorted_patch_list + ! end do + ! endif ! Report Basal Area (as a check on if things were read in) ! ------------------------------------------------------------------------------ basal_area_pref = 0.0_r8 + n_pref = 0.0_r8 currentpatch => sites(s)%youngest_patch do while(associated(currentpatch)) currentcohort => currentpatch%tallest do while(associated(currentcohort)) basal_area_pref = basal_area_pref + & - currentcohort%n*0.25*((currentcohort%dbh/100.0_r8)**2.0_r8)*pi_const + currentcohort%n*0.25*((currentcohort%dbh/100.0_r8)**2.0_r8)*pi_const + n_pref = n_pref + currentcohort%n currentcohort => currentcohort%shorter end do currentPatch => currentpatch%older @@ -546,6 +550,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) write(fates_log(),*) 'Basal Area from inventory, BEFORE fusion' write(fates_log(),*) 'Lat: ',sites(s)%lat,' Lon: ',sites(s)%lon write(fates_log(),*) basal_area_pref,' [m2/ha]' + write(fates_log(),*) 'number of plants: ', n_pref write(fates_log(),*) '-------------------------------------------------------' ! Update the patch index numbers and fuse the cohorts in the patches @@ -583,12 +588,14 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! ---------------------------------------------------------------------------------------- !call canopy_structure(sites(s),bc_in(s)) basal_area_postf = 0.0_r8 + n_postf = 0.0_r8 currentpatch => sites(s)%youngest_patch do while(associated(currentpatch)) currentcohort => currentpatch%tallest do while(associated(currentcohort)) basal_area_postf = basal_area_postf + & currentcohort%n*0.25*((currentcohort%dbh/100.0_r8)**2.0_r8)*pi_const + n_postf = n_postf + currentcohort%n currentcohort => currentcohort%shorter end do @@ -601,6 +608,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) write(fates_log(),*) 'Basal Area from inventory, AFTER fusion' write(fates_log(),*) 'Lat: ',sites(s)%lat,' Lon: ',sites(s)%lon write(fates_log(),*) basal_area_postf,' [m2/ha]' + write(fates_log(),*) 'jfn n post f :', n_postf write(fates_log(),*) '-------------------------------------------------------' ! If this is flagged as true, the post-fusion inventory will be written to file @@ -1077,9 +1085,11 @@ subroutine set_inventory_cohort_type1(csite,bc_in,css_file_unit,npatches, & if( c_dbh> 0._r8)then temp_cohort%dbh = c_dbh call h_allom(c_dbh,temp_cohort%pft,temp_cohort%height) + write(fates_log(),*) 'jfn - using dbh' else temp_cohort%height = c_height call h2d_allom(c_height,temp_cohort%pft,temp_cohort%dbh) + write(fates_log(),*) 'jfn - using height' end if temp_cohort%canopy_trim = 1.0_r8 From 35a6abd748c91f56f949d4852713e8fcfab36662 Mon Sep 17 00:00:00 2001 From: jessica needham Date: Thu, 2 Nov 2023 16:02:13 -0700 Subject: [PATCH 171/250] Clean writing of inventory files. Remove unused code. --- main/FatesInventoryInitMod.F90 | 142 ++------------------------------- 1 file changed, 5 insertions(+), 137 deletions(-) diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index f713102998..c462c45112 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -170,11 +170,6 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) real(r8) :: basal_area_pref ! basal area after fusion (m2/ha) real(r8) :: n_pref real(r8) :: n_postf - ! real(r8) :: min_patch_age -! real(r8) :: max_patch_age -! real(r8) :: min_cohort_dbh -! real(r8) :: max_cohort_dbh - ! I. Load the inventory list file, do some file handle checks ! ------------------------------------------------------------------------------------------ @@ -407,129 +402,6 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) deallocate(patch_pointer_vec,patch_name_vec) - - ! ! if all patches are identical in age and biomass then don't change the order of the LL - ! min_patch_age = 0._r8 - ! max_patch_age = 0._r8 - ! min_cohort_dbh = 100000._r8 - ! max_cohort_dbh = 0._r8 - - ! ! get min and max patch age and cohort dbh - ! currentpatch => sites(s)%youngest_patch - ! do while(associated(currentpatch)) - - ! if ( currentpatch%age > max_patch_age ) then - ! max_patch_age = currentpatch%age - ! else if ( currentpatch%age < min_patch_age ) then - ! min_patch_age = currentpatch%age - ! end if - - ! currentcohort => currentpatch%tallest - ! do while(associated(currentcohort)) - - ! if ( currentcohort%dbh > max_cohort_dbh ) then - ! max_cohort_dbh = currentcohort%dbh - ! else if ( currentcohort%dbh < min_cohort_dbh ) then - ! min_cohort_dbh = currentcohort%dbh - ! end if - - ! currentcohort => currentcohort%shorter - ! end do - ! currentPatch => currentpatch%older - ! enddo - - ! if (debug_inv) then - ! write(fates_log(),*) 'min patch age', min_patch_age - ! write(fates_log(),*) 'max patch age', max_patch_age - ! write(fates_log(),*) 'min cohort dbh', min_cohort_dbh - ! write(fates_log(),*) 'max cohort dbh', max_cohort_dbh - ! end if - - ! if ( min_patch_age .eq. max_patch_age .and. min_cohort_dbh .eq. max_cohort_dbh ) then - - ! if(debug_inv)then - ! write(fates_log(), *) 'All patches and cohorts are identical' - ! end if - - - ! ! now that we've read in the patch and cohort info, check to see if there is any real age info - ! else if ( abs(sites(s)%youngest_patch%age - sites(s)%oldest_patch%age) <= nearzero .and. & - ! associated(sites(s)%youngest_patch%older) ) then - - ! ! so there are at least two patches and the oldest and youngest are the same age. - ! ! this means that sorting by age wasn't very useful. try sorting by total biomass instead - - ! ! first calculate the biomass in each patch. simplest way is to use the patch fusion criteria - ! currentpatch => sites(s)%youngest_patch - ! do while(associated(currentpatch)) - ! call patch_pft_size_profile(currentPatch) - ! currentPatch => currentpatch%older - ! enddo - - ! ! now we need to sort them. - ! ! first generate a new head of the linked list. - ! head_of_unsorted_patch_list => sites(s)%youngest_patch%older - - ! ! reset the site-level patch linked list, keeping only the youngest patch. - ! sites(s)%youngest_patch%older => null() - ! sites(s)%youngest_patch%younger => null() - ! sites(s)%oldest_patch => sites(s)%youngest_patch - - ! ! loop through each patch in the unsorted LL, peel it off, - ! ! and insert it into the new, sorted LL - ! do while(associated(head_of_unsorted_patch_list)) - - ! ! first keep track of the next patch in the old (unsorted) linked list - ! next_in_unsorted_patch_list => head_of_unsorted_patch_list%older - - ! ! check the two end-cases - - ! ! Youngest Patch - ! if(sum(head_of_unsorted_patch_list%pft_agb_profile(:,:)) <= & - ! sum(sites(s)%youngest_patch%pft_agb_profile(:,:)))then - ! head_of_unsorted_patch_list%older => sites(s)%youngest_patch - ! head_of_unsorted_patch_list%younger => null() - ! sites(s)%youngest_patch%younger => head_of_unsorted_patch_list - ! sites(s)%youngest_patch => head_of_unsorted_patch_list - - ! ! Oldest Patch - ! else if(sum(head_of_unsorted_patch_list%pft_agb_profile(:,:)) > & - ! sum(sites(s)%oldest_patch%pft_agb_profile(:,:)))then - ! head_of_unsorted_patch_list%older => null() - ! head_of_unsorted_patch_list%younger => sites(s)%oldest_patch - ! sites(s)%oldest_patch%older => head_of_unsorted_patch_list - ! sites(s)%oldest_patch => head_of_unsorted_patch_list - - ! ! Somewhere in the middle - ! else - ! currentpatch => sites(s)%youngest_patch - ! do while(associated(currentpatch)) - ! olderpatch => currentpatch%older - ! if(associated(currentpatch%older)) then - ! if(sum(head_of_unsorted_patch_list%pft_agb_profile(:,:)) >= & - ! sum(currentpatch%pft_agb_profile(:,:)) .and. & - ! sum(head_of_unsorted_patch_list%pft_agb_profile(:,:)) < & - ! sum(olderpatch%pft_agb_profile(:,:))) then - ! ! Set the new patches pointers - ! head_of_unsorted_patch_list%older => currentpatch%older - ! head_of_unsorted_patch_list%younger => currentpatch - ! ! Fix the patch's older pointer - ! currentpatch%older => head_of_unsorted_patch_list - ! ! Fix the older patch's younger pointer - ! olderpatch%younger => head_of_unsorted_patch_list - ! ! Exit the loop once head sorted to avoid later re-sort - ! exit - ! end if - ! end if - ! currentPatch => olderpatch - ! enddo - ! end if - - ! ! now work through to the next element in the unsorted linked list - ! head_of_unsorted_patch_list => next_in_unsorted_patch_list - ! end do - ! endif - ! Report Basal Area (as a check on if things were read in) ! ------------------------------------------------------------------------------ basal_area_pref = 0.0_r8 @@ -1085,11 +957,9 @@ subroutine set_inventory_cohort_type1(csite,bc_in,css_file_unit,npatches, & if( c_dbh> 0._r8)then temp_cohort%dbh = c_dbh call h_allom(c_dbh,temp_cohort%pft,temp_cohort%height) - write(fates_log(),*) 'jfn - using dbh' else temp_cohort%height = c_height call h2d_allom(c_height,temp_cohort%pft,temp_cohort%dbh) - write(fates_log(),*) 'jfn - using height' end if temp_cohort%canopy_trim = 1.0_r8 @@ -1313,9 +1183,9 @@ subroutine write_inventory_type1(currentSite) ilon_sign = 'W' end if - write(pss_name_out,'(A8,I2.2,A1,I5.5,A1,A1,I3.3,A1,I5.5,A1,A4)') & + write(pss_name_out,'(A8, I2.2, A1, I5.5, A1)') & 'pss_out_',ilat_int,'.',ilat_dec,ilat_sign,'_',ilon_int,'.',ilon_dec,ilon_sign,'.txt' - write(css_name_out,'(A8,I2.2,A1,I5.5,A1,A1,I3.3,A1,I5.5,A1,A4)') & + write(css_name_out,'(A8, I2.2, A1, A1, I3.3, A1)') & 'css_out_',ilat_int,'.',ilat_dec,ilat_sign,'_',ilon_int,'.',ilon_dec,ilon_sign,'.txt' pss_file_out = shr_file_getUnit() @@ -1334,16 +1204,14 @@ subroutine write_inventory_type1(currentSite) write(patch_str,'(A7,i4.4,A)') '' - write(pss_file_out,*) '0000 ',trim(patch_str),' 2 ',currentPatch%age,currentPatch%area/AREA, & - '0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000' + write(pss_file_out,*) '0000 ',trim(patch_str),' 2 ',currentPatch%age,currentPatch%area/AREA icohort=0 currentcohort => currentpatch%tallest do while(associated(currentcohort)) icohort=icohort+1 - write(cohort_str,'(A7,i4.4,A)') '' - write(css_file_out,*) '0000 ',trim(patch_str),' ',trim(cohort_str), & - currentCohort%dbh,0.0,currentCohort%pft,currentCohort%n/currentPatch%area,0.0,0.0,0.0 + write(css_file_out,*) '0000 ',trim(patch_str), & + currentCohort%dbh,currentCohort%height,currentCohort%pft,currentCohort%n/currentPatch%area currentcohort => currentcohort%shorter end do From 00c0ab81d1cbc06e0f94987dccda1971090f8084 Mon Sep 17 00:00:00 2001 From: jessica needham Date: Thu, 2 Nov 2023 16:14:25 -0700 Subject: [PATCH 172/250] remove another cohort name from write css --- main/FatesInventoryInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index c462c45112..b3d305d48d 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -1195,7 +1195,7 @@ subroutine write_inventory_type1(currentSite) open(unit=css_file_out,file=trim(css_name_out), status='UNKNOWN',action='WRITE',form='FORMATTED') write(pss_file_out,*) 'time patch trk age area' - write(css_file_out,*) 'time patch cohort dbh height pft nplant' + write(css_file_out,*) 'time patch dbh height pft nplant' ipatch=0 currentpatch => currentSite%youngest_patch From 44f9a4aa1e8eec5e75ba8f831c4fbea827e7a450 Mon Sep 17 00:00:00 2001 From: jessica needham Date: Thu, 2 Nov 2023 17:11:05 -0700 Subject: [PATCH 173/250] remove debugging checks --- main/FatesInventoryInitMod.F90 | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index b3d305d48d..304c40cfb0 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -168,9 +168,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) character(len=patchname_strlen), allocatable :: patch_name_vec(:) ! vector of patch ID strings real(r8) :: basal_area_postf ! basal area before fusion (m2/ha) real(r8) :: basal_area_pref ! basal area after fusion (m2/ha) - real(r8) :: n_pref - real(r8) :: n_postf - + ! I. Load the inventory list file, do some file handle checks ! ------------------------------------------------------------------------------------------ @@ -405,14 +403,12 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! Report Basal Area (as a check on if things were read in) ! ------------------------------------------------------------------------------ basal_area_pref = 0.0_r8 - n_pref = 0.0_r8 currentpatch => sites(s)%youngest_patch do while(associated(currentpatch)) currentcohort => currentpatch%tallest do while(associated(currentcohort)) basal_area_pref = basal_area_pref + & currentcohort%n*0.25*((currentcohort%dbh/100.0_r8)**2.0_r8)*pi_const - n_pref = n_pref + currentcohort%n currentcohort => currentcohort%shorter end do currentPatch => currentpatch%older @@ -422,7 +418,6 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) write(fates_log(),*) 'Basal Area from inventory, BEFORE fusion' write(fates_log(),*) 'Lat: ',sites(s)%lat,' Lon: ',sites(s)%lon write(fates_log(),*) basal_area_pref,' [m2/ha]' - write(fates_log(),*) 'number of plants: ', n_pref write(fates_log(),*) '-------------------------------------------------------' ! Update the patch index numbers and fuse the cohorts in the patches @@ -460,14 +455,12 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! ---------------------------------------------------------------------------------------- !call canopy_structure(sites(s),bc_in(s)) basal_area_postf = 0.0_r8 - n_postf = 0.0_r8 currentpatch => sites(s)%youngest_patch do while(associated(currentpatch)) currentcohort => currentpatch%tallest do while(associated(currentcohort)) basal_area_postf = basal_area_postf + & currentcohort%n*0.25*((currentcohort%dbh/100.0_r8)**2.0_r8)*pi_const - n_postf = n_postf + currentcohort%n currentcohort => currentcohort%shorter end do @@ -480,7 +473,6 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) write(fates_log(),*) 'Basal Area from inventory, AFTER fusion' write(fates_log(),*) 'Lat: ',sites(s)%lat,' Lon: ',sites(s)%lon write(fates_log(),*) basal_area_postf,' [m2/ha]' - write(fates_log(),*) 'jfn n post f :', n_postf write(fates_log(),*) '-------------------------------------------------------' ! If this is flagged as true, the post-fusion inventory will be written to file From 90f50ba399e8a7998874b74f0cae81b8dd13c2aa Mon Sep 17 00:00:00 2001 From: jessica needham Date: Fri, 3 Nov 2023 14:16:00 -0700 Subject: [PATCH 174/250] turn off hmort when soil is frozen --- biogeochem/EDMortalityFunctionsMod.F90 | 14 +++++++++----- main/EDParamsMod.F90 | 4 +++- 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/biogeochem/EDMortalityFunctionsMod.F90 b/biogeochem/EDMortalityFunctionsMod.F90 index bf47a5cce3..029ca907dc 100644 --- a/biogeochem/EDMortalityFunctionsMod.F90 +++ b/biogeochem/EDMortalityFunctionsMod.F90 @@ -48,7 +48,7 @@ module EDMortalityFunctionsMod contains - subroutine mortality_rates( cohort_in,bc_in,btran_ft, mean_temp, & + subroutine mortality_rates( cohort_in,bc_in, btran_ft, mean_temp, & cmort,hmort,bmort, frmort,smort,asmort,dgmort ) ! ============================================================================ @@ -56,9 +56,10 @@ subroutine mortality_rates( cohort_in,bc_in,btran_ft, mean_temp, & ! background and freezing and size and age dependent senescence ! ============================================================================ - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - use FatesConstantsMod, only : fates_check_param_set - use DamageMainMod, only : GetDamageMortality + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + use FatesConstantsMod, only : fates_check_param_set + use DamageMainMod, only : GetDamageMortality + use EDParamsmod, only : tsoil_thresh_hmort type (fates_cohort_type), intent(in) :: cohort_in type (bc_in_type), intent(in) :: bc_in @@ -156,9 +157,12 @@ subroutine mortality_rates( cohort_in,bc_in,btran_ft, mean_temp, & hmort = 0.0_r8 endif else - if(btran_ft(cohort_in%pft) <= hf_sm_threshold)then + if(btran_ft(cohort_in%pft) <= hf_sm_threshold .and. & + minval(bc_in%t_soisno_sl) - tfrz .ge. tsoil_thresh_hmort )then hmort = EDPftvarcon_inst%mort_scalar_hydrfailure(cohort_in%pft) else + write(fates_log(),*) 'jfn soil frozen - no hmort' + write(fates_log(),*) 'jfn min soil temp - ', minval(bc_in%t_soisno_sl) - tfrz hmort = 0.0_r8 endif endif diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 438d387213..489e0f209a 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -95,8 +95,10 @@ module EDParamsMod integer, public :: n_uptake_mode integer, public :: p_uptake_mode + real(r8), parameter, public :: tsoil_thresh_hmort = -2.0_r8 ! Soil temperature threshold below which hydraulic failure mortality is off (non-hydro only) + integer, parameter, public :: nclmax = 2 ! Maximum number of canopy layers - + ! parameters that govern the VAI (LAI+SAI) bins used in radiative transfer code integer, parameter, public :: nlevleaf = 30 ! number of leaf+stem layers in each canopy layer From ef1ee873eda060efc544bfeea20e73f4a74ccf03 Mon Sep 17 00:00:00 2001 From: jessica needham Date: Fri, 3 Nov 2023 15:26:08 -0700 Subject: [PATCH 175/250] remove checks --- biogeochem/EDMortalityFunctionsMod.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/biogeochem/EDMortalityFunctionsMod.F90 b/biogeochem/EDMortalityFunctionsMod.F90 index 029ca907dc..ea2b11b06d 100644 --- a/biogeochem/EDMortalityFunctionsMod.F90 +++ b/biogeochem/EDMortalityFunctionsMod.F90 @@ -161,8 +161,6 @@ subroutine mortality_rates( cohort_in,bc_in, btran_ft, mean_temp, & minval(bc_in%t_soisno_sl) - tfrz .ge. tsoil_thresh_hmort )then hmort = EDPftvarcon_inst%mort_scalar_hydrfailure(cohort_in%pft) else - write(fates_log(),*) 'jfn soil frozen - no hmort' - write(fates_log(),*) 'jfn min soil temp - ', minval(bc_in%t_soisno_sl) - tfrz hmort = 0.0_r8 endif endif From 86eaa052060bb940ad899975cf9a53b601742f5c Mon Sep 17 00:00:00 2001 From: jessica needham Date: Sat, 4 Nov 2023 11:46:44 -0700 Subject: [PATCH 176/250] Remove checks - rename soil temp threshold --- biogeochem/EDMortalityFunctionsMod.F90 | 6 +++--- biogeophys/EDBtranMod.F90 | 3 ++- main/EDParamsMod.F90 | 4 ++-- 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/biogeochem/EDMortalityFunctionsMod.F90 b/biogeochem/EDMortalityFunctionsMod.F90 index ea2b11b06d..2291e56b39 100644 --- a/biogeochem/EDMortalityFunctionsMod.F90 +++ b/biogeochem/EDMortalityFunctionsMod.F90 @@ -59,7 +59,7 @@ subroutine mortality_rates( cohort_in,bc_in, btran_ft, mean_temp, & use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm use FatesConstantsMod, only : fates_check_param_set use DamageMainMod, only : GetDamageMortality - use EDParamsmod, only : tsoil_thresh_hmort + use EDParamsmod, only : soil_tfrz_thresh type (fates_cohort_type), intent(in) :: cohort_in type (bc_in_type), intent(in) :: bc_in @@ -157,8 +157,8 @@ subroutine mortality_rates( cohort_in,bc_in, btran_ft, mean_temp, & hmort = 0.0_r8 endif else - if(btran_ft(cohort_in%pft) <= hf_sm_threshold .and. & - minval(bc_in%t_soisno_sl) - tfrz .ge. tsoil_thresh_hmort )then + if( ( btran_ft(cohort_in%pft) <= hf_sm_threshold ) .and. & + ( ( minval(bc_in%t_soisno_sl) - tfrz ) >= soil_tfrz_thresh ) ) then hmort = EDPftvarcon_inst%mort_scalar_hydrfailure(cohort_in%pft) else hmort = 0.0_r8 diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index a785493d54..c0a84ac701 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -12,6 +12,7 @@ module EDBtranMod use EDTypesMod , only : ed_site_type use FatesPatchMod, only : fates_patch_type use EDParamsMod, only : maxpft + use EDParamsMod, only : soil_tfrz_thresh use FatesCohortMod, only : fates_cohort_type use shr_kind_mod , only : r8 => shr_kind_r8 use FatesInterfaceTypesMod , only : bc_in_type, & @@ -48,7 +49,7 @@ logical function check_layer_water(h2o_liq_vol, tempk) check_layer_water = .false. if ( h2o_liq_vol .gt. 0._r8 ) then - if ( tempk .gt. tfrz-2._r8) then + if ( tempk .gt. soil_tfrz_thresh) then check_layer_water = .true. end if end if diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 489e0f209a..b3d0bfe669 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -95,12 +95,12 @@ module EDParamsMod integer, public :: n_uptake_mode integer, public :: p_uptake_mode - real(r8), parameter, public :: tsoil_thresh_hmort = -2.0_r8 ! Soil temperature threshold below which hydraulic failure mortality is off (non-hydro only) + real(r8), parameter, public :: soil_tfrz_thresh = -2.0_r8 ! Soil temperature threshold below which hydraulic failure mortality is off (non-hydro only) in degrees C integer, parameter, public :: nclmax = 2 ! Maximum number of canopy layers ! parameters that govern the VAI (LAI+SAI) bins used in radiative transfer code - integer, parameter, public :: nlevleaf = 30 ! number of leaf+stem layers in each canopy layer + integer, parameter, public :: nlevleaf = 40 ! number of leaf+stem layers in each canopy layer real(r8), public :: dinc_vai(nlevleaf) = fates_unset_r8 ! VAI bin widths array real(r8), public :: dlower_vai(nlevleaf) = fates_unset_r8 ! lower edges of VAI bins From 63c2c47698522402119602537c1a85ea0a6519f4 Mon Sep 17 00:00:00 2001 From: jessica needham Date: Sat, 4 Nov 2023 16:54:12 -0700 Subject: [PATCH 177/250] revert nlevleaf to 30 --- main/EDParamsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index b3d0bfe669..215d4c3ee7 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -100,7 +100,7 @@ module EDParamsMod integer, parameter, public :: nclmax = 2 ! Maximum number of canopy layers ! parameters that govern the VAI (LAI+SAI) bins used in radiative transfer code - integer, parameter, public :: nlevleaf = 40 ! number of leaf+stem layers in each canopy layer + integer, parameter, public :: nlevleaf = 30 ! number of leaf+stem layers in each canopy layer real(r8), public :: dinc_vai(nlevleaf) = fates_unset_r8 ! VAI bin widths array real(r8), public :: dlower_vai(nlevleaf) = fates_unset_r8 ! lower edges of VAI bins From 03aa382726fcc55e23c0020141b0206f33d1fa75 Mon Sep 17 00:00:00 2001 From: jessica needham Date: Sat, 4 Nov 2023 19:53:58 -0700 Subject: [PATCH 178/250] change >= to > to be consistent with btran calculation --- biogeochem/EDMortalityFunctionsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDMortalityFunctionsMod.F90 b/biogeochem/EDMortalityFunctionsMod.F90 index 2291e56b39..d849121c0e 100644 --- a/biogeochem/EDMortalityFunctionsMod.F90 +++ b/biogeochem/EDMortalityFunctionsMod.F90 @@ -158,7 +158,7 @@ subroutine mortality_rates( cohort_in,bc_in, btran_ft, mean_temp, & endif else if( ( btran_ft(cohort_in%pft) <= hf_sm_threshold ) .and. & - ( ( minval(bc_in%t_soisno_sl) - tfrz ) >= soil_tfrz_thresh ) ) then + ( ( minval(bc_in%t_soisno_sl) - tfrz ) > soil_tfrz_thresh ) ) then hmort = EDPftvarcon_inst%mort_scalar_hydrfailure(cohort_in%pft) else hmort = 0.0_r8 From 696365076d3029991bc9267fc753c68425949245 Mon Sep 17 00:00:00 2001 From: jessica needham Date: Sun, 5 Nov 2023 13:21:53 -0800 Subject: [PATCH 179/250] update soil freezing in btran calculation --- biogeophys/EDBtranMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index c0a84ac701..3e2401a033 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -49,7 +49,7 @@ logical function check_layer_water(h2o_liq_vol, tempk) check_layer_water = .false. if ( h2o_liq_vol .gt. 0._r8 ) then - if ( tempk .gt. soil_tfrz_thresh) then + if ( tempk .gt. soil_tfrz_thresh + tfrz) then check_layer_water = .true. end if end if From 83f81563787b18736a21aa218b83fb89875c9782 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 6 Nov 2023 17:01:10 -0500 Subject: [PATCH 180/250] Adding in protections to avoid Kb==a in two-stream --- radiation/TwoStreamMLPEMod.F90 | 89 +++++++++++++++++++++++++++++++--- 1 file changed, 83 insertions(+), 6 deletions(-) diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index cfec744480..9df7a54d5c 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -862,7 +862,13 @@ subroutine ZenithPrep(this,cosz) real(r8) :: betab_veg ! beam backscatter for vegetation (no snow) real(r8) :: betab_om ! multiplication of beam backscatter and reflectance real(r8) :: om_veg ! scattering coefficient for vegetation (no snow) - + real(r8) :: Kb_sing ! the KB_leaf that would generate a singularity + ! with the scelb%a parameter + real(r8), parameter :: Kb_stem = 1.0_r8 + real(r8), parameter :: sing_tol = 0.001_r8 ! allowable difference between + ! the Kb_leaf that creates + ! a singularity and the actual + if( (cosz-1.0) > nearzero ) then write(log_unit,*)"The cosine of the zenith angle cannot exceed 1" write(log_unit,*)"cosz: ",cosz @@ -896,16 +902,30 @@ subroutine ZenithPrep(this,cosz) !how much direct light penetrates a singleunit of lai? scelg%Kb_leaf = min(kb_max,rad_params%clumping_index(ft) * gdir / cosz) - !write(log_unit,*)"Kb_leaf: ",scelg%Kb_leaf,gdir , cosz + ! To avoid singularities, we need to make sure that Kb =/ a + ! If they are too similar, it will create a very large + ! term in the linear solution and generate solution errors + ! Lets identify the Kb_leaf that gives a singularity. + ! We don't need to include the min() function + ! a will never be that large. + ! + ! kb = a = (lai*kb_leaf + sai*1)/(lai+sai) + ! (a*(lai+sai) - sai*kb_stem)/lai = Kb_sing + + do_ib: do ib = 1,this%n_bands + Kb_sing = (this%band(ib)%scelb(ican,icol)%a*(scelg%lai+scelg%sai) - scelg%sai*Kb_stem)/scelg%lai + if(abs(scelg%Kb_leaf - Kb_sing) Date: Mon, 6 Nov 2023 17:25:29 -0500 Subject: [PATCH 181/250] clean up comments and old text in two-stream code --- radiation/TwoStreamMLPEMod.F90 | 56 +++------------------------------- 1 file changed, 4 insertions(+), 52 deletions(-) diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index 1da686eec0..4320ae95d2 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -42,7 +42,7 @@ Module TwoStreamMLPEMod ! Allowable error, as a fraction of total incident for total canopy ! radiation balance checks - real(r8), public, parameter :: rel_err_thresh = 1.e-4_r8 + real(r8), public, parameter :: rel_err_thresh = 1.e-6_r8 real(r8), public, parameter :: area_err_thresh = rel_err_thresh*0.1_r8 ! These are the codes for how the upper boundary is specified, normalized or absolute @@ -889,7 +889,7 @@ subroutine ZenithPrep(this,cosz) real(r8) :: Kb_sing ! the KB_leaf that would generate a singularity ! with the scelb%a parameter real(r8), parameter :: Kb_stem = 1.0_r8 - real(r8), parameter :: sing_tol = 0.001_r8 ! allowable difference between + real(r8), parameter :: sing_tol = 0.01_r8 ! allowable difference between ! the Kb_leaf that creates ! a singularity and the actual @@ -936,12 +936,12 @@ subroutine ZenithPrep(this,cosz) ! kb = a = (lai*kb_leaf + sai*1)/(lai+sai) ! (a*(lai+sai) - sai*kb_stem)/lai = Kb_sing - do_ib: do ib = 1,this%n_bands + do_ib0: do ib = 1,this%n_bands Kb_sing = (this%band(ib)%scelb(ican,icol)%a*(scelg%lai+scelg%sai) - scelg%sai*Kb_stem)/scelg%lai if(abs(scelg%Kb_leaf - Kb_sing) Date: Tue, 7 Nov 2023 20:07:57 -0700 Subject: [PATCH 182/250] Fixed keyword name to match --- main/EDMainMod.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 2b2da8a2ee..59e3096409 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -765,7 +765,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) end subroutine ed_integrate_state_variables !-------------------------------------------------------------------------------! - subroutine ed_update_site( currentSite, bc_in, bc_out, is_restart ) + subroutine ed_update_site( currentSite, bc_in, bc_out, is_restarting ) ! ! !DESCRIPTION: ! Calls routines to consolidate the ED growth process. @@ -781,19 +781,19 @@ subroutine ed_update_site( currentSite, bc_in, bc_out, is_restart ) type(ed_site_type) , intent(inout), target :: currentSite type(bc_in_type) , intent(in) :: bc_in type(bc_out_type) , intent(inout) :: bc_out - logical,intent(in) :: is_restart ! is this called during restart read? + logical,intent(in) :: is_restarting ! is this called during restart read? ! ! !LOCAL VARIABLES: type (fates_patch_type) , pointer :: currentPatch !----------------------------------------------------------------------- - if(hlm_use_sp.eq.ifalse .and. (.not.is_restart))then + if(hlm_use_sp.eq.ifalse .and. (.not.is_restarting))then call canopy_spread(currentSite) end if call TotalBalanceCheck(currentSite,6) - if(hlm_use_sp.eq.ifalse .and. (.not.is_restart) )then + if(hlm_use_sp.eq.ifalse .and. (.not.is_restarting) )then call canopy_structure(currentSite, bc_in) endif @@ -807,7 +807,7 @@ subroutine ed_update_site( currentSite, bc_in, bc_out, is_restart ) currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) - if(.not.is_restart)then + if(.not.is_restarting)then call terminate_cohorts(currentSite, currentPatch, 1, 11, bc_in) call terminate_cohorts(currentSite, currentPatch, 2, 11, bc_in) end if @@ -834,7 +834,7 @@ subroutine ed_update_site( currentSite, bc_in, bc_out, is_restart ) ! FIX(RF,032414). This needs to be monthly, not annual ! If this is the second to last day of the year, then perform trimming - if( hlm_day_of_year == hlm_days_per_year-1 .and. (.not.is_restart)) then + if( hlm_day_of_year == hlm_days_per_year-1 .and. (.not.is_restarting)) then if(hlm_use_sp.eq.ifalse)then call trim_canopy(currentSite) endif From 80c0fa9a9d1ee4d4cc1d5322860df0130588dd5c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 8 Nov 2023 08:09:02 -0700 Subject: [PATCH 183/250] making crown area available in the restart, because its needed --- main/FatesRestartInterfaceMod.F90 | 50 ++++++++++++++----------------- 1 file changed, 23 insertions(+), 27 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index baec2149e5..36a571516b 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -1133,21 +1133,21 @@ subroutine define_restart_vars(this, initialize_variables) ! Only register satellite phenology related restart variables if it is turned on! - if(hlm_use_sp .eq. itrue) then - call this%set_restart_var(vname='fates_cohort_area', vtype=cohort_r8, & - long_name='area of the fates cohort', & - units='m2', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_c_area_co ) - call this%set_restart_var(vname='fates_cohort_treelai', vtype=cohort_r8, & - long_name='leaf area index of fates cohort', & - units='m2/m2', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_treelai_co ) - call this%set_restart_var(vname='fates_cohort_treesai', vtype=cohort_r8, & - long_name='stem area index of fates cohort', & - units='m2/m2', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_treesai_co ) - - call this%set_restart_var(vname='fates_canopy_layer_tlai_pa', vtype=cohort_r8, & + call this%set_restart_var(vname='fates_cohort_area', vtype=cohort_r8, & + long_name='area of the fates cohort', & + units='m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_c_area_co ) + call this%set_restart_var(vname='fates_cohort_treelai', vtype=cohort_r8, & + long_name='leaf area index of fates cohort', & + units='m2/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_treelai_co ) + call this%set_restart_var(vname='fates_cohort_treesai', vtype=cohort_r8, & + long_name='stem area index of fates cohort', & + units='m2/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_treesai_co ) + + if(hlm_use_sp .eq. itrue)then + call this%set_restart_var(vname='fates_canopy_layer_tlai_pa', vtype=cohort_r8, & long_name='total patch level leaf area index of each fates canopy layer', & units='m2/m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_layer_tlai_pa ) @@ -2376,12 +2376,10 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_isnew_co(io_idx_co) = old_cohort endif - if (hlm_use_sp .eq. itrue) then - this%rvars(ir_c_area_co)%r81d(io_idx_co) = ccohort%c_area - this%rvars(ir_treelai_co)%r81d(io_idx_co) = ccohort%treelai - this%rvars(ir_treesai_co)%r81d(io_idx_co) = ccohort%treesai - end if - + this%rvars(ir_c_area_co)%r81d(io_idx_co) = ccohort%c_area + this%rvars(ir_treelai_co)%r81d(io_idx_co) = ccohort%treelai + this%rvars(ir_treesai_co)%r81d(io_idx_co) = ccohort%treesai + if ( debug ) then write(fates_log(),*) 'CLTV offsetNumCohorts II ',io_idx_co, & cohortsperpatch @@ -3314,12 +3312,10 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! (Keeping as an example) !call this%GetRMeanRestartVar(ccohort%tveg_lpa, ir_tveglpa_co, io_idx_co) - if (hlm_use_sp .eq. itrue) then - ccohort%c_area = this%rvars(ir_c_area_co)%r81d(io_idx_co) - ccohort%treelai = this%rvars(ir_treelai_co)%r81d(io_idx_co) - ccohort%treesai = this%rvars(ir_treesai_co)%r81d(io_idx_co) - end if - + ccohort%c_area = this%rvars(ir_c_area_co)%r81d(io_idx_co) + ccohort%treelai = this%rvars(ir_treelai_co)%r81d(io_idx_co) + ccohort%treesai = this%rvars(ir_treesai_co)%r81d(io_idx_co) + io_idx_co = io_idx_co + 1 ccohort => ccohort%taller From 2e140bef290844dc3df19be98656131d02bd674d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 8 Nov 2023 11:14:00 -0500 Subject: [PATCH 184/250] small tweaks to error tracking in fates two-stream --- biogeochem/FatesPatchMod.F90 | 6 ++- main/FatesHistoryInterfaceMod.F90 | 30 +++++++------- radiation/FatesRadiationDriveMod.F90 | 7 ++-- radiation/TwoStreamMLPEMod.F90 | 58 +++++++++++++--------------- 4 files changed, 50 insertions(+), 51 deletions(-) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index d5c31769dc..e9c2dac5d6 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -380,8 +380,10 @@ subroutine NanValues(this) this%scorch_ht(:) = nan this%frac_burnt = nan this%tfc_ros = nan - this%burnt_frac_litter(:) = nan - + this%burnt_frac_litter(:) = nan + this%solve_err(:) = nan + this%convs_err(:) = nan + end subroutine NanValues !=========================================================================== diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index e95230c23b..9ddca1bf27 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -4411,7 +4411,7 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste real(r8) :: dt_tstep_inv ! inverse timestep (1/sec) real(r8) :: n_perm2 ! number of plants per square meter real(r8) :: sum_area_rad ! sum of patch canopy areas - real(r8),allocatable :: age_area_rad_inv(:) + real(r8),allocatable :: age_area_rad(:) type(fates_patch_type),pointer :: cpatch type(fates_cohort_type),pointer :: ccohort @@ -4456,7 +4456,7 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste dt_tstep_inv = 1.0_r8/dt_tstep - allocate(age_area_rad_inv(size(ED_val_history_ageclass_bin_edges,1)+1)) + allocate(age_area_rad(size(ED_val_history_ageclass_bin_edges,1)+1)) do_sites: do s = 1,nsites @@ -4471,7 +4471,7 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste ! We do not call the radiation solver if ! a) there is no vegetation ! b) there is no light! (ie cos(zenith) ~= 0) - age_area_rad_inv(:) = 0._r8 + age_area_rad(:) = 0._r8 cpatch => sites(s)%oldest_patch do while(associated(cpatch)) ! We initialize the solver error to the ignore value @@ -4481,12 +4481,12 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste ! error. So the check on VIS solve error will catch all. if( abs(cpatch%solve_err(ivis)-hlm_hio_ignore_val)>nearzero ) then age_class = get_age_class_index(cpatch%age) - age_area_rad_inv(age_class) = age_area_rad_inv(age_class) + cpatch%total_canopy_area + age_area_rad(age_class) = age_area_rad(age_class) + cpatch%total_canopy_area end if cpatch => cpatch%younger end do - sum_area_rad = sum(age_area_rad_inv(:)) + sum_area_rad = sum(age_area_rad(:)) if_anyrad: if(sum_area_rad cpatch%younger @@ -4681,7 +4681,7 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste end if if_veg_area end do do_sites - deallocate(age_area_rad_inv) + deallocate(age_area_rad) end associate return diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index 6a84e0fb17..bfe76a3221 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -112,6 +112,9 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 + currentPatch%solve_err(:) = hlm_hio_ignore_val + currentPatch%consv_err(:) = hlm_hio_ignore_val + !cpatch%ed_parsun_z(ican,ipft,ileaf) if_notbareground: if(currentpatch%nocomp_pft_label.ne.nocomp_bareground)then @@ -125,9 +128,7 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) currentPatch%gnd_alb_dif(1:hlm_numSWb) = bc_in(s)%albgr_dif_rb(1:hlm_numSWb) currentPatch%gnd_alb_dir(1:hlm_numSWb) = bc_in(s)%albgr_dir_rb(1:hlm_numSWb) currentPatch%fcansno = bc_in(s)%fcansno_pa(ifp) - currentPatch%solve_err(:) = hlm_hio_ignore_val - currentPatch%consv_err(:) = hlm_hio_ignore_val - + if(radiation_model.eq.twostr_solver) then call currentPatch%twostr%CanopyPrep(bc_in(s)%fcansno_pa(ifp)) call currentPatch%twostr%ZenithPrep(bc_in(s)%coszen_pa(ifp)) diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index 4320ae95d2..7e62bfada7 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -1076,6 +1076,7 @@ subroutine Solve(this, ib, & real(r8) :: albedo_beam ! Mean albedo at canopy top generated from beam radiation [-] real(r8) :: albedo_diff ! Mean albedo at canopy top generated from downwelling diffuse [-] + real(r8) :: temp_err ! Used to build the other error terms, a temp real(r8) :: solve_err ! This is the maximum error encountered when comparing the forward solution ! of the linear solution A*x, to the known b, in Ax=b. This is the maximum ! considering all equations, and both beam and diffuse boundaries. Units @@ -1129,7 +1130,7 @@ subroutine Solve(this, ib, & real(r8) :: r_abs_stem ! total absorbed by stems (dummy) real(r8) :: r_abs_snow ! total absorbed by snow (dummy) real(r8) :: leaf_sun_frac ! sunlit fraction of leaves (dummy) - real(r8) :: rel_err ! radiation canopy balance conservation + real(r8) :: consv_err ! radiation canopy balance conservation ! error, fraction of incident real(r8) :: beam_err,diff_err ! error partitioned by beam and diffuse @@ -1186,13 +1187,7 @@ subroutine Solve(this, ib, & ! upper canopy. ! -------------------------------------------------------------------------- - if(debug)then - solve_err = 0._r8 - else - solve_err = -unset_r8 - end if - - consv_err = 0._r8 + solve_err = 0._r8 if((Rbeam_atm+Rdiff_atm)rel_err_thresh)then - write(log_unit,*) 'Poor forward solution on two-stream solver' - write(log_unit,*) 'isol (1=beam or 2=diff): ',isol - write(log_unit,*) 'i (equation): ',ilem - write(log_unit,*) 'band index (1=vis,2=nir): ',ib - write(log_unit,*) 'error (tau(i) - omega(i,:)*lambda(:)) ',rel_err - this%band(ib)%Rbeam_atm = 1._r8 - this%band(ib)%Rdiff_atm = 1._r8 - call this%Dump(ib) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end do - deallocate(tau_temp,omega_temp) - end if - + ! Perform a forward check on the solution error + do ilem = 1,n_eq + temp_err = tau_temp(ilem) - sum(taulamb(1:n_eq)*omega_temp(ilem,1:n_eq)) + solve_err = max(solve_err,abs(temp_err)) + if(abs(temp_err)>rel_err_thresh)then + write(log_unit,*) 'Poor forward solution on two-stream solver' + write(log_unit,*) 'isol (1=beam or 2=diff): ',isol + write(log_unit,*) 'i (equation): ',ilem + write(log_unit,*) 'band index (1=vis,2=nir): ',ib + write(log_unit,*) 'error (tau(i) - omega(i,:)*lambda(:)) ',temp_err + this%band(ib)%Rbeam_atm = 1._r8 + this%band(ib)%Rdiff_atm = 1._r8 + call this%Dump(ib) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do + deallocate(tau_temp,omega_temp) + ! Save the solution terms @@ -1652,12 +1645,15 @@ subroutine Solve(this, ib, & ! Source = upwelling + canopy absorbed + ground absorbed - rel_err = ((Rbeam_atm + Rdiff_atm) - & + consv_err = ((Rbeam_atm + Rdiff_atm) - & (albedo_diff + albedo_beam ) - & (frac_abs_can_diff + frac_abs_can_beam) - & ((frac_diff_grnd_diff+frac_diff_grnd_beam)*(1._r8-this%band(ib)%albedo_grnd_diff)) - & (frac_beam_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_beam)) ) / (Rbeam_atm + Rdiff_atm) + ! This is an error magnitude, not a bias + consv_err = abs(consv_err) + beam_err = Rbeam_atm - (albedo_beam + frac_abs_can_beam + & frac_diff_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_diff) + & frac_beam_grnd_beam*(1._r8-this%band(ib)%albedo_grnd_beam)) @@ -1665,9 +1661,9 @@ subroutine Solve(this, ib, & diff_err = Rdiff_atm - (albedo_diff + frac_abs_can_diff + & frac_diff_grnd_diff*(1._r8-this%band(ib)%albedo_grnd_diff)) - if( abs(rel_err) > rel_err_thresh ) then + if( consv_err > rel_err_thresh ) then write(log_unit,*)"Total canopy flux balance not closing in TwoStrteamMLPEMod:Solve" - write(log_unit,*)"Relative Error, delta/(Rbeam_atm+Rdiff_atm) :",rel_err + write(log_unit,*)"Relative Error, delta/(Rbeam_atm+Rdiff_atm) :",consv_err write(log_unit,*)"Max Error: ",rel_err_thresh write(log_unit,*)"ib: ",ib write(log_unit,*)"scattering coeff: ",(2*rad_params%om_leaf(ib,1)+0.5*rad_params%om_stem(ib,1))/2.5 From 58732e5bda2d6881b28ee06a618903bca293bbb8 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 8 Nov 2023 14:26:42 -0800 Subject: [PATCH 185/250] correct the way YEAR is updated Since regridding skips 'timesince' in the input dataset (and isn't necessary to regrid), simply pass the value from the original ds_luh2 dataset --- tools/luh2/luh2.py | 2 +- tools/luh2/luh2.sh | 2 +- tools/luh2/luh2mod.py | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/tools/luh2/luh2.py b/tools/luh2/luh2.py index c5f3983e3e..7ea0af9fa3 100644 --- a/tools/luh2/luh2.py +++ b/tools/luh2/luh2.py @@ -64,7 +64,7 @@ def main(): # Note that the time variable from the LUH2 data is 'years since ...' so we need to # add the input data year if (not "YEAR" in list(regrid_luh2.variables)): - regrid_luh2["YEAR"] = regrid_luh2.time + regrid_luh2.timesince + regrid_luh2["YEAR"] = regrid_luh2.time + ds_luh2.timesince regrid_luh2["LONGXY"] = ds_regrid_target["LONGXY"] # TO DO: double check if this is strictly necessary regrid_luh2["LATIXY"] = ds_regrid_target["LATIXY"] # TO DO: double check if this is strictly necessary diff --git a/tools/luh2/luh2.sh b/tools/luh2/luh2.sh index 3aa246907d..1d088ba7e4 100755 --- a/tools/luh2/luh2.sh +++ b/tools/luh2/luh2.sh @@ -42,7 +42,7 @@ echo -e"storage status:\n" du -h ${OUTPUT_LOC} # Regrid the luh2 transitions data using the saved regridder weights file and merge into previous regrid output -python luh2.py -b ${START} -e ${END} -l ${TRANSITIONS} -s ${STATIC} -r ${REGRID_TARGET} -w ${REGRIDDER} \ +python luh2.py -b ${START} -e ${END}-1 -l ${TRANSITIONS} -s ${STATIC} -r ${REGRID_TARGET} -w ${REGRIDDER} \ -m ${OUTPUT_LOC}/states_regrid.nc -o ${OUTPUT_LOC}/states_trans_regrid.nc echo -e"storage status:\n" du -h ${OUTPUT_LOC} diff --git a/tools/luh2/luh2mod.py b/tools/luh2/luh2mod.py index d0f21b9060..1581f949fc 100644 --- a/tools/luh2/luh2mod.py +++ b/tools/luh2/luh2mod.py @@ -202,7 +202,7 @@ def RegridLoop(ds_to_regrid, regridder): for i in range(varlen-1): # Skip time variable - if (ds_varnames[i] != "time"): + if (not "time" in ds_varnames[i]): # Only regrid variables that match the lat/lon shape. if (ds_to_regrid[ds_varnames[i]][0].shape == (ds_to_regrid.lat.shape[0], ds_to_regrid.lon.shape[0])): From 0913be784986ee06151bea7fd0f6650891defc9b Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 8 Nov 2023 14:36:47 -0800 Subject: [PATCH 186/250] start setting up a refactor of the luh2 shell script --- tools/luh2/luh2.sh | 2 +- tools/luh2/luh2mod.py | 15 +++++++++------ 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/tools/luh2/luh2.sh b/tools/luh2/luh2.sh index 1d088ba7e4..3aa246907d 100755 --- a/tools/luh2/luh2.sh +++ b/tools/luh2/luh2.sh @@ -42,7 +42,7 @@ echo -e"storage status:\n" du -h ${OUTPUT_LOC} # Regrid the luh2 transitions data using the saved regridder weights file and merge into previous regrid output -python luh2.py -b ${START} -e ${END}-1 -l ${TRANSITIONS} -s ${STATIC} -r ${REGRID_TARGET} -w ${REGRIDDER} \ +python luh2.py -b ${START} -e ${END} -l ${TRANSITIONS} -s ${STATIC} -r ${REGRID_TARGET} -w ${REGRIDDER} \ -m ${OUTPUT_LOC}/states_regrid.nc -o ${OUTPUT_LOC}/states_trans_regrid.nc echo -e"storage status:\n" du -h ${OUTPUT_LOC} diff --git a/tools/luh2/luh2mod.py b/tools/luh2/luh2mod.py index 1581f949fc..9f3d26333a 100644 --- a/tools/luh2/luh2mod.py +++ b/tools/luh2/luh2mod.py @@ -30,7 +30,7 @@ def PrepDataset(input_dataset,start=None,stop=None,merge_flag=False): # 'years since' style format. if(not(dstype in ('static','regrid'))): - if (dstype == 'LUH2'): + if ('LUH2' in dstype): # Get the units to determine the file time # It is expected that the units of time is 'years since ...' time_since_array = input_dataset.time.units.split() @@ -80,7 +80,7 @@ def PrepDataset(input_dataset,start=None,stop=None,merge_flag=False): def PrepDataset_ESMF(input_dataset,dsflag,dstype): if (dsflag): - if(dstype == "LUH2"): + if("LUH2" in dstype): print("PrepDataset: LUH2") input_dataset = BoundsVariableFixLUH2(input_dataset) elif(dstype == "surface"): @@ -142,15 +142,18 @@ def CheckDataset(input_dataset): dsflag = False dsvars = list(input_dataset.variables) if('primf' in dsvars or - 'primf_to_secdn' in dsvars or any('irrig' in subname for subname in dsvars)): - dstype = 'LUH2' + if ('primf_to_secdn' in dsvars): + dstype = 'LUH2_transitions' + else: + dstype = 'LUH2' + dsflag = True - print("LUH2") + # print("LUH2") elif('natpft' in dsvars): dstype = 'surface' dsflag = True - print("Surface") + # print("Surface") elif('icwtr' in dsvars): dstype = 'static' dsflag = True From 17ed1b3410113d3dd2f946c0360238016dc638bb Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 8 Nov 2023 14:43:11 -0800 Subject: [PATCH 187/250] fix how luh2 data tool check luh2 file type --- tools/luh2/luh2mod.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/luh2/luh2mod.py b/tools/luh2/luh2mod.py index 9f3d26333a..801baa96fc 100644 --- a/tools/luh2/luh2mod.py +++ b/tools/luh2/luh2mod.py @@ -141,7 +141,7 @@ def CheckDataset(input_dataset): dsflag = False dsvars = list(input_dataset.variables) - if('primf' in dsvars or + if(any('primf' in subname for subname in dsvars) or any('irrig' in subname for subname in dsvars)): if ('primf_to_secdn' in dsvars): dstype = 'LUH2_transitions' From 77899da0b9bc6d5fd022a0b65d8a80b4580caab2 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 8 Nov 2023 19:28:44 -0800 Subject: [PATCH 188/250] adding attribute copy to luh2 data tool to avoid losing unit data during regrid --- tools/luh2/luh2.py | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/tools/luh2/luh2.py b/tools/luh2/luh2.py index 7ea0af9fa3..ec111c88f6 100644 --- a/tools/luh2/luh2.py +++ b/tools/luh2/luh2.py @@ -72,6 +72,12 @@ def main(): if (not 'lsmlat' in list(regrid_luh2.dims)): regrid_luh2 = regrid_luh2.rename_dims({'lat':'lsmlat','lon':'lsmlon'}) + # Reapply the coordinate attributes. This is a workaround for an xarray bug (#8047) + # Currently only need time + regrid_luh2.time.attrs = ds_luh2.time.attrs + regrid_luh2.lat.attrs = ds_luh2.lat.attrs + regrid_luh2.lon.attrs = ds_luh2.lon.attrs + # Merge existing regrided luh2 file with merge input target # TO DO: check that the grid resolution # We could do this with an append during the write phase instead of the merge From 9f6f5c22f48a998a2f39125b06b6e414eb730fe7 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 9 Nov 2023 09:58:18 -0500 Subject: [PATCH 189/250] cleaning up conservation error diagnostics --- biogeochem/FatesPatchMod.F90 | 2 +- radiation/TwoStreamMLPEMod.F90 | 12 ++++-------- 2 files changed, 5 insertions(+), 9 deletions(-) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index e9c2dac5d6..eae3e2fa7a 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -382,7 +382,7 @@ subroutine NanValues(this) this%tfc_ros = nan this%burnt_frac_litter(:) = nan this%solve_err(:) = nan - this%convs_err(:) = nan + this%consv_err(:) = nan end subroutine NanValues diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index 7e62bfada7..7b3a80640e 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -1081,12 +1081,9 @@ subroutine Solve(this, ib, & ! of the linear solution A*x, to the known b, in Ax=b. This is the maximum ! considering all equations, and both beam and diffuse boundaries. Units ! are a fraction relative to the boundary flux. - - real(r8) :: consv_err ! This is the error that is returned when seeing if the - ! total albedo matches the total absorbed by all cohorts and - ! the soil absorbed radiation. It is a fraction based - ! on upper boundaries of 1 W/m2 for both beam and diffuse - + real(r8) :: consv_err ! radiation canopy balance conservation + ! error, fraction of incident + real(r8) :: frac_abs_can_beam ! Fraction of incident beam radiation absorbed by the vegetation [-] real(r8) :: frac_abs_can_diff ! Fraction of incident diffuse radiation absorbed by the vegetation [-] real(r8) :: frac_beam_grnd_beam ! fraction of beam radiation at ground resulting from of beam at canopy top [-] @@ -1130,8 +1127,7 @@ subroutine Solve(this, ib, & real(r8) :: r_abs_stem ! total absorbed by stems (dummy) real(r8) :: r_abs_snow ! total absorbed by snow (dummy) real(r8) :: leaf_sun_frac ! sunlit fraction of leaves (dummy) - real(r8) :: consv_err ! radiation canopy balance conservation - ! error, fraction of incident + real(r8) :: beam_err,diff_err ! error partitioned by beam and diffuse type(scelg_type),pointer :: scelgp ! Pointer to the scelg data structure From 3fa96a37623bdd7de80dd8fb62bd7e710d55ec45 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 12 Nov 2023 12:54:13 -0500 Subject: [PATCH 190/250] Tweaking the correction to beam optical depth, needs provisions for no LAI and for the a parameter to be calculated prior --- radiation/TwoStreamMLPEMod.F90 | 61 +++++++++++++++++++++------------- 1 file changed, 38 insertions(+), 23 deletions(-) diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index 7b3a80640e..ca2900646c 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -745,7 +745,8 @@ subroutine CanopyPrep(this,frac_snow) real(r8) :: betad_veg ! diffuse backscatter for vegetation (no snow) real(r8) :: betad_om ! multiplication of diffuse backscatter and reflectance real(r8) :: area_check ! Checks to make sure each layer has 100% coverage - + real(r8) :: a2 ! The "a" term squared + this%frac_snow = frac_snow if(.not.this%force_prep) then @@ -837,6 +838,18 @@ subroutine CanopyPrep(this,frac_snow) end if end if + + a2 = scelg%Kd*scelg%Kd*(1._r8-scelb%om)*(1._r8-scelb%om+2._r8*scelb%om*scelb%betad) + if(a2<0._r8) then + write(log_unit,*)'a^2 is less than zero' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! We also have to avoid singularities, see Ad and Au below, + ! where a^2-Kb^2 is in the denominator + + scelb%a = sqrt(a2) + end associate end do do_bands end associate @@ -888,7 +901,9 @@ subroutine ZenithPrep(this,cosz) real(r8) :: om_veg ! scattering coefficient for vegetation (no snow) real(r8) :: Kb_sing ! the KB_leaf that would generate a singularity ! with the scelb%a parameter - real(r8), parameter :: Kb_stem = 1.0_r8 + real(r8) :: Kb_stem ! actual optical depth of stem with not planar geometry effects + ! usually the base value + real(r8), parameter :: Kb_stem_base = 1.0_r8 real(r8), parameter :: sing_tol = 0.01_r8 ! allowable difference between ! the Kb_leaf that creates ! a singularity and the actual @@ -923,6 +938,8 @@ subroutine ZenithPrep(this,cosz) else gdir = rad_params%phi1(ft) + rad_params%phi2(ft) * cosz + Kb_stem = Kb_stem_base + !how much direct light penetrates a singleunit of lai? scelg%Kb_leaf = min(kb_max,rad_params%clumping_index(ft) * gdir / cosz) @@ -933,15 +950,25 @@ subroutine ZenithPrep(this,cosz) ! We don't need to include the min() function ! a will never be that large. ! - ! kb = a = (lai*kb_leaf + sai*1)/(lai+sai) + ! kb = a = (lai*kb_leaf + sai*kb_stem)/(lai+sai) ! (a*(lai+sai) - sai*kb_stem)/lai = Kb_sing - - do_ib0: do ib = 1,this%n_bands - Kb_sing = (this%band(ib)%scelb(ican,icol)%a*(scelg%lai+scelg%sai) - scelg%sai*Kb_stem)/scelg%lai - if(abs(scelg%Kb_leaf - Kb_sing)nearzero) then + do ib = 1,this%n_bands + Kb_sing = (this%band(ib)%scelb(ican,icol)%a*(scelg%lai+scelg%sai) - scelg%sai*Kb_stem)/scelg%lai + if(abs(scelg%Kb_leaf - Kb_sing) this%scelg(ican,icol) scelbp => this%band(ib)%scelb(ican,icol) - a2 = scelgp%Kd*scelgp%Kd*(scelbp%om-1._r8)*(scelbp%om-1._r8-2._r8*scelbp%om*scelbp%betad) - - if(a2<0._r8) then - write(log_unit,*)'a^2 is less than zero' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! We also have to avoid singularities, see Ad and Au below, - ! where a^2-Kb^2 is in the denominator - - scelbp%a = sqrt(a2) - b2 = -(scelgp%Kd*(1._r8-scelbp%om)*(1._r8-2._r8*scelbp%betab)+scelgp%Kb) * & scelbp%om*scelgp%Kb*scelbp%Rbeam0 From c37d878e527eff9728b927423530dc8096f1b3c2 Mon Sep 17 00:00:00 2001 From: adrifoster Date: Tue, 14 Nov 2023 08:52:57 -0700 Subject: [PATCH 191/250] fixing indents --- main/FatesInterfaceMod.F90 | 52 +++++++++++++++++++------------------- 1 file changed, 26 insertions(+), 26 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 5f8ff245ac..2fa1ad8c39 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2391,38 +2391,38 @@ end subroutine DetermineGridCellNeighbors ! ====================================================================================== - !----------------------------------------------------------------------- - ! TODO(jpalex): this belongs in FatesParametersInterface.F90, but would require - ! untangling the dependencies of the *RegisterParams methods below. - subroutine FatesReadParameters(param_reader) - implicit none - - class(fates_param_reader_type), intent(in) :: param_reader ! HLM-provided param file reader +!----------------------------------------------------------------------- +! TODO(jpalex): this belongs in FatesParametersInterface.F90, but would require +! untangling the dependencies of the *RegisterParams methods below. +subroutine FatesReadParameters(param_reader) + implicit none + + class(fates_param_reader_type), intent(in) :: param_reader ! HLM-provided param file reader - character(len=32) :: subname = 'FatesReadParameters' - class(fates_parameters_type), allocatable :: fates_params + character(len=32) :: subname = 'FatesReadParameters' + class(fates_parameters_type), allocatable :: fates_params - if ( hlm_masterproc == itrue ) then - write(fates_log(), *) 'FatesParametersInterface.F90::'//trim(subname)//' :: CLM reading ED/FATES '//' parameters ' - end if + if ( hlm_masterproc == itrue ) then + write(fates_log(), *) 'FatesParametersInterface.F90::'//trim(subname)//' :: CLM reading ED/FATES '//' parameters ' + end if - allocate(fates_params) - call fates_params%Init() ! fates_params class, in FatesParameterInterfaceMod - call FatesRegisterParams(fates_params) !EDParamsMod, only operates on fates_params class - call SpitFireRegisterParams(fates_params) !SpitFire Mod, only operates of fates_params class - call PRTRegisterParams(fates_params) ! PRT mod, only operates on fates_params class - call FatesSynchronizedParamsInst%RegisterParams(fates_params) !Synchronized params class in Synchronized params mod, only operates on fates_params class + allocate(fates_params) + call fates_params%Init() ! fates_params class, in FatesParameterInterfaceMod + call FatesRegisterParams(fates_params) !EDParamsMod, only operates on fates_params class + call SpitFireRegisterParams(fates_params) !SpitFire Mod, only operates of fates_params class + call PRTRegisterParams(fates_params) ! PRT mod, only operates on fates_params class + call FatesSynchronizedParamsInst%RegisterParams(fates_params) !Synchronized params class in Synchronized params mod, only operates on fates_params class - call param_reader%Read(fates_params) + call param_reader%Read(fates_params) - call FatesReceiveParams(fates_params) - call SpitFireReceiveParams(fates_params) - call PRTReceiveParams(fates_params) - call FatesSynchronizedParamsInst%ReceiveParams(fates_params) + call FatesReceiveParams(fates_params) + call SpitFireReceiveParams(fates_params) + call PRTReceiveParams(fates_params) + call FatesSynchronizedParamsInst%ReceiveParams(fates_params) - call fates_params%Destroy() - deallocate(fates_params) + call fates_params%Destroy() + deallocate(fates_params) end subroutine FatesReadParameters - + end module FatesInterfaceMod From 03446604fa78e80fdbfe22979212ac92a2e5bc86 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Thu, 16 Nov 2023 13:16:48 -0700 Subject: [PATCH 192/250] update diffs --- main/FatesInterfaceMod.F90 | 300 ++++++++++++++++++------------------- 1 file changed, 150 insertions(+), 150 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 2fa1ad8c39..bb3021cb4a 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2182,210 +2182,210 @@ end subroutine SeedlingParPatch subroutine DetermineGridCellNeighbors(neighbors,seeds,numg) - ! This subroutine utilizes information from the decomposition and domain types to determine - ! the set of grid cell neighbors within some maximum distance. It records the distance for each - ! neighbor for later use. This should be called after decompInit_lnd and surf_get_grid - ! as it relies on ldecomp and ldomain information. - - use decompMod , only : procinfo - use domainMod , only : ldomain - use spmdMod , only : MPI_REAL8, MPI_INTEGER, mpicom, npes, masterproc, iam - use perf_mod , only : t_startf, t_stopf - use FatesDispersalMod , only : neighborhood_type, neighbor_type, ProbabilityDensity, dispersal_type - use FatesUtilsMod , only : GetNeighborDistance - use FatesConstantsMod , only : fates_unset_int - use EDPftvarcon , only : EDPftvarcon_inst + ! This subroutine utilizes information from the decomposition and domain types to determine + ! the set of grid cell neighbors within some maximum distance. It records the distance for each + ! neighbor for later use. This should be called after decompInit_lnd and surf_get_grid + ! as it relies on ldecomp and ldomain information. - ! Arguments - type(neighborhood_type), intent(inout), pointer :: neighbors(:) ! land gridcell neighbor data structure - type(dispersal_type), intent(inout) :: seeds ! land gridcell neighbor data structure - integer , intent(in) :: numg ! number of land gridcells + use decompMod , only : procinfo + use domainMod , only : ldomain + use spmdMod , only : MPI_REAL8, MPI_INTEGER, mpicom, npes, masterproc, iam + use perf_mod , only : t_startf, t_stopf + use FatesDispersalMod , only : neighborhood_type, neighbor_type, ProbabilityDensity, dispersal_type + use FatesUtilsMod , only : GetNeighborDistance + use FatesConstantsMod , only : fates_unset_int + use EDPftvarcon , only : EDPftvarcon_inst - ! Local variables - type (neighbor_type), pointer :: current_neighbor - type (neighbor_type), pointer :: another_neighbor + ! Arguments + type(neighborhood_type), intent(inout), pointer :: neighbors(:) ! land gridcell neighbor data structure + type(dispersal_type), intent(inout) :: seeds ! land gridcell neighbor data structure + integer , intent(in) :: numg ! number of land gridcells - integer :: i, gi, gj, ni ! indices - integer :: ier, mpierr ! error status - integer :: ipft ! pft index + ! Local variables + type (neighbor_type), pointer :: current_neighbor + type (neighbor_type), pointer :: another_neighbor - integer, allocatable :: ncells_array(:), begg_array(:) ! number of cells and starting global grid cell index per process - real(r8), allocatable :: gclat(:), gclon(:) ! local array holding gridcell lat and lon + integer :: i, gi, gj, ni ! indices + integer :: ier, mpierr ! error status + integer :: ipft ! pft index - real(r8) :: g2g_dist ! grid cell distance (m) - real(r8) :: pdf ! probability density function output + integer, allocatable :: ncells_array(:), begg_array(:) ! number of cells and starting global grid cell index per process + real(r8), allocatable :: gclat(:), gclon(:) ! local array holding gridcell lat and lon - if(debug .and. hlm_is_restart .eq. itrue) write(fates_log(),*) 'gridcell initialization during restart' + real(r8) :: g2g_dist ! grid cell distance (m) + real(r8) :: pdf ! probability density function output - if(debug) write(fates_log(),*)'DGCN: npes, numg: ', npes, numg + if(debug .and. hlm_is_restart .eq. itrue) write(fates_log(),*) 'gridcell initialization during restart' - ! Allocate and initialize array neighbor type - allocate(neighbors(numg), stat=ier) - neighbors(:)%neighbor_count = 0 + if(debug) write(fates_log(),*)'DGCN: npes, numg: ', npes, numg - ! Allocate and initialize local lat and lon arrays - allocate(gclat(numg), stat=ier) - if(debug) write(fates_log(),*)'DGCN: gclat alloc: ', ier + ! Allocate and initialize array neighbor type + allocate(neighbors(numg), stat=ier) + neighbors(:)%neighbor_count = 0 - allocate(gclon(numg), stat=ier) - if(debug) write(fates_log(),*)'DGCN: gclon alloc: ', ier + ! Allocate and initialize local lat and lon arrays + allocate(gclat(numg), stat=ier) + if(debug) write(fates_log(),*)'DGCN: gclat alloc: ', ier - gclon(:) = nan - gclat(:) = nan + allocate(gclon(numg), stat=ier) + if(debug) write(fates_log(),*)'DGCN: gclon alloc: ', ier - ! Allocate and initialize MPI count and displacement values - allocate(ncells_array(0:npes-1), stat=ier) - if(debug) write(fates_log(),*)'DGCN: ncells alloc: ', ier + gclon(:) = nan + gclat(:) = nan - allocate(begg_array(0:npes-1), stat=ier) - if(debug) write(fates_log(),*)'DGCN: begg alloc: ', ier + ! Allocate and initialize MPI count and displacement values + allocate(ncells_array(0:npes-1), stat=ier) + if(debug) write(fates_log(),*)'DGCN: ncells alloc: ', ier - ncells_array(:) = fates_unset_int - begg_array(:) = fates_unset_int + allocate(begg_array(0:npes-1), stat=ier) + if(debug) write(fates_log(),*)'DGCN: begg alloc: ', ier - call t_startf('fates-seed-init-allgather') + ncells_array(:) = fates_unset_int + begg_array(:) = fates_unset_int - if(debug) write(fates_log(),*)'DGCN: procinfo%begg: ', procinfo%begg - if(debug) write(fates_log(),*)'DGCN: procinfo%ncells: ', procinfo%ncells + call t_startf('fates-seed-init-allgather') - ! Gather the sizes of the ldomain that each mpi rank is passing - call MPI_Allgather(procinfo%ncells,1,MPI_INTEGER,ncells_array,1,MPI_INTEGER,mpicom,mpierr) - if(debug) write(fates_log(),*)'DGCN: ncells mpierr: ', mpierr + if(debug) write(fates_log(),*)'DGCN: procinfo%begg: ', procinfo%begg + if(debug) write(fates_log(),*)'DGCN: procinfo%ncells: ', procinfo%ncells - ! Gather the starting gridcell index for each ldomain - call MPI_Allgather(procinfo%begg,1,MPI_INTEGER,begg_array,1,MPI_INTEGER,mpicom,mpierr) - if(debug) write(fates_log(),*)'DGCN: begg mpierr: ', mpierr + ! Gather the sizes of the ldomain that each mpi rank is passing + call MPI_Allgather(procinfo%ncells,1,MPI_INTEGER,ncells_array,1,MPI_INTEGER,mpicom,mpierr) + if(debug) write(fates_log(),*)'DGCN: ncells mpierr: ', mpierr - ! reduce the begg_array displacements by one as MPI collectives expect zero indexed arrays - begg_array = begg_array - 1 + ! Gather the starting gridcell index for each ldomain + call MPI_Allgather(procinfo%begg,1,MPI_INTEGER,begg_array,1,MPI_INTEGER,mpicom,mpierr) + if(debug) write(fates_log(),*)'DGCN: begg mpierr: ', mpierr - if(debug) write(fates_log(),*)'DGCN: ncells_array: ' , ncells_array - if(debug) write(fates_log(),*)'DGCN: begg_array: ' , begg_array + ! reduce the begg_array displacements by one as MPI collectives expect zero indexed arrays + begg_array = begg_array - 1 - ! Gather the domain information together into the neighbor type - ! Note that MPI_Allgatherv is only gathering a subset of ldomain - if(debug) write(fates_log(),*)'DGCN: gathering latc' - call MPI_Allgatherv(ldomain%latc,procinfo%ncells,MPI_REAL8,gclat,ncells_array,begg_array,MPI_REAL8,mpicom,mpierr) + if(debug) write(fates_log(),*)'DGCN: ncells_array: ' , ncells_array + if(debug) write(fates_log(),*)'DGCN: begg_array: ' , begg_array - if(debug) write(fates_log(),*)'DGCN: gathering lonc' - call MPI_Allgatherv(ldomain%lonc,procinfo%ncells,MPI_REAL8,gclon,ncells_array,begg_array,MPI_REAL8,mpicom,mpierr) + ! Gather the domain information together into the neighbor type + ! Note that MPI_Allgatherv is only gathering a subset of ldomain + if(debug) write(fates_log(),*)'DGCN: gathering latc' + call MPI_Allgatherv(ldomain%latc,procinfo%ncells,MPI_REAL8,gclat,ncells_array,begg_array,MPI_REAL8,mpicom,mpierr) - if (debug .and. iam .eq. 0) then - write(fates_log(),*)'DGCN: sum(gclat):, sum(gclon): ', sum(gclat), sum(gclon) - end if + if(debug) write(fates_log(),*)'DGCN: gathering lonc' + call MPI_Allgatherv(ldomain%lonc,procinfo%ncells,MPI_REAL8,gclon,ncells_array,begg_array,MPI_REAL8,mpicom,mpierr) - ! Save number of cells and begging index arrays to dispersal type - if(debug) write(fates_log(),*)'DGCN: save to seeds type' - if(debug) write(fates_log(),*)'DGCN: seeds ncells alloc: ', allocated(seeds%ncells_array) - if(debug) write(fates_log(),*)'DGCN: seeds begg alloc: ', allocated(seeds%begg_array) - seeds%ncells_array = ncells_array - seeds%begg_array = begg_array + if (debug .and. iam .eq. 0) then + write(fates_log(),*)'DGCN: sum(gclat):, sum(gclon): ', sum(gclat), sum(gclon) + end if - if (debug .and. iam .eq. 0) then - write(fates_log(),*)'DGCN: seeds%ncells_array: ', seeds%ncells_array - write(fates_log(),*)'DGCN: seeds%begg_array: ', seeds%begg_array - end if + ! Save number of cells and begging index arrays to dispersal type + if(debug) write(fates_log(),*)'DGCN: save to seeds type' + if(debug) write(fates_log(),*)'DGCN: seeds ncells alloc: ', allocated(seeds%ncells_array) + if(debug) write(fates_log(),*)'DGCN: seeds begg alloc: ', allocated(seeds%begg_array) + seeds%ncells_array = ncells_array + seeds%begg_array = begg_array - call t_stopf('fates-seed-init-allgather') + if (debug .and. iam .eq. 0) then + write(fates_log(),*)'DGCN: seeds%ncells_array: ', seeds%ncells_array + write(fates_log(),*)'DGCN: seeds%begg_array: ', seeds%begg_array + end if - call t_startf('fates-seed-init-decomp') + call t_stopf('fates-seed-init-allgather') - if(debug) write(fates_log(), *) 'DGCN: maxdist: ', EDPftvarcon_inst%seed_dispersal_max_dist + call t_startf('fates-seed-init-decomp') - ! Iterate through the grid cell indices and determine if any neighboring cells are in range - gc_loop: do gi = 1,numg-1 + if(debug) write(fates_log(), *) 'DGCN: maxdist: ', EDPftvarcon_inst%seed_dispersal_max_dist - ! Seach forward through all indices for neighbors to current grid cell index - neighbor_search: do gj = gi+1,numg + ! Iterate through the grid cell indices and determine if any neighboring cells are in range + gc_loop: do gi = 1,numg-1 - ! Determine distance to old grid cells to the current one - g2g_dist = GetNeighborDistance(gi,gj,gclat,gclon) + ! Seach forward through all indices for neighbors to current grid cell index + neighbor_search: do gj = gi+1,numg - if(debug) write(fates_log(), *) 'DGCN: gi,gj,g2g_dist: ', gi,gj,g2g_dist + ! Determine distance to old grid cells to the current one + g2g_dist = GetNeighborDistance(gi,gj,gclat,gclon) - ! - dist_check: if (any(EDPftvarcon_inst%seed_dispersal_max_dist .gt. g2g_dist)) then + if(debug) write(fates_log(), *) 'DGCN: gi,gj,g2g_dist: ', gi,gj,g2g_dist - ! Add neighbor index to current grid cell index list - allocate(current_neighbor) - current_neighbor%next_neighbor => null() + ! + dist_check: if (any(EDPftvarcon_inst%seed_dispersal_max_dist .gt. g2g_dist)) then - current_neighbor%gindex = gj + ! Add neighbor index to current grid cell index list + allocate(current_neighbor) + current_neighbor%next_neighbor => null() - current_neighbor%gc_dist = g2g_dist + current_neighbor%gindex = gj - allocate(current_neighbor%density_prob(numpft)) + current_neighbor%gc_dist = g2g_dist - do ipft = 1, numpft - call ProbabilityDensity(pdf, ipft, g2g_dist) - current_neighbor%density_prob(ipft) = pdf - end do + allocate(current_neighbor%density_prob(numpft)) - if (associated(neighbors(gi)%first_neighbor)) then - neighbors(gi)%last_neighbor%next_neighbor => current_neighbor - neighbors(gi)%last_neighbor => current_neighbor - else - neighbors(gi)%first_neighbor => current_neighbor - neighbors(gi)%last_neighbor => current_neighbor - end if + do ipft = 1, numpft + call ProbabilityDensity(pdf, ipft, g2g_dist) + current_neighbor%density_prob(ipft) = pdf + end do - neighbors(gi)%neighbor_count = neighbors(gi)%neighbor_count + 1 + if (associated(neighbors(gi)%first_neighbor)) then + neighbors(gi)%last_neighbor%next_neighbor => current_neighbor + neighbors(gi)%last_neighbor => current_neighbor + else + neighbors(gi)%first_neighbor => current_neighbor + neighbors(gi)%last_neighbor => current_neighbor + end if - ! Add current grid cell index to the neighbor's list as well - allocate(another_neighbor) - another_neighbor%next_neighbor => null() + neighbors(gi)%neighbor_count = neighbors(gi)%neighbor_count + 1 - another_neighbor%gindex = gi + ! Add current grid cell index to the neighbor's list as well + allocate(another_neighbor) + another_neighbor%next_neighbor => null() - another_neighbor%gc_dist = current_neighbor%gc_dist - allocate(another_neighbor%density_prob(numpft)) - do ipft = 1, numpft - another_neighbor%density_prob(ipft) = current_neighbor%density_prob(ipft) - end do + another_neighbor%gindex = gi - if (associated(neighbors(gj)%first_neighbor)) then - neighbors(gj)%last_neighbor%next_neighbor => another_neighbor - neighbors(gj)%last_neighbor => another_neighbor - else - neighbors(gj)%first_neighbor => another_neighbor - neighbors(gj)%last_neighbor => another_neighbor - end if + another_neighbor%gc_dist = current_neighbor%gc_dist + allocate(another_neighbor%density_prob(numpft)) + do ipft = 1, numpft + another_neighbor%density_prob(ipft) = current_neighbor%density_prob(ipft) + end do - neighbors(gj)%neighbor_count = neighbors(gj)%neighbor_count + 1 + if (associated(neighbors(gj)%first_neighbor)) then + neighbors(gj)%last_neighbor%next_neighbor => another_neighbor + neighbors(gj)%last_neighbor => another_neighbor + else + neighbors(gj)%first_neighbor => another_neighbor + neighbors(gj)%last_neighbor => another_neighbor + end if - end if dist_check - end do neighbor_search - end do gc_loop + neighbors(gj)%neighbor_count = neighbors(gj)%neighbor_count + 1 - ! Loop through the list and populate the grid cell index array for each gridcell - do gi = 1,numg + end if dist_check + end do neighbor_search + end do gc_loop - ! Start at the first neighbor of each neighborhood list - current_neighbor => neighbors(gi)%first_neighbor + ! Loop through the list and populate the grid cell index array for each gridcell + do gi = 1,numg - ! Allocate an array to hold the gridcell indices in each neighborhood - allocate(neighbors(gi)%neighbor_indices(neighbors(gi)%neighbor_count)) + ! Start at the first neighbor of each neighborhood list + current_neighbor => neighbors(gi)%first_neighbor - ! Walk through the neighborhood linked list and populate the array - ni = 1 - do while (associated(current_neighbor)) - neighbors(gi)%neighbor_indices(ni) = current_neighbor%gindex - ni = ni + 1 - current_neighbor => current_neighbor%next_neighbor - end do + ! Allocate an array to hold the gridcell indices in each neighborhood + allocate(neighbors(gi)%neighbor_indices(neighbors(gi)%neighbor_count)) - if (debug .and. iam .eq. 0) then - write(fates_log(), *) 'DGCN: g, lat, lon: ', gi, gclat(gi), gclon(gi) - write(fates_log(), *) 'DGCN: g, ncount: ', gi, neighbors(gi)%neighbor_count - do i = 1,neighbors(gi)%neighbor_count - write(fates_log(), *) 'DGCN: g, gilist: ', gi, neighbors(gi)%neighbor_indices(i) - end do - end if + ! Walk through the neighborhood linked list and populate the array + ni = 1 + do while (associated(current_neighbor)) + neighbors(gi)%neighbor_indices(ni) = current_neighbor%gindex + ni = ni + 1 + current_neighbor => current_neighbor%next_neighbor + end do - end do + if (debug .and. iam .eq. 0) then + write(fates_log(), *) 'DGCN: g, lat, lon: ', gi, gclat(gi), gclon(gi) + write(fates_log(), *) 'DGCN: g, ncount: ', gi, neighbors(gi)%neighbor_count + do i = 1,neighbors(gi)%neighbor_count + write(fates_log(), *) 'DGCN: g, gilist: ', gi, neighbors(gi)%neighbor_indices(i) + end do + end if + + end do - call t_stopf('fates-seed-init-decomp') + call t_stopf('fates-seed-init-decomp') end subroutine DetermineGridCellNeighbors From cb6b6772790cb64e85a3031d7e6a6fe333d9989b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 17 Nov 2023 07:39:12 -0800 Subject: [PATCH 193/250] Initializing two-stream error with the ignore flag --- biogeochem/FatesPatchMod.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index eae3e2fa7a..c2c425e91a 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -24,6 +24,7 @@ module FatesPatchMod use TwoStreamMLPEMod, only : twostream_type use FatesRadiationMemMod,only : num_swb use FatesRadiationMemMod,only : num_rad_stream_types + use FatesInterfaceTypesMod,only : hlm_hio_ignore_val use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) use shr_log_mod, only : errMsg => shr_log_errMsg @@ -381,8 +382,8 @@ subroutine NanValues(this) this%frac_burnt = nan this%tfc_ros = nan this%burnt_frac_litter(:) = nan - this%solve_err(:) = nan - this%consv_err(:) = nan + this%solve_err(:) = hlm_hio_ignore_val + this%consv_err(:) = hlm_hio_ignore_val end subroutine NanValues From bbb0b54851f59f0d2e4f9ecc76087eb352024eb5 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 17 Nov 2023 11:55:54 -0500 Subject: [PATCH 194/250] Fixed argument type declaration for the number of cwd pools, identified by Noel Keen --- biogeochem/FatesLitterMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/FatesLitterMod.F90 b/biogeochem/FatesLitterMod.F90 index e16cce69db..7d55dc9aab 100644 --- a/biogeochem/FatesLitterMod.F90 +++ b/biogeochem/FatesLitterMod.F90 @@ -447,7 +447,7 @@ subroutine adjust_SF_CWD_frac(dbh,ncwd,SF_val_CWD_frac,SF_val_CWD_frac_adj) !ARGUMENTS real(r8), intent(in) :: dbh !dbh of cohort [cm] - type(integer), intent(in) :: ncwd !number of cwd pools + integer, intent(in) :: ncwd !number of cwd pools real(r8), intent(in) :: SF_val_CWD_frac(:) !fates parameter specifying the !fraction of struct + sapw going !to each CWD class From 24760aa4e0c0d7100abc89b601151e3bd9c3f8c4 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 20 Nov 2023 18:03:22 -0800 Subject: [PATCH 195/250] Tweaks to area squeezing in two-stream --- radiation/FatesRadiationDriveMod.F90 | 7 +-- radiation/FatesTwoStreamInterfaceMod.F90 | 66 ++++++++---------------- 2 files changed, 25 insertions(+), 48 deletions(-) diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index bfe76a3221..c86ae5e353 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -1206,9 +1206,6 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) cpatch%ed_parsha_z(:,:,:) = 0._r8 cpatch%parprof_pft_dir_z(:,:,:) = 0._r8 cpatch%parprof_pft_dif_z(:,:,:) = 0._r8 - bc_out(s)%fsun_pa(ifp) = 0._r8 - bc_out(s)%laisun_pa(ifp) = 0._r8 - bc_out(s)%laisha_pa(ifp) = calc_areaindex(cpatch,'elai') if_notbareground:if(cpatch%nocomp_pft_label.ne.nocomp_bareground)then !only for veg patches ! do not do albedo calculations for bare ground patch in SP mode @@ -1216,6 +1213,10 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) ! ifp=1 is the first vegetated patch. ifp=ifp+1 + bc_out(s)%fsun_pa(ifp) = 0._r8 + bc_out(s)%laisun_pa(ifp) = 0._r8 + bc_out(s)%laisha_pa(ifp) = calc_areaindex(cpatch,'elai') + ! If there is no sun out, we have a trivial solution if_zenithflag: if(cpatch%solar_zenith_flag ) then diff --git a/radiation/FatesTwoStreamInterfaceMod.F90 b/radiation/FatesTwoStreamInterfaceMod.F90 index 3a52978ed8..f12f24834a 100644 --- a/radiation/FatesTwoStreamInterfaceMod.F90 +++ b/radiation/FatesTwoStreamInterfaceMod.F90 @@ -232,54 +232,30 @@ subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) end if ! If the layer is overfull, remove some from area from - ! the first element - ! THIS DOES HELP IMPROVE ENERGY CONSERVATION ON THE - ! ELEMENT VERSUS TOTAL AREA CHECK, BUT JUST PASSES - ! ERROR TO THE CHECK OF ENERGY CONSERVATION WITH - ! FATES COHORTS... THE SOLUTION IS TO HAVE - ! HIGHER PRECISION ON - if( (1._r8-canopy_frac(ican))<-area_err_thresh ) then - - !twostr%scelg(ican,1)%area = & - ! twostr%scelg(ican,1)%area + (1._r8-canopy_frac(ican)) - !new_area = twostr%scelg(ican,1)%area + (1._r8-canopy_frac(ican)) - area_ratio = (twostr%scelg(ican,1)%area + (1._r8-canopy_frac(ican)))/twostr%scelg(ican,1)%area - - twostr%scelg(ican,1)%area = twostr%scelg(ican,1)%area * area_ratio - twostr%scelg(ican,1)%lai = twostr%scelg(ican,1)%lai / area_ratio - twostr%scelg(ican,1)%sai = twostr%scelg(ican,1)%sai / area_ratio - - write(fates_log(),*) 'overfull areas' - twostr%cosz = coszen_pa(ifp) - call twostr%Dump(1,lat=site%lat,lon=site%lon) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + ! the first element that is 10x larger than the threshold + + if_overfull: if( (1._r8-canopy_frac(ican))<-area_err_thresh ) then + + do icol = 1,n_col(ican) + if(twostr%scelg(ican,icol)%area > 10._r8*(1._r8-canopy_frac(ican)))then + + area_ratio = (twostr%scelg(ican,icol)%area + (1._r8-canopy_frac(ican)))/twostr%scelg(ican,icol)%area + + twostr%scelg(ican,icol)%area = twostr%scelg(ican,icol)%area * area_ratio + twostr%scelg(ican,icol)%lai = twostr%scelg(ican,icol)%lai / area_ratio + twostr%scelg(ican,icol)%sai = twostr%scelg(ican,icol)%sai / area_ratio + exit if_overfull + end if + end do + + !write(fates_log(),*) 'overfull areas' + !twostr%cosz = coszen_pa(ifp) + ! call twostr%Dump(1,lat=site%lat,lon=site%lon) + ! call endrun(msg=errMsg(sourcefile, __LINE__)) + end if if_overfull end do - ! Go ahead an temporarily squeeze crown areas - - cohort => patch%tallest - do while (associated(cohort)) - ican = cohort%canopy_layer - icol = cohort%twostr_col - if( (cohort%c_area/patch%total_canopy_area - twostr%scelg(ican,icol)%area) > nearzero) then - - !v_ratio = twostr%scelg(ican,icol)%area / (cohort%c_area/patch%total_canopy_area) - !c_area_new = patch%total_canopy_area*twostr%scelg(ican,icol)%area - - area_ratio = (patch%total_canopy_area*twostr%scelg(ican,icol)%area) / cohort%c_area - - cohort%c_area = cohort%c_area * area_ratio - cohort%treelai = cohort%treelai / area_ratio - cohort%treesai = cohort%treesai / area_ratio - - end if - - cohort => cohort%shorter - enddo - - twostr%n_col(1:patch%ncl_p) = n_col(1:patch%ncl_p) ! Set up some non-element parameters From d35b9b1462f775e22d7fe608fb6f459effed1af3 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 21 Nov 2023 08:26:56 -0800 Subject: [PATCH 196/250] bug fix in area squeezing during two-stream --- radiation/FatesTwoStreamInterfaceMod.F90 | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/radiation/FatesTwoStreamInterfaceMod.F90 b/radiation/FatesTwoStreamInterfaceMod.F90 index f12f24834a..382d234d92 100644 --- a/radiation/FatesTwoStreamInterfaceMod.F90 +++ b/radiation/FatesTwoStreamInterfaceMod.F90 @@ -234,16 +234,14 @@ subroutine FatesConstructRadElements(site,fcansno_pa,coszen_pa) ! If the layer is overfull, remove some from area from ! the first element that is 10x larger than the threshold - if_overfull: if( (1._r8-canopy_frac(ican))<-area_err_thresh ) then - + if_overfull: if( (canopy_frac(ican)-1._r8)>area_err_thresh ) then do icol = 1,n_col(ican) - if(twostr%scelg(ican,icol)%area > 10._r8*(1._r8-canopy_frac(ican)))then - - area_ratio = (twostr%scelg(ican,icol)%area + (1._r8-canopy_frac(ican)))/twostr%scelg(ican,icol)%area - + if(twostr%scelg(ican,icol)%area > 10._r8*(canopy_frac(ican)-1._r8))then + area_ratio = (twostr%scelg(ican,icol)%area + (1._r8-canopy_frac(ican)))/twostr%scelg(ican,icol)%area twostr%scelg(ican,icol)%area = twostr%scelg(ican,icol)%area * area_ratio twostr%scelg(ican,icol)%lai = twostr%scelg(ican,icol)%lai / area_ratio twostr%scelg(ican,icol)%sai = twostr%scelg(ican,icol)%sai / area_ratio + canopy_frac(ican) = 1.0_r8 exit if_overfull end if end do From 31ed39b23b8c003499f0a1ab1ab666d2e76ebc0d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 22 Nov 2023 11:30:01 -0800 Subject: [PATCH 197/250] cleaned up canopy mask logic --- biogeochem/EDCanopyStructureMod.F90 | 17 +++++------------ 1 file changed, 5 insertions(+), 12 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index eca4b4a0ed..bada4ab8a2 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1563,7 +1563,7 @@ subroutine leaf_area_profile( currentSite ) ! area, ie not plants at all... ! ------------------------------------------------------------------------------ - if (currentPatch%total_canopy_area > nearzero ) then + if_any_canopy_area: if (currentPatch%total_canopy_area > nearzero ) then call UpdatePatchLAI(currentPatch) @@ -1709,18 +1709,11 @@ subroutine leaf_area_profile( currentSite ) currentPatch%canopy_mask(:,:) = 0 do cl = 1,currentPatch%NCL_p do ft = 1,numpft - do_leaflayer: do iv = 1, currentPatch%nrad(cl,ft) - if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then - currentPatch%canopy_mask(cl,ft) = 1 - exit do_leaflayer - else - exit do_leaflayer - endif - end do do_leaflayer !iv - enddo !ft - enddo ! loop over cl + if(currentPatch%canopy_area_profile(cl,ft,1) > nearzero) currentPatch%canopy_mask(cl,ft) = 1 + end do + end do - end if + end if if_any_canopy_area currentPatch => currentPatch%younger From 38c3f1f075a0f69e2f187b91bae4d9b6323896c9 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 28 Nov 2023 15:29:48 -0500 Subject: [PATCH 198/250] Added in code to preserve leaf to cohort scaling in norman mode, will be updated in subsequent PR --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 55 +++++++++++++++------- 1 file changed, 39 insertions(+), 16 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 47b61e8e48..b721a45b49 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -758,23 +758,46 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! a sum over layers. ! --------------------------------------------------------------- nv = currentCohort%nv - call ScaleLeafLayerFluxToCohort(nv, & !in - currentPatch%psn_z(cl,ft,1:nv), & !in - lmr_z(1:nv,ft,cl), & !in - rs_z(1:nv,ft,cl), & !in - !currentPatch%elai_profile(cl,ft,1:nv), & !in - cohort_layer_elai(1:nv), & !in - c13disc_z(cl, ft, 1:nv), & !in - currentCohort%c_area, & !in - currentCohort%n, & !in - bc_in(s)%rb_pa(ifp), & !in - maintresp_reduction_factor, & !in - currentCohort%g_sb_laweight, & !out - currentCohort%gpp_tstep, & !out - currentCohort%rdark, & !out - currentCohort%c13disc_clm, & !out - cohort_eleaf_area) !out + ! Temporary bypass to preserve B4B behavior + if(radiation_model.eq.norman_solver) then + + call ScaleLeafLayerFluxToCohort(nv, & !in + currentPatch%psn_z(cl,ft,1:nv), & !in + lmr_z(1:nv,ft,cl), & !in + rs_z(1:nv,ft,cl), & !in + currentPatch%elai_profile(cl,ft,1:nv), & !in + c13disc_z(cl, ft, 1:nv), & !in + currentCohort%c_area, & !in + currentCohort%n, & !in + bc_in(s)%rb_pa(ifp), & !in + maintresp_reduction_factor, & !in + currentCohort%g_sb_laweight, & !out + currentCohort%gpp_tstep, & !out + currentCohort%rdark, & !out + currentCohort%c13disc_clm, & !out + cohort_eleaf_area) !out + + else + + call ScaleLeafLayerFluxToCohort(nv, & !in + currentPatch%psn_z(cl,ft,1:nv), & !in + lmr_z(1:nv,ft,cl), & !in + rs_z(1:nv,ft,cl), & !in + cohort_layer_elai(1:nv), & !in + c13disc_z(cl, ft, 1:nv), & !in + currentCohort%c_area, & !in + currentCohort%n, & !in + bc_in(s)%rb_pa(ifp), & !in + maintresp_reduction_factor, & !in + currentCohort%g_sb_laweight, & !out + currentCohort%gpp_tstep, & !out + currentCohort%rdark, & !out + currentCohort%c13disc_clm, & !out + cohort_eleaf_area) !out + end if + + ! Net Uptake does not need to be scaled, just transfer directly currentCohort%ts_net_uptake(1:nv) = anet_av_z(1:nv,ft,cl) * umolC_to_kgC From 3c361de0d3b5442cfede0f16d74a81e5e15bf258 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 29 Nov 2023 10:40:46 -0800 Subject: [PATCH 199/250] add graceful failure if the HLM state name is not found in the fates list --- biogeochem/FatesLandUseChangeMod.F90 | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index adb92bcebc..48eea8f77f 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -125,6 +125,14 @@ function GetLUCategoryFromStateName(this, state_name) result(landuse_category) landuse_category = this%landuse_categories(findloc(this%state_names,state_name,dim=1)) + ! Check that the result from the landuse_categories is not zero, which indicates that no + ! match was found. + if (landuse_category .eq. 0) then + write(fates_log(),*) 'The input state name from the HLM does not match the FATES landuse state name options' + write(fates_log(),*) 'input state name: ', state_name + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end function GetLUCategoryFromStateName !---------------------------------------------------------------------------------------------------- From cde7e7d4c2650cb94ffdc15f6a852c183574b108 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 29 Nov 2023 10:45:42 -0800 Subject: [PATCH 200/250] correct findloc check for landuse state name check --- biogeochem/FatesLandUseChangeMod.F90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index 48eea8f77f..b7bf893b6d 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -122,15 +122,19 @@ function GetLUCategoryFromStateName(this, state_name) result(landuse_category) class(luh2_fates_lutype_map) :: this character(len=5), intent(in) :: state_name integer :: landuse_category + integer :: index - landuse_category = this%landuse_categories(findloc(this%state_names,state_name,dim=1)) + index = findloc(this%state_names,state_name,dim=1) ! Check that the result from the landuse_categories is not zero, which indicates that no ! match was found. - if (landuse_category .eq. 0) then + if (index .eq. 0) then write(fates_log(),*) 'The input state name from the HLM does not match the FATES landuse state name options' write(fates_log(),*) 'input state name: ', state_name + write(fates_log(),*) 'state name options: ', this%state_names call endrun(msg=errMsg(sourcefile, __LINE__)) + else + landuse_category = this%landuse_categories(index) end if end function GetLUCategoryFromStateName From 1cf7bca3651efc7aaf16416ee483fb810221a1e4 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 29 Nov 2023 22:35:50 -0700 Subject: [PATCH 201/250] fix merge that snuck in old anthro disturbance label --- main/FatesHistoryInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 605a446522..c985b427f3 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3161,7 +3161,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_npp_si_pft(io_si, ft) = hio_npp_si_pft(io_si, ft) + & ccohort%npp_acc_hold * n_perm2 / days_per_year / sec_per_day - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_gpp_sec_si_pft(io_si, ft) = hio_gpp_sec_si_pft(io_si, ft) + & ccohort%gpp_acc_hold * n_perm2 / days_per_year / sec_per_day hio_npp_sec_si_pft(io_si, ft) = hio_npp_sec_si_pft(io_si, ft) + & From ea24aa8edf707e7547be1c136dfce368b94a475c Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 29 Nov 2023 23:23:58 -0700 Subject: [PATCH 202/250] rename the parameter patch file to reflect the actual next tag --- .../{api27.0.0_080923_luh2.xml => api32.0.0_113023_luh2.xml} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename parameter_files/archive/{api27.0.0_080923_luh2.xml => api32.0.0_113023_luh2.xml} (100%) diff --git a/parameter_files/archive/api27.0.0_080923_luh2.xml b/parameter_files/archive/api32.0.0_113023_luh2.xml similarity index 100% rename from parameter_files/archive/api27.0.0_080923_luh2.xml rename to parameter_files/archive/api32.0.0_113023_luh2.xml From 46ecf390c14cccf1b1518f00791ea8213862bafd Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 30 Nov 2023 16:57:56 -0500 Subject: [PATCH 203/250] altnerate reverted form of leaf layer calculation --- biogeochem/FatesAllometryMod.F90 | 81 ++++++++++++++++++++++++++++++-- 1 file changed, 77 insertions(+), 4 deletions(-) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index 5f2ff04da6..a479841cbb 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -92,6 +92,7 @@ module FatesAllometryMod use FatesConstantsMod, only : calloc_abs_error use FatesConstantsMod, only : fates_unset_r8 use FatesConstantsMod, only : itrue + use FatesConstantsMod, only : nearzero use shr_log_mod , only : errMsg => shr_log_errMsg use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun @@ -2591,8 +2592,7 @@ end subroutine ForceDBH ! ========================================================================= subroutine VegAreaLayer(tree_lai,tree_sai,tree_height,iv,nv,pft,snow_depth, & - vai_top,vai_bot, & - elai_layer,esai_layer,tlai_layer,tsai_layer) + vai_top,vai_bot, elai_layer,esai_layer,tlai_layer,tsai_layer) ! ----------------------------------------------------------------------------------- ! This routine returns the exposed leaf and stem areas (m2 of leaf and stem) per m2 of @@ -2621,13 +2621,86 @@ subroutine VegAreaLayer(tree_lai,tree_sai,tree_height,iv,nv,pft,snow_depth, & real(r8) :: layer_top_height ! Physical height of the layer top relative to ground [m] real(r8) :: layer_bot_height ! Physical height of the layer bottom relative to ground [m] real(r8) :: tlai,tsai ! temporary total area indices [m2/m2] + real(r8) :: fleaf ! fraction of biomass in layer that is leaf + real(r8) :: remainder ! old-method: remainder of biomass in last bin integer, parameter :: layer_height_const_depth = 1 ! constant physical depth assumption integer, parameter :: layer_height_const_lad = 2 ! constant leaf area depth assumption integer, parameter :: layer_height_method = layer_height_const_depth + + + logical, parameter :: old_method = .true. + + + if(old_method) then + + if( (tree_lai+tree_sai) > nearzero)then + + ! lai = tree_lai * currentCohort%c_area/currentPatch%total_canopy_area + ! sai = tree_sai * currentCohort%c_area/currentPatch%total_canopy_area + + ! See issue: https://github.com/NGEET/fates/issues/899 + ! fleaf = currentCohort%treelai / (currentCohort%treelai + currentCohort%treesai) + fleaf = tree_lai / (tree_lai+tree_sai) + else + fleaf = 0._r8 + endif + + if(iv==0)then ! Whole plant (not just specific layer) + + layer_top_height = tree_height + layer_bot_height = tree_height - ( tree_height * prt_params%crown_depth_frac(pft) ) + + else + + layer_top_height = tree_height - ( real(iv-1,r8)/nv * tree_height * & + prt_params%crown_depth_frac(pft) ) + + layer_bot_height = tree_height - ( real(iv,r8)/nv * tree_height * & + prt_params%crown_depth_frac(pft) ) + end if + fraction_exposed = 1.0_r8 + if(snow_depth > layer_top_height)then + fraction_exposed = 0._r8 + endif + if(snow_depth < layer_bot_height)then + fraction_exposed = 1._r8 + endif + if(snow_depth >= layer_bot_height .and. & + snow_depth <= layer_top_height) then !only partly hidden... + fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(snow_depth -layer_bot_height)/ & + (layer_top_height-layer_bot_height )))) + endif + + if(iv==0) then + remainder = tree_lai+tree_sai + elseif(iv==nv) then + remainder = (tree_lai + tree_sai) - & + (dlower_vai(iv) - dinc_vai(iv)) + if(remainder > dinc_vai(iv) )then + write(fates_log(), *)'ED: issue with remainder', & + tree_lai,tree_sai,dinc_vai(iv), & + nv,remainder + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + else + remainder = dinc_vai(iv) + end if + + if(present(tlai_layer)) tlai_layer = remainder * fleaf !* currentCohort%c_area/currentPatch%total_canopy_area + if(present(tsai_layer)) tsai_layer = remainder * (1._r8-fleaf) !* currentCohort%c_area/currentPatch%total_canopy_area + elai_layer = fraction_exposed * remainder * fleaf + esai_layer = fraction_exposed * remainder * (1._r8-fleaf) + + + return + + end if + + tree_vai = tree_lai + tree_sai - if(tree_vai>0._r8)then + if_any_vai: if(tree_vai>0._r8)then if(iv==0)then vai_top = 0.0 @@ -2686,7 +2759,7 @@ subroutine VegAreaLayer(tree_lai,tree_sai,tree_height,iv,nv,pft,snow_depth, & vai_bot = 0._r8 vai_top = 0._r8 - end if + end if if_any_vai return From 624293b8fa26c90eb49829e1d6d054306fe4ee0b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 1 Dec 2023 13:48:20 -0700 Subject: [PATCH 204/250] testing out b4b corrections --- radiation/FatesRadiationDriveMod.F90 | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index c86ae5e353..ede4eeb65f 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -140,20 +140,28 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) ! Note (RGK-MLO): Investigate twilight mechanics for ! non-zero diffuse radiation when cosz<=0 - bc_out(s)%albd_parb(ifp,:) = 1._r8 - bc_out(s)%albi_parb(ifp,:) = 1._r8 - bc_out(s)%fabi_parb(ifp,:) = 0._r8 - bc_out(s)%fabd_parb(ifp,:) = 0._r8 - bc_out(s)%ftdd_parb(ifp,:) = 0._r8 - bc_out(s)%ftid_parb(ifp,:) = 0._r8 - bc_out(s)%ftii_parb(ifp,:) = 0._r8 + ! Temporarily turn off to preserve b4b + + !!bc_out(s)%albd_parb(ifp,:) = 1._r8 + !!bc_out(s)%albi_parb(ifp,:) = 1._r8 + !!bc_out(s)%fabi_parb(ifp,:) = 0._r8 + !!bc_out(s)%fabd_parb(ifp,:) = 0._r8 + !!bc_out(s)%ftdd_parb(ifp,:) = 0._r8 + !!bc_out(s)%ftid_parb(ifp,:) = 0._r8 + !!bc_out(s)%ftii_parb(ifp,:) = 0._r8 else + bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%fabd_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM + bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM + bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM + if_nrad: if (maxval(currentPatch%nrad(1,:))==0)then ! there are no leaf layers in this patch. it is effectively bare ground. - ! no radiation is absorbed - currentPatch%radiation_error = 0.0_r8 do ib = 1,hlm_numSWb From 5f4a8b68338dc6dc7dbd815717eccfb1f2ee7065 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 1 Dec 2023 13:50:38 -0700 Subject: [PATCH 205/250] Reverted incorrect nscalar --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index b721a45b49..ce714ea0a4 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -545,9 +545,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) kn = decay_coeff_kn(ft,currentCohort%vcmax25top) ! Scale for leaf nitrogen profile - !nscaler = exp(-kn * cumulative_lai) - - nscaler = 1.0_r8 + nscaler = exp(-kn * cumulative_lai) ! Leaf maintenance respiration to match the base rate used in CN ! but with the new temperature functions for C3 and C4 plants. From b88f636b49b4bb3037aa80a6edc3e85eea0f78d7 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 4 Dec 2023 13:30:30 -0500 Subject: [PATCH 206/250] More b4b attempts at two-stream --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 195 ++++++++++++++------- 1 file changed, 130 insertions(+), 65 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index ce714ea0a4..ab1d01e014 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -114,7 +114,8 @@ module FATESPlantRespPhotosynthMod ! is to use anet integer, parameter :: net_assim_model = 1 integer, parameter :: gross_assim_model = 2 - + + logical, parameter :: preserve_b4b = .true. contains @@ -271,12 +272,12 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: rd_abs_leaf, rb_abs_leaf, r_abs_stem, r_abs_snow, rb_abs, rd_abs real(r8) :: fsun real(r8) :: par_per_sunla, par_per_shala ! PAR per sunlit and shaded leaf area [W/m2 leaf] - real(r8),dimension(50) :: cohort_vaitop - real(r8),dimension(50) :: cohort_vaibot - real(r8),dimension(50) :: cohort_layer_elai - real(r8),dimension(50) :: cohort_layer_esai - real(r8),dimension(50) :: cohort_layer_tlai - real(r8),dimension(50) :: cohort_layer_tsai + real(r8),dimension(75) :: cohort_vaitop + real(r8),dimension(75) :: cohort_vaibot + real(r8),dimension(75) :: cohort_layer_elai + real(r8),dimension(75) :: cohort_layer_esai + real(r8),dimension(75) :: cohort_layer_tlai + real(r8),dimension(75) :: cohort_layer_tsai real(r8) :: cohort_elai real(r8) :: cohort_esai real(r8) :: elai_layer @@ -491,7 +492,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) rate_mask_if: if ( .not.rate_mask_z(iv,ft,cl) .or. & (hlm_use_planthydro.eq.itrue) .or. & (radiation_model .eq. twostr_solver ) .or. & - (radiation_model .eq. norman_solver ) .or. & + !(radiation_model .eq. norman_solver ) .or. & (nleafage > 1) .or. & (hlm_parteh_mode .ne. prt_carbon_allom_hyp ) ) then @@ -614,36 +615,44 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) laisun = currentPatch%elai_profile(cl,ft,iv)*currentPatch%f_sun(cl,ft,iv) laisha = currentPatch%elai_profile(cl,ft,iv)*(1._r8-currentPatch%f_sun(cl,ft,iv)) - - if(((laisun*currentPatch%canopy_area_profile(cl,ft,iv)) >nearzero) .and. & - (currentPatch%ed_parsun_z(cl,ft,iv)>nearzero)) then - - ! laisun: m2 of exposed leaf, per m2 of crown. If this is the lowest layer - ! for the pft/canopy group, than the m2 per crown is probably not - ! as large as the layer above. - ! ed_parsun_z: this is W/m2 ground times the canopy_area_profile, which is the - ! fraction of m2 of ground in the crown per m2 ground in the - ! total canopy area. This results in W/m2 of total canopy. + + if_nonnzero_lai: if((laisun+laisha)>0._r8) then + + if(((laisun*currentPatch%canopy_area_profile(cl,ft,iv)) >0.0000000001_r8)) then ! .and. & + !(currentPatch%ed_parsun_z(cl,ft,iv)>nearzero)) then + + ! laisun: m2 of exposed leaf, per m2 of crown. If this is the lowest layer + ! for the pft/canopy group, than the m2 per crown is probably not + ! as large as the layer above. + ! ed_parsun_z: this is W/m2 ground times the canopy_area_profile, which is the + ! fraction of m2 of ground in the crown per m2 ground in the + ! total canopy area. This results in W/m2 of total canopy. + + par_per_sunla = currentPatch%ed_parsun_z(cl,ft,iv) / & + (laisun*currentPatch%canopy_area_profile(cl,ft,iv)) + else + par_per_sunla = 0._r8 + end if - par_per_sunla = currentPatch%ed_parsun_z(cl,ft,iv) / & - (laisun*currentPatch%canopy_area_profile(cl,ft,iv)) + !!if(((laisha*currentPatch%canopy_area_profile(cl,ft,iv)) >nearzero) .and. & + !! (currentPatch%ed_parsha_z(cl,ft,iv)>nearzero)) then - else - par_per_sunla = 0._r8 - end if - - if(((laisha*currentPatch%canopy_area_profile(cl,ft,iv)) >nearzero) .and. & - (currentPatch%ed_parsha_z(cl,ft,iv)>nearzero)) then par_per_shala = currentPatch%ed_parsha_z(cl,ft,iv) / & (laisha*currentPatch%canopy_area_profile(cl,ft,iv)) + elai_layer = currentPatch%elai_profile(cl,ft,iv) + else + + par_per_sunla = 0._r8 par_per_shala = 0._r8 - end if - + elai_layer = 0._r8 + + end if if_nonnzero_lai + fsun = currentPatch%f_sun(cl,ft,iv) - elai_layer = currentPatch%elai_profile(cl,ft,iv) - else + + else ! Two-stream if(cohort_layer_elai(iv) > nearzero .and. currentPatch%solar_zenith_flag) then @@ -1027,39 +1036,94 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! The value here was integrated over each cohort x leaf layer ! and was weighted by m2 of effective leaf area for each layer - if(patch_la>nearzero) then - - ! Normalize the leaf-area weighted canopy conductance - ! The denominator is the total effective leaf area in the canopy, - ! units of [m/s]*[m2] / [m2] = [m/s] - !g_sb_leaves = g_sb_leaves / (elai*currentPatch%total_canopy_area) + preserve_b4b: if(preserve_b4b) then - g_sb_leaves = g_sb_leaves / max(0.1_r8*currentPatch%total_canopy_area,patch_la) + patch_la = patch_la / currentPatch%total_canopy_area - if( g_sb_leaves > (1._r8/rsmax0) ) then - - ! Combined mean leaf resistance is the inverse of mean leaf conductance - r_sb_leaves = 1.0_r8/g_sb_leaves - - if (r_sb_leavestiny(patch_la)) then + + elai = calc_areaindex(currentPatch,'elai') + g_sb_leaves = g_sb_leaves / (elai*currentPatch%total_canopy_area) + + if( g_sb_leaves > (1._r8/rsmax0) ) then + + ! Combined mean leaf resistance is the inverse of mean leaf conductance + r_sb_leaves = 1.0_r8/g_sb_leaves + + if (r_sb_leavesnearzero) then + + ! Normalize the leaf-area weighted canopy conductance + ! The denominator is the total effective leaf area in the canopy, + ! units of [m/s]*[m2] / [m2] = [m/s] + + g_sb_leaves = g_sb_leaves / max(0.1_r8*currentPatch%total_canopy_area,patch_la) + + if( g_sb_leaves > (1._r8/rsmax0) ) then + + ! Combined mean leaf resistance is the inverse of mean leaf conductance + r_sb_leaves = 1.0_r8/g_sb_leaves + + if (r_sb_leaves currentPatch%younger end do @@ -1335,7 +1400,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! Is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) - if_leafarea: if ( elai_lsl > 0._r8 ) then + if_leafarea: if (elai_lsl > 0._r8 ) then !Loop aroun shaded and unshaded leaves psn_out = 0._r8 ! psn is accumulated across sun and shaded leaves. From bf99977343888576d66b138d348d219427206d94 Mon Sep 17 00:00:00 2001 From: Marcos Longo Date: Wed, 6 Dec 2023 14:55:02 -0800 Subject: [PATCH 207/250] Added crown area by size class and PFT to the output. --- main/FatesHistoryInterfaceMod.F90 | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index c530656bda..63475392f6 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -277,6 +277,9 @@ module FatesHistoryInterfaceMod ! Size-class x PFT LAI states integer :: ih_lai_canopy_si_scpf integer :: ih_lai_understory_si_scpf + ! Size-class x PFT LAI states + integer :: ih_crownarea_canopy_si_scpf + integer :: ih_crownarea_understory_si_scpf integer :: ih_totvegc_scpf integer :: ih_leafc_scpf @@ -2318,6 +2321,8 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_bleaf_understory_si_scpf => this%hvars(ih_bleaf_understory_si_scpf)%r82d, & hio_lai_canopy_si_scpf => this%hvars(ih_lai_canopy_si_scpf)%r82d, & hio_lai_understory_si_scpf => this%hvars(ih_lai_understory_si_scpf)%r82d, & + hio_crownarea_canopy_si_scpf => this%hvars(ih_crownarea_canopy_si_scpf)%r82d, & + hio_crownarea_understory_si_scpf => this%hvars(ih_crownarea_understory_si_scpf)%r82d, & hio_mortality_canopy_si_scpf => this%hvars(ih_mortality_canopy_si_scpf)%r82d, & hio_mortality_canopy_secondary_si_scls => this%hvars(ih_mortality_canopy_secondary_si_scls)%r82d, & hio_mortality_understory_si_scpf => this%hvars(ih_mortality_understory_si_scpf)%r82d, & @@ -3359,6 +3364,9 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) leaf_m * ccohort%n / m2_per_ha hio_lai_canopy_si_scpf(io_si,scpf) = hio_lai_canopy_si_scpf(io_si,scpf) + & ccohort%treelai*ccohort%c_area * AREA_INV + hio_crownarea_canopy_si_scpf(io_si,scpf) = hio_crownarea_canopy_si_scpf(io_si,scpf) + & + ccohort%c_area * AREA_INV + hio_canopy_biomass_si(io_si) = hio_canopy_biomass_si(io_si) + n_perm2 * total_m @@ -3502,6 +3510,8 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) n_perm2 * total_m hio_lai_understory_si_scpf(io_si,scpf) = hio_lai_understory_si_scpf(io_si,scpf) + & ccohort%treelai*ccohort%c_area * AREA_INV + hio_crownarea_understory_si_scpf(io_si,scpf) = hio_crownarea_understory_si_scpf(io_si,scpf) + & + ccohort%c_area * AREA_INV !hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & ! (ccohort%bmort + ccohort%hmort + ccohort%cmort + @@ -7227,6 +7237,13 @@ subroutine define_history_vars(this, initialize_variables) ivar=ivar, initialize=initialize_variables, & index = ih_lai_canopy_si_scpf ) + call this%set_history_var(vname='FATES_CROWNAREA_CANOPY_SZPF', & + units = 'm2 m-2', & + long='Total crown area of canopy plants by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_crownarea_canopy_si_scpf ) + call this%set_history_var(vname='FATES_NPLANT_CANOPY_SZPF', units = 'm-2', & long='number of canopy plants by size/pft per m2', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & @@ -7262,6 +7279,13 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_lai_understory_si_scpf ) + call this%set_history_var(vname='FATES_CROWNAREA_USTORY_SZPF', & + units = 'm2 m-2', & + long='Total crown area of understory plants by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_crownarea_understory_si_scpf ) + call this%set_history_var(vname='FATES_NPLANT_USTORY_SZPF', & units = 'm-2', & long='density of understory plants by pft/size in number of plants per m2', & From 0ab1f809956dfff79967b782c717d0dd6b024547 Mon Sep 17 00:00:00 2001 From: Marcos Longo Date: Wed, 6 Dec 2023 14:56:34 -0800 Subject: [PATCH 208/250] Fix units for FATES_CROWNAREA_CANOPY_SZ and FATES_CROWNAREA_USTORY_SZ. This addresses issue #1126 --- main/FatesHistoryInterfaceMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 63475392f6..075624f51b 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3392,7 +3392,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_trimming_canopy_si_scls(io_si,scls) = hio_trimming_canopy_si_scls(io_si,scls) + & ccohort%n * ccohort%canopy_trim / m2_per_ha hio_crown_area_canopy_si_scls(io_si,scls) = hio_crown_area_canopy_si_scls(io_si,scls) + & - ccohort%c_area / m2_per_ha + ccohort%c_area * AREA_INV hio_gpp_canopy_si_scpf(io_si,scpf) = hio_gpp_canopy_si_scpf(io_si,scpf) + & n_perm2*ccohort%gpp_acc_hold / days_per_year / sec_per_day hio_ar_canopy_si_scpf(io_si,scpf) = hio_ar_canopy_si_scpf(io_si,scpf) + & @@ -3543,7 +3543,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_trimming_understory_si_scls(io_si,scls) = hio_trimming_understory_si_scls(io_si,scls) + & ccohort%n * ccohort%canopy_trim / m2_per_ha hio_crown_area_understory_si_scls(io_si,scls) = hio_crown_area_understory_si_scls(io_si,scls) + & - ccohort%c_area / m2_per_ha + ccohort%c_area * AREA_INV hio_gpp_understory_si_scpf(io_si,scpf) = hio_gpp_understory_si_scpf(io_si,scpf) + & n_perm2*ccohort%gpp_acc_hold / days_per_year / sec_per_day hio_ar_understory_si_scpf(io_si,scpf) = hio_ar_understory_si_scpf(io_si,scpf) + & From 3c0051e176a083bd1b3af03f7c45f9fb03018371 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 7 Dec 2023 12:10:20 -0700 Subject: [PATCH 209/250] debugging logic ends --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 71 +++++++++++----------- 1 file changed, 35 insertions(+), 36 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index ab1d01e014..773a1345c8 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -341,7 +341,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) - if(currentpatch%nocomp_pft_label.ne.nocomp_bareground)then + if_notbare: if(currentpatch%nocomp_pft_label.ne.nocomp_bareground)then ifp = ifp+1 NCL_p = currentPatch%NCL_p @@ -492,7 +492,6 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) rate_mask_if: if ( .not.rate_mask_z(iv,ft,cl) .or. & (hlm_use_planthydro.eq.itrue) .or. & (radiation_model .eq. twostr_solver ) .or. & - !(radiation_model .eq. norman_solver ) .or. & (nleafage > 1) .or. & (hlm_parteh_mode .ne. prt_carbon_allom_hyp ) ) then @@ -838,12 +837,12 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) fnrt_c = currentCohort%prt%GetState(fnrt_organ, carbon12_element) if (hlm_use_tree_damage .eq. itrue) then - + ! Crown damage currenly only reduces the aboveground portion of ! sapwood. Therefore we calculate the aboveground and the belowground portion ! sapwood for use in stem respiration. call GetCrownReduction(currentCohort%crowndamage, crown_reduction) - + else crown_reduction = 0.0_r8 end if @@ -1036,8 +1035,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! The value here was integrated over each cohort x leaf layer ! and was weighted by m2 of effective leaf area for each layer - preserve_b4b: if(preserve_b4b) then - + if_preserve_b4b: if(preserve_b4b) then + patch_la = patch_la / currentPatch%total_canopy_area if_zerolai1: if(patch_la>tiny(patch_la)) then @@ -1078,7 +1077,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! is what is used in the field usually, so we track that form currentPatch%c_stomata = cf / r_stomata - else + else !if_zerolai1 ! But this will prevent it from using an unintialized value bc_out(s)%rssun_pa(ifp) = rsmax0 @@ -1124,38 +1123,38 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) end if - ! This will be multiplied by scaled by effective LAI in the host model - ! when it comes time to calculate a flux rate per unit ground - bc_out(s)%rssun_pa(ifp) = r_stomata - bc_out(s)%rssha_pa(ifp) = r_stomata - - ! This value is used for diagnostics, the molar form of conductance - ! is what is used in the field usually, so we track that form - currentPatch%c_stomata = cf / r_stomata - - else - - ! But this will prevent it from using an unintialized value - bc_out(s)%rssun_pa(ifp) = rsmax0 - bc_out(s)%rssha_pa(ifp) = rsmax0 - - ! This value is used for diagnostics, the molar form of conductance - ! is what is used in the field usually, so we track that form - currentPatch%c_stomata = cf / rsmax0 - - end if if_zerolai + ! This will be multiplied by scaled by effective LAI in the host model + ! when it comes time to calculate a flux rate per unit ground + bc_out(s)%rssun_pa(ifp) = r_stomata + bc_out(s)%rssha_pa(ifp) = r_stomata + + ! This value is used for diagnostics, the molar form of conductance + ! is what is used in the field usually, so we track that form + currentPatch%c_stomata = cf / r_stomata + + else ! if_zerolai - end if preserve_b4b + ! But this will prevent it from using an unintialized value + bc_out(s)%rssun_pa(ifp) = rsmax0 + bc_out(s)%rssha_pa(ifp) = rsmax0 + + ! This value is used for diagnostics, the molar form of conductance + ! is what is used in the field usually, so we track that form + currentPatch%c_stomata = cf / rsmax0 + + end if if_zerolai + + end if if_preserve_b4b + + ! This value is used for diagnostics, the molar form of conductance + ! is what is used in the field usually, so we track that form + currentPatch%c_lblayer = cf / bc_in(s)%rb_pa(ifp) - ! This value is used for diagnostics, the molar form of conductance - ! is what is used in the field usually, so we track that form - currentPatch%c_lblayer = cf / bc_in(s)%rb_pa(ifp) - - end if ! not bare ground patch - currentPatch => currentPatch%younger - end do - + end if if_filter2 ! not bare ground patch + currentPatch => currentPatch%younger + end do + deallocate(rootfr_ft) end do !site loop From c71dadb88ece75d43463bb13974974aa381df95c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 7 Dec 2023 21:46:02 -0700 Subject: [PATCH 210/250] more b4b attempts at two-stream --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 773a1345c8..63dfbf3d36 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -282,7 +282,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: cohort_esai real(r8) :: elai_layer real(r8) :: laisun,laisha - + real(r8) :: elai ! ----------------------------------------------------------------------------------- ! Keeping these two definitions in case they need to be added later ! @@ -414,6 +414,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! ------------------------------------------------------------------------ rate_mask_z(:,1:numpft,:) = .false. + if(currentPatch%countcohorts > 0.0)then currentCohort => currentPatch%tallest do_cohort_drive: do while (associated(currentCohort)) ! Cohort loop @@ -1031,6 +1032,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) currentCohort => currentCohort%shorter enddo do_cohort_drive + end if + ! Normalize canopy total conductance by the effective LAI ! The value here was integrated over each cohort x leaf layer ! and was weighted by m2 of effective leaf area for each layer @@ -1149,14 +1152,16 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! This value is used for diagnostics, the molar form of conductance ! is what is used in the field usually, so we track that form currentPatch%c_lblayer = cf / bc_in(s)%rb_pa(ifp) - - + end if if_filter2 ! not bare ground patch - currentPatch => currentPatch%younger - end do - - deallocate(rootfr_ft) + + end if if_notbare + currentPatch => currentPatch%younger + end do + + deallocate(rootfr_ft) + end do !site loop end associate From 1d641074a4b15a30b60a8d8b82ef2a599c2472fa Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 8 Dec 2023 11:18:03 -0500 Subject: [PATCH 211/250] making switches in b4b check consistent --- biogeochem/FatesAllometryMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index a479841cbb..07e6c4c836 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -2628,10 +2628,10 @@ subroutine VegAreaLayer(tree_lai,tree_sai,tree_height,iv,nv,pft,snow_depth, & integer, parameter :: layer_height_method = layer_height_const_depth - logical, parameter :: old_method = .true. + logical, parameter :: preserve_b4b = .true. - if(old_method) then + if_preserve_b4b: if(preserve_b4b) then if( (tree_lai+tree_sai) > nearzero)then @@ -2695,7 +2695,7 @@ subroutine VegAreaLayer(tree_lai,tree_sai,tree_height,iv,nv,pft,snow_depth, & return - end if + end if if_preserve_b4b tree_vai = tree_lai + tree_sai From d4ac49bcb40a9d46937ba71f4f5cc20fb7e64d7e Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 8 Dec 2023 09:55:31 -0700 Subject: [PATCH 212/250] reverting history code in two-stream to match main for b4b --- main/FatesHistoryInterfaceMod.F90 | 1626 ++++++++++++----------------- 1 file changed, 675 insertions(+), 951 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 9ddca1bf27..c530656bda 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -27,7 +27,6 @@ module FatesHistoryInterfaceMod use EDTypesMod , only : num_vegtemp_mem use EDTypesMod , only : site_massbal_type use PRTGenericMod , only : element_list - use FatesIOVariableKindMod , only : upfreq_hifr_multi use FatesConstantsMod , only : N_DIST_TYPES use FatesConstantsMod , only : dtype_ifall use FatesConstantsMod , only : dtype_ifire @@ -47,9 +46,6 @@ module FatesHistoryInterfaceMod use FatesInterfaceTypesMod , only : hlm_parteh_mode use EDParamsMod , only : ED_val_comp_excln use EDParamsMod , only : ED_val_phen_coldtemp - use EDParamsMod , only : nlevleaf - use EDParamsMod , only : ED_val_history_height_bin_edges - use EDParamsMod , only : ED_val_history_ageclass_bin_edges use FatesInterfaceTypesMod , only : nlevsclass, nlevage use FatesInterfaceTypesMod , only : nlevheight use FatesInterfaceTypesMod , only : bc_in_type @@ -58,9 +54,6 @@ module FatesHistoryInterfaceMod use FatesInterfaceTypesMod , only : nlevcoage use FatesInterfaceTypesMod , only : hlm_use_nocomp use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog - use FatesRadiationMemMod , only : ivis,inir - use FatesInterfaceTypesMod , only : hio_include_hifr_multi - use FatesAllometryMod , only : CrownDepth use FatesAllometryMod , only : bstore_allom use FatesAllometryMod , only : set_root_fraction @@ -100,7 +93,6 @@ module FatesHistoryInterfaceMod use PRTGenericMod , only : prt_carbon_allom_hyp use PRTAllometricCNPMod , only : stoich_max,stoich_growth_min use FatesSizeAgeTypeIndicesMod, only : get_layersizetype_class_index - use FatesSizeAgeTypeIndicesMod, only : get_age_class_index implicit none private ! By default everything is private @@ -355,15 +347,7 @@ module FatesHistoryInterfaceMod integer :: ih_c_stomata_si integer :: ih_c_lblayer_si integer :: ih_rad_error_si - integer :: ih_vis_solve_err_si - integer :: ih_nir_solve_err_si - integer :: ih_vis_consv_err_si - integer :: ih_nir_consv_err_si - integer :: ih_vis_solve_err_age_si - integer :: ih_nir_solve_err_age_si - integer :: ih_vis_consv_err_age_si - integer :: ih_nir_consv_err_age_si - + integer :: ih_fire_c_to_atm_si @@ -593,7 +577,6 @@ module FatesHistoryInterfaceMod integer :: ih_firemortality_carbonflux_si_pft integer :: ih_crownarea_si_pft integer :: ih_canopycrownarea_si_pft - integer :: ih_crownarea_si_cnlf integer :: ih_gpp_si_pft integer :: ih_gpp_sec_si_pft integer :: ih_npp_si_pft @@ -697,20 +680,27 @@ module FatesHistoryInterfaceMod integer :: ih_parsha_z_si_cnlf integer :: ih_laisun_z_si_cnlf integer :: ih_laisha_z_si_cnlf + integer :: ih_fabd_sun_si_cnlf + integer :: ih_fabd_sha_si_cnlf + integer :: ih_fabi_sun_si_cnlf + integer :: ih_fabi_sha_si_cnlf integer :: ih_ts_net_uptake_si_cnlf - integer :: ih_crownarea_clll + integer :: ih_crownarea_si_cnlf integer :: ih_parprof_dir_si_cnlf integer :: ih_parprof_dif_si_cnlf ! indices to (site x [canopy layer x leaf layer x pft]) variables integer :: ih_parsun_z_si_cnlfpft integer :: ih_parsha_z_si_cnlfpft - integer :: ih_laisun_clllpf - integer :: ih_laisha_clllpf + integer :: ih_laisun_z_si_cnlfpft + integer :: ih_laisha_z_si_cnlfpft + integer :: ih_fabd_sun_si_cnlfpft + integer :: ih_fabd_sha_si_cnlfpft + integer :: ih_fabi_sun_si_cnlfpft + integer :: ih_fabi_sha_si_cnlfpft integer :: ih_parprof_dir_si_cnlfpft integer :: ih_parprof_dif_si_cnlfpft - integer :: ih_crownfrac_clllpf - + ! indices to site x crown damage variables ! site x crown damage x pft x sizeclass ! site x crown damage x size class @@ -735,11 +725,15 @@ module FatesHistoryInterfaceMod integer :: ih_crownarea_ustory_damage_si ! indices to (site x canopy layer) variables - integer :: ih_parsun_si_can - integer :: ih_parsha_si_can - integer :: ih_laisun_si_can - integer :: ih_laisha_si_can - integer :: ih_crownarea_cl + integer :: ih_parsun_top_si_can + integer :: ih_parsha_top_si_can + integer :: ih_laisun_top_si_can + integer :: ih_laisha_top_si_can + integer :: ih_fabd_sun_top_si_can + integer :: ih_fabd_sha_top_si_can + integer :: ih_fabi_sun_top_si_can + integer :: ih_fabi_sha_top_si_can + integer :: ih_crownarea_si_can ! indices to (patch age x fuel size class) variables integer :: ih_fuel_amount_age_fuel @@ -786,8 +780,7 @@ module FatesHistoryInterfaceMod procedure :: assemble_history_output_types procedure :: update_history_dyn - procedure :: update_history_hifrq_simple - procedure :: update_history_hifrq_multi + procedure :: update_history_hifrq procedure :: update_history_hydraulics procedure :: update_history_nutrflux @@ -2083,6 +2076,15 @@ subroutine update_history_nutrflux(this,csite) cpatch => cpatch%older end do + ! Normalize the layer x size x pft arrays + !do iclscpf = 1,nclmax*numpft*nlevsclass + !if(fnrtc_clscpf(iclscpf)>nearzero) then + ! hio_l2fr_clscpf(io_si,iclscpf) = hio_l2fr_clscpf(io_si,iclscpf) / fnrtc_clscpf(iclscpf) + !else + ! hio_l2fr_clscpf(io_si,iclscpf) = hlm_hio_ignore_val + !end if + !end do + do ft = 1,numpft hio_recl2fr_canopy_pf(io_si,ft) = csite%rec_l2fr(ft,1) hio_recl2fr_ustory_pf(io_si,ft) = csite%rec_l2fr(ft,2) @@ -2119,14 +2121,15 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) use FatesSizeAgeTypeIndicesMod, only : get_sizeagepft_class_index use FatesSizeAgeTypeIndicesMod, only : get_agepft_class_index use FatesSizeAgeTypeIndicesMod, only : get_agefuel_class_index - + use FatesSizeAgeTypeIndicesMod, only : get_age_class_index use FatesSizeAgeTypeIndicesMod, only : get_height_index use FatesSizeAgeTypeIndicesMod, only : sizetype_class_index use FatesSizeAgeTypeIndicesMod, only : get_cdamagesize_class_index use FatesSizeAgeTypeIndicesMod, only : get_cdamagesizepft_class_index use FatesSizeAgeTypeIndicesMod, only : coagetype_class_index - + use EDParamsMod , only : nlevleaf + use EDParamsMod , only : ED_val_history_height_bin_edges use FatesInterfaceTypesMod , only : nlevdamage ! Arguments @@ -2475,10 +2478,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_cwd_ag_out_si_cwdsc => this%hvars(ih_cwd_ag_out_si_cwdsc)%r82d, & hio_cwd_bg_out_si_cwdsc => this%hvars(ih_cwd_bg_out_si_cwdsc)%r82d, & hio_crownarea_si_cnlf => this%hvars(ih_crownarea_si_cnlf)%r82d, & - hio_crownarea_cl => this%hvars(ih_crownarea_cl)%r82d, & - hio_nplant_si_scag => this%hvars(ih_nplant_si_scag)%r82d, & - hio_nplant_canopy_si_scag => this%hvars(ih_nplant_canopy_si_scag)%r82d, & - hio_nplant_understory_si_scag => this%hvars(ih_nplant_understory_si_scag)%r82d, & + hio_crownarea_si_can => this%hvars(ih_crownarea_si_can)%r82d, & hio_ddbh_canopy_si_scag => this%hvars(ih_ddbh_canopy_si_scag)%r82d, & hio_ddbh_understory_si_scag => this%hvars(ih_ddbh_understory_si_scag)%r82d, & hio_mortality_canopy_si_scag => this%hvars(ih_mortality_canopy_si_scag)%r82d, & @@ -2498,7 +2498,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_meansmp_si_pft => this%hvars(ih_meansmp_si_pft)%r82d, & hio_elong_factor_si_pft => this%hvars(ih_elong_factor_si_pft)%r82d, & hio_tveg24 => this%hvars(ih_tveg24_si)%r81d, & - hio_tlongterm => this%hvars(ih_tlongterm_si)%r81d, & + hio_tlongterm => this%hvars(ih_tlongterm_si)%r81d, & hio_tgrowth => this%hvars(ih_tgrowth_si)%r81d, & hio_cbal_err_fates_si => this%hvars(ih_cbal_err_fates_si)%r81d, & hio_err_fates_si => this%hvars(ih_err_fates_si)%r82d, & @@ -3664,7 +3664,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! resolve some canopy area profiles, both total and of occupied leaves ican = ccohort%canopy_layer ! - hio_crownarea_cl(io_si, ican) = hio_crownarea_cl(io_si, ican) + ccohort%c_area / AREA + hio_crownarea_si_can(io_si, ican) = hio_crownarea_si_can(io_si, ican) + ccohort%c_area / AREA ! do ileaf=1,ccohort%nv cnlf_indx = ileaf + (ican-1) * nlevleaf @@ -4386,317 +4386,14 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) return end subroutine update_history_dyn - ! =============================================================================================== - - subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) - - ! - ! Arguments - class(fates_history_interface_type) :: this - integer , intent(in) :: nc ! clump index - integer , intent(in) :: nsites - type(ed_site_type) , intent(inout), target :: sites(nsites) - type(bc_in_type) , intent(in) :: bc_in(nsites) - type(bc_out_type) , intent(in) :: bc_out(nsites) - real(r8) , intent(in) :: dt_tstep - - ! Locals - integer :: s ! The local site index - integer :: io_si ! The site index of the IO array - integer :: ipa ! patch bc index for the patch - integer :: age_class ! class age index - real(r8) :: site_area_veg_inv ! inverse canopy area of the site (1/m2) - real(r8) :: site_area_rad_inv ! inverse canopy area of site for only - ! patches that called the solver - real(r8) :: dt_tstep_inv ! inverse timestep (1/sec) - real(r8) :: n_perm2 ! number of plants per square meter - real(r8) :: sum_area_rad ! sum of patch canopy areas - real(r8),allocatable :: age_area_rad(:) - - type(fates_patch_type),pointer :: cpatch - type(fates_cohort_type),pointer :: ccohort - - associate( hio_gpp_si => this%hvars(ih_gpp_si)%r81d, & - hio_gpp_secondary_si => this%hvars(ih_gpp_secondary_si)%r81d, & - hio_npp_si => this%hvars(ih_npp_si)%r81d, & - hio_npp_secondary_si => this%hvars(ih_npp_secondary_si)%r81d, & - hio_aresp_si => this%hvars(ih_aresp_si)%r81d, & - hio_aresp_secondary_si => this%hvars(ih_aresp_secondary_si)%r81d, & - hio_maint_resp_si => this%hvars(ih_maint_resp_si)%r81d, & - hio_maint_resp_secondary_si => this%hvars(ih_maint_resp_secondary_si)%r81d, & - hio_growth_resp_si => this%hvars(ih_growth_resp_si)%r81d, & - hio_growth_resp_secondary_si => this%hvars(ih_growth_resp_secondary_si)%r81d, & - hio_c_stomata_si => this%hvars(ih_c_stomata_si)%r81d, & - hio_c_lblayer_si => this%hvars(ih_c_lblayer_si)%r81d, & - hio_rad_error_si => this%hvars(ih_rad_error_si)%r81d, & - hio_vis_solve_err_si => this%hvars(ih_vis_solve_err_si)%r81d, & - hio_nir_solve_err_si => this%hvars(ih_nir_solve_err_si)%r81d, & - hio_vis_consv_err_si => this%hvars(ih_vis_consv_err_si)%r81d, & - hio_nir_consv_err_si => this%hvars(ih_nir_consv_err_si)%r81d, & - hio_vis_solve_err_age_si => this%hvars(ih_vis_solve_err_age_si)%r82d, & - hio_nir_solve_err_age_si => this%hvars(ih_nir_solve_err_age_si)%r82d, & - hio_vis_consv_err_age_si => this%hvars(ih_vis_consv_err_age_si)%r82d, & - hio_nir_consv_err_age_si => this%hvars(ih_nir_consv_err_age_si)%r82d, & - hio_nep_si => this%hvars(ih_nep_si)%r81d, & - hio_hr_si => this%hvars(ih_hr_si)%r81d, & - hio_gpp_canopy_si => this%hvars(ih_gpp_canopy_si)%r81d, & - hio_ar_canopy_si => this%hvars(ih_ar_canopy_si)%r81d, & - hio_gpp_understory_si => this%hvars(ih_gpp_understory_si)%r81d, & - hio_ar_understory_si => this%hvars(ih_ar_understory_si)%r81d, & - hio_leaf_mr_si => this%hvars(ih_leaf_mr_si)%r81d, & - hio_froot_mr_si => this%hvars(ih_froot_mr_si)%r81d, & - hio_livecroot_mr_si => this%hvars(ih_livecroot_mr_si)%r81d, & - hio_livestem_mr_si => this%hvars(ih_livestem_mr_si)%r81d, & - hio_maint_resp_unreduced_si => this%hvars(ih_maint_resp_unreduced_si)%r81d, & - hio_tveg => this%hvars(ih_tveg_si)%r81d) - - - ! Flush the relevant history variables - call this%flush_hvars(nc,upfreq_in=2) - - dt_tstep_inv = 1.0_r8/dt_tstep - - allocate(age_area_rad(size(ED_val_history_ageclass_bin_edges,1)+1)) - - do_sites: do s = 1,nsites - - call this%zero_site_hvars(sites(s), upfreq_in=2) - - io_si = sites(s)%h_gid - - hio_nep_si(io_si) = -bc_in(s)%tot_het_resp * kg_per_g - hio_hr_si(io_si) = bc_in(s)%tot_het_resp * kg_per_g - - ! Diagnostics that are only incremented if we called the radiation solver - ! We do not call the radiation solver if - ! a) there is no vegetation - ! b) there is no light! (ie cos(zenith) ~= 0) - age_area_rad(:) = 0._r8 - cpatch => sites(s)%oldest_patch - do while(associated(cpatch)) - ! We initialize the solver error to the ignore value - ! in the radiation driver. It is only modified if the - ! solver was called. The solver will be called for NIR - ! if VIS is called, and likewise the same for conservation - ! error. So the check on VIS solve error will catch all. - if( abs(cpatch%solve_err(ivis)-hlm_hio_ignore_val)>nearzero ) then - age_class = get_age_class_index(cpatch%age) - age_area_rad(age_class) = age_area_rad(age_class) + cpatch%total_canopy_area - end if - cpatch => cpatch%younger - end do - - sum_area_rad = sum(age_area_rad(:)) - - if_anyrad: if(sum_area_rad sites(s)%oldest_patch - do while(associated(cpatch)) - if( abs(cpatch%solve_err(ivis)-hlm_hio_ignore_val)>nearzero ) then - age_class = get_age_class_index(cpatch%age) - - hio_vis_solve_err_age_si(io_si,age_class) = hio_vis_solve_err_age_si(io_si,age_class) + & - cpatch%solve_err(ivis) * cpatch%total_canopy_area/age_area_rad(age_class) - hio_nir_solve_err_age_si(io_si,age_class) = hio_nir_solve_err_age_si(io_si,age_class) + & - cpatch%solve_err(inir) * cpatch%total_canopy_area/age_area_rad(age_class) - hio_vis_consv_err_age_si(io_si,age_class) = hio_vis_consv_err_age_si(io_si,age_class) + & - cpatch%consv_err(ivis) * cpatch%total_canopy_area/age_area_rad(age_class) - hio_nir_consv_err_age_si(io_si,age_class) = hio_nir_consv_err_age_si(io_si,age_class) + & - cpatch%consv_err(inir) * cpatch%total_canopy_area/age_area_rad(age_class) - - hio_vis_solve_err_si(io_si) = hio_vis_solve_err_si(io_si) + & - cpatch%solve_err(ivis)*cpatch%total_canopy_area/sum(age_area_rad(:)) - hio_nir_solve_err_si(io_si) = hio_nir_solve_err_si(io_si) + & - cpatch%solve_err(inir)*cpatch%total_canopy_area/sum(age_area_rad(:)) - hio_vis_consv_err_si(io_si) = hio_vis_consv_err_si(io_si) + & - cpatch%consv_err(ivis)*cpatch%total_canopy_area/sum(age_area_rad(:)) - hio_nir_consv_err_si(io_si) = hio_nir_consv_err_si(io_si) + & - cpatch%consv_err(inir)*cpatch%total_canopy_area/sum(age_area_rad(:)) - - end if - cpatch => cpatch%younger - end do - end if if_anyrad - - ! Diagnostics that are only relevant if there is vegetation present on this site - ! ie, non-zero canopy area - - - site_area_veg_inv = 0._r8 - cpatch => sites(s)%oldest_patch - do while(associated(cpatch)) - site_area_veg_inv = site_area_veg_inv + cpatch%total_canopy_area - cpatch => cpatch%younger - end do !patch loop - - if_veg_area: if(site_area_veg_inv < nearzero) then - - hio_c_stomata_si(io_si) = hlm_hio_ignore_val - hio_c_lblayer_si(io_si) = hlm_hio_ignore_val - hio_rad_error_si(io_si) = hlm_hio_ignore_val - hio_tveg(io_si) = hlm_hio_ignore_val - - exit if_veg_area - - else - - ipa = 0 - site_area_veg_inv = 1._r8/site_area_veg_inv - - cpatch => sites(s)%oldest_patch - do while(associated(cpatch)) - - ipa = ipa + 1 - - - hio_c_stomata_si(io_si) = hio_c_stomata_si(io_si) + & - cpatch%c_stomata * cpatch%total_canopy_area * mol_per_umol * site_area_veg_inv - - hio_c_lblayer_si(io_si) = hio_c_lblayer_si(io_si) + & - cpatch%c_lblayer * cpatch%total_canopy_area * mol_per_umol * site_area_veg_inv - - hio_rad_error_si(io_si) = hio_rad_error_si(io_si) + & - cpatch%radiation_error * cpatch%total_canopy_area * site_area_veg_inv - - - ! Only accumulate the instantaneous vegetation temperature for vegetated patches - if (cpatch%patchno .ne. 0) then - hio_tveg(io_si) = hio_tveg(io_si) + & - (bc_in(s)%t_veg_pa(cpatch%patchno) - t_water_freeze_k_1atm) * & - cpatch%total_canopy_area * site_area_veg_inv - end if - - ccohort => cpatch%shortest - do while(associated(ccohort)) - - n_perm2 = ccohort%n * AREA_INV - - if_notnew: if ( .not. ccohort%isnew ) then - - ! scale up cohort fluxes to the site level - hio_npp_si(io_si) = hio_npp_si(io_si) + & - ccohort%npp_tstep * n_perm2 * dt_tstep_inv - - ! Net Ecosystem Production [kgC/m2/s] - hio_nep_si(io_si) = hio_nep_si(io_si) + & - ccohort%npp_tstep * n_perm2 * dt_tstep_inv - - hio_gpp_si(io_si) = hio_gpp_si(io_si) + & - ccohort%gpp_tstep * n_perm2 * dt_tstep_inv - - hio_aresp_si(io_si) = hio_aresp_si(io_si) + & - ccohort%resp_tstep * n_perm2 * dt_tstep_inv - - hio_growth_resp_si(io_si) = hio_growth_resp_si(io_si) + & - ccohort%resp_g_tstep * n_perm2 * dt_tstep_inv - - hio_maint_resp_si(io_si) = hio_maint_resp_si(io_si) + & - ccohort%resp_m * n_perm2 * dt_tstep_inv - - hio_maint_resp_unreduced_si(io_si) = hio_maint_resp_unreduced_si(io_si) + & - ccohort%resp_m_unreduced * n_perm2 * dt_tstep_inv - - ! Secondary forest only - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then - hio_npp_secondary_si(io_si) = hio_npp_secondary_si(io_si) + & - ccohort%npp_tstep * n_perm2 * dt_tstep_inv - - hio_gpp_secondary_si(io_si) = hio_gpp_secondary_si(io_si) + & - ccohort%gpp_tstep * n_perm2 * dt_tstep_inv - - hio_aresp_secondary_si(io_si) = hio_aresp_secondary_si(io_si) + & - ccohort%resp_tstep * n_perm2 * dt_tstep_inv - - hio_growth_resp_secondary_si(io_si) = hio_growth_resp_secondary_si(io_si) + & - ccohort%resp_g_tstep * n_perm2 * dt_tstep_inv - - hio_maint_resp_secondary_si(io_si) = hio_maint_resp_secondary_si(io_si) + & - ccohort%resp_m * n_perm2 * dt_tstep_inv - end if - - ! Maintenance respiration of different organs - hio_leaf_mr_si(io_si) = hio_leaf_mr_si(io_si) + ccohort%rdark & - * n_perm2 - hio_froot_mr_si(io_si) = hio_froot_mr_si(io_si) + ccohort%froot_mr & - * n_perm2 - hio_livecroot_mr_si(io_si) = hio_livecroot_mr_si(io_si) + ccohort%livecroot_mr & - * n_perm2 - hio_livestem_mr_si(io_si) = hio_livestem_mr_si(io_si) + ccohort%livestem_mr & - * n_perm2 - - ! accumulate fluxes on canopy- and understory- separated fluxes - if (ccohort%canopy_layer .eq. 1) then - - ! bulk fluxes are in gC / m2 / s - hio_gpp_canopy_si(io_si) = hio_gpp_canopy_si(io_si) + & - ccohort%gpp_tstep * n_perm2 * dt_tstep_inv - - hio_ar_canopy_si(io_si) = hio_ar_canopy_si(io_si) + & - ccohort%resp_tstep * n_perm2 * dt_tstep_inv - - else - - ! bulk fluxes are in gC / m2 / s - hio_gpp_understory_si(io_si) = hio_gpp_understory_si(io_si) + & - ccohort%gpp_tstep * n_perm2 * dt_tstep_inv - - hio_ar_understory_si(io_si) = hio_ar_understory_si(io_si) + & - ccohort%resp_tstep * n_perm2 * dt_tstep_inv - - end if - - end if if_notnew - ccohort => ccohort%taller - end do - - cpatch => cpatch%younger - end do - end if if_veg_area - end do do_sites - - deallocate(age_area_rad) - - end associate - return - end subroutine update_history_hifrq_simple - - ! =============================================================================================== - - subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) + subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ! --------------------------------------------------------------------------------- - ! This is the call to update the history IO arrays for multi-dimension arrays - ! that change rapidly. This is an expensive call, the model will probably run - ! much faster if the user is not using any of these diagnostics. + ! This is the call to update the history IO arrays that are expected to only change + ! after rapid timescale productivity calculations (gpp and respiration). ! --------------------------------------------------------------------------------- + use EDParamsMod , only : nclmax, nlevleaf ! ! Arguments class(fates_history_interface_type) :: this @@ -4704,7 +4401,6 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) type(bc_in_type) , intent(in) :: bc_in(nsites) - type(bc_out_type) , intent(in) :: bc_out(nsites) real(r8) , intent(in) :: dt_tstep ! Locals @@ -4721,102 +4417,125 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep real(r8) :: n_perm2 ! individuals per m2 for the whole column real(r8) :: patch_area_by_age(nlevage) ! patch area in each bin for normalizing purposes real(r8) :: canopy_area_by_age(nlevage) ! canopy area in each bin for normalizing purposes - real(r8) :: site_area_veg_inv ! 1/area of the site that is not bare-ground + real(r8) :: site_area_veg ! area of the site that is not bare-ground integer :: ipa2 ! patch incrementer - integer :: clllpf_indx, cnlf_indx, ipft, ican, ileaf ! more iterators and indices - real(r8) :: clllpf_area ! area footprint (m2) for the current cl x ll x pft bin - real(r8) :: clll_area ! area footprint (m2) for the cl x ll bin (ie adds up pfts in parallel) - real(r8) :: cl_area ! total weight of all ll x pft bins in the canopy layer - + integer :: cnlfpft_indx, cnlf_indx, ipft, ican, ileaf ! more iterators and indices type(fates_patch_type),pointer :: cpatch type(fates_cohort_type),pointer :: ccohort - real(r8) :: dt_tstep_inv ! Time step in frequency units (/s) - - if(.not.hio_include_hifr_multi) return - - associate( hio_ar_si_scpf => this%hvars(ih_ar_si_scpf)%r82d, & - hio_ar_grow_si_scpf => this%hvars(ih_ar_grow_si_scpf)%r82d, & - hio_ar_maint_si_scpf => this%hvars(ih_ar_maint_si_scpf)%r82d, & - hio_ar_agsapm_si_scpf => this%hvars(ih_ar_agsapm_si_scpf)%r82d, & - hio_ar_darkm_si_scpf => this%hvars(ih_ar_darkm_si_scpf)%r82d, & - hio_ar_crootm_si_scpf => this%hvars(ih_ar_crootm_si_scpf)%r82d, & - hio_ar_frootm_si_scpf => this%hvars(ih_ar_frootm_si_scpf)%r82d, & - hio_rdark_canopy_si_scls => this%hvars(ih_rdark_canopy_si_scls)%r82d, & - hio_livestem_mr_canopy_si_scls => this%hvars(ih_livestem_mr_canopy_si_scls)%r82d, & - hio_livecroot_mr_canopy_si_scls => this%hvars(ih_livecroot_mr_canopy_si_scls)%r82d, & - hio_froot_mr_canopy_si_scls => this%hvars(ih_froot_mr_canopy_si_scls)%r82d, & - hio_resp_g_canopy_si_scls => this%hvars(ih_resp_g_canopy_si_scls)%r82d, & - hio_resp_m_canopy_si_scls => this%hvars(ih_resp_m_canopy_si_scls)%r82d, & - hio_rdark_understory_si_scls => this%hvars(ih_rdark_understory_si_scls)%r82d, & - hio_livestem_mr_understory_si_scls => this%hvars(ih_livestem_mr_understory_si_scls)%r82d, & - hio_livecroot_mr_understory_si_scls => this%hvars(ih_livecroot_mr_understory_si_scls)%r82d, & - hio_froot_mr_understory_si_scls => this%hvars(ih_froot_mr_understory_si_scls)%r82d, & - hio_resp_g_understory_si_scls => this%hvars(ih_resp_g_understory_si_scls)%r82d, & - hio_resp_m_understory_si_scls => this%hvars(ih_resp_m_understory_si_scls)%r82d, & - hio_gpp_si_age => this%hvars(ih_gpp_si_age)%r82d, & - hio_npp_si_age => this%hvars(ih_npp_si_age)%r82d, & - hio_c_stomata_si_age => this%hvars(ih_c_stomata_si_age)%r82d, & - hio_c_lblayer_si_age => this%hvars(ih_c_lblayer_si_age)%r82d, & - hio_parsun_z_si_cnlf => this%hvars(ih_parsun_z_si_cnlf)%r82d, & - hio_parsha_z_si_cnlf => this%hvars(ih_parsha_z_si_cnlf)%r82d, & - hio_ts_net_uptake_si_cnlf => this%hvars(ih_ts_net_uptake_si_cnlf)%r82d, & - hio_parsun_z_si_cnlfpft => this%hvars(ih_parsun_z_si_cnlfpft)%r82d, & - hio_parsha_z_si_cnlfpft => this%hvars(ih_parsha_z_si_cnlfpft)%r82d, & - hio_laisun_z_si_cnlf => this%hvars(ih_laisun_z_si_cnlf)%r82d, & - hio_laisha_z_si_cnlf => this%hvars(ih_laisha_z_si_cnlf)%r82d, & - hio_laisun_clllpf => this%hvars(ih_laisun_clllpf)%r82d, & - hio_laisha_clllpf => this%hvars(ih_laisha_clllpf)%r82d, & - hio_crownfrac_clllpf => this%hvars(ih_crownfrac_clllpf)%r82d, & - hio_parprof_dir_si_cnlf => this%hvars(ih_parprof_dir_si_cnlf)%r82d, & - hio_parprof_dif_si_cnlf => this%hvars(ih_parprof_dif_si_cnlf)%r82d, & - hio_parprof_dir_si_cnlfpft => this%hvars(ih_parprof_dir_si_cnlfpft)%r82d, & - hio_parprof_dif_si_cnlfpft => this%hvars(ih_parprof_dif_si_cnlfpft)%r82d, & - hio_parsun_si_can => this%hvars(ih_parsun_si_can)%r82d, & - hio_parsha_si_can => this%hvars(ih_parsha_si_can)%r82d, & - hio_laisun_si_can => this%hvars(ih_laisun_si_can)%r82d, & - hio_laisha_si_can => this%hvars(ih_laisha_si_can)%r82d ) - - ! Flush the relevant history variables - call this%flush_hvars(nc,upfreq_in=upfreq_hifr_multi) + real(r8) :: per_dt_tstep ! Time step in frequency units (/s) - dt_tstep_inv = 1.0_r8/dt_tstep + associate( hio_gpp_si => this%hvars(ih_gpp_si)%r81d, & + hio_gpp_secondary_si => this%hvars(ih_gpp_secondary_si)%r81d, & + hio_npp_si => this%hvars(ih_npp_si)%r81d, & + hio_npp_secondary_si => this%hvars(ih_npp_secondary_si)%r81d, & + hio_aresp_si => this%hvars(ih_aresp_si)%r81d, & + hio_aresp_secondary_si => this%hvars(ih_aresp_secondary_si)%r81d, & + hio_maint_resp_si => this%hvars(ih_maint_resp_si)%r81d, & + hio_maint_resp_secondary_si => this%hvars(ih_maint_resp_secondary_si)%r81d, & + hio_growth_resp_si => this%hvars(ih_growth_resp_si)%r81d, & + hio_growth_resp_secondary_si => this%hvars(ih_growth_resp_secondary_si)%r81d, & + hio_c_stomata_si => this%hvars(ih_c_stomata_si)%r81d, & + hio_c_lblayer_si => this%hvars(ih_c_lblayer_si)%r81d, & + hio_rad_error_si => this%hvars(ih_rad_error_si)%r81d, & + hio_nep_si => this%hvars(ih_nep_si)%r81d, & + hio_hr_si => this%hvars(ih_hr_si)%r81d, & + hio_ar_si_scpf => this%hvars(ih_ar_si_scpf)%r82d, & + hio_ar_grow_si_scpf => this%hvars(ih_ar_grow_si_scpf)%r82d, & + hio_ar_maint_si_scpf => this%hvars(ih_ar_maint_si_scpf)%r82d, & + hio_ar_agsapm_si_scpf => this%hvars(ih_ar_agsapm_si_scpf)%r82d, & + hio_ar_darkm_si_scpf => this%hvars(ih_ar_darkm_si_scpf)%r82d, & + hio_ar_crootm_si_scpf => this%hvars(ih_ar_crootm_si_scpf)%r82d, & + hio_ar_frootm_si_scpf => this%hvars(ih_ar_frootm_si_scpf)%r82d, & + hio_gpp_canopy_si => this%hvars(ih_gpp_canopy_si)%r81d, & + hio_ar_canopy_si => this%hvars(ih_ar_canopy_si)%r81d, & + hio_gpp_understory_si => this%hvars(ih_gpp_understory_si)%r81d, & + hio_ar_understory_si => this%hvars(ih_ar_understory_si)%r81d, & + hio_rdark_canopy_si_scls => this%hvars(ih_rdark_canopy_si_scls)%r82d, & + hio_livestem_mr_canopy_si_scls => this%hvars(ih_livestem_mr_canopy_si_scls)%r82d, & + hio_livecroot_mr_canopy_si_scls => this%hvars(ih_livecroot_mr_canopy_si_scls)%r82d, & + hio_froot_mr_canopy_si_scls => this%hvars(ih_froot_mr_canopy_si_scls)%r82d, & + hio_resp_g_canopy_si_scls => this%hvars(ih_resp_g_canopy_si_scls)%r82d, & + hio_resp_m_canopy_si_scls => this%hvars(ih_resp_m_canopy_si_scls)%r82d, & + hio_rdark_understory_si_scls => this%hvars(ih_rdark_understory_si_scls)%r82d, & + hio_livestem_mr_understory_si_scls => this%hvars(ih_livestem_mr_understory_si_scls)%r82d, & + hio_livecroot_mr_understory_si_scls => this%hvars(ih_livecroot_mr_understory_si_scls)%r82d, & + hio_froot_mr_understory_si_scls => this%hvars(ih_froot_mr_understory_si_scls)%r82d, & + hio_resp_g_understory_si_scls => this%hvars(ih_resp_g_understory_si_scls)%r82d, & + hio_resp_m_understory_si_scls => this%hvars(ih_resp_m_understory_si_scls)%r82d, & + hio_leaf_mr_si => this%hvars(ih_leaf_mr_si)%r81d, & + hio_froot_mr_si => this%hvars(ih_froot_mr_si)%r81d, & + hio_livecroot_mr_si => this%hvars(ih_livecroot_mr_si)%r81d, & + hio_livestem_mr_si => this%hvars(ih_livestem_mr_si)%r81d, & + hio_gpp_si_age => this%hvars(ih_gpp_si_age)%r82d, & + hio_npp_si_age => this%hvars(ih_npp_si_age)%r82d, & + hio_c_stomata_si_age => this%hvars(ih_c_stomata_si_age)%r82d, & + hio_c_lblayer_si_age => this%hvars(ih_c_lblayer_si_age)%r82d, & + hio_parsun_z_si_cnlf => this%hvars(ih_parsun_z_si_cnlf)%r82d, & + hio_parsha_z_si_cnlf => this%hvars(ih_parsha_z_si_cnlf)%r82d, & + hio_ts_net_uptake_si_cnlf => this%hvars(ih_ts_net_uptake_si_cnlf)%r82d, & + hio_parsun_z_si_cnlfpft => this%hvars(ih_parsun_z_si_cnlfpft)%r82d, & + hio_parsha_z_si_cnlfpft => this%hvars(ih_parsha_z_si_cnlfpft)%r82d, & + hio_laisun_z_si_cnlf => this%hvars(ih_laisun_z_si_cnlf)%r82d, & + hio_laisha_z_si_cnlf => this%hvars(ih_laisha_z_si_cnlf)%r82d, & + hio_laisun_z_si_cnlfpft => this%hvars(ih_laisun_z_si_cnlfpft)%r82d, & + hio_laisha_z_si_cnlfpft => this%hvars(ih_laisha_z_si_cnlfpft)%r82d, & + hio_laisun_top_si_can => this%hvars(ih_laisun_top_si_can)%r82d, & + hio_laisha_top_si_can => this%hvars(ih_laisha_top_si_can)%r82d, & + hio_fabd_sun_si_cnlfpft => this%hvars(ih_fabd_sun_si_cnlfpft)%r82d, & + hio_fabd_sha_si_cnlfpft => this%hvars(ih_fabd_sha_si_cnlfpft)%r82d, & + hio_fabi_sun_si_cnlfpft => this%hvars(ih_fabi_sun_si_cnlfpft)%r82d, & + hio_fabi_sha_si_cnlfpft => this%hvars(ih_fabi_sha_si_cnlfpft)%r82d, & + hio_fabd_sun_si_cnlf => this%hvars(ih_fabd_sun_si_cnlf)%r82d, & + hio_fabd_sha_si_cnlf => this%hvars(ih_fabd_sha_si_cnlf)%r82d, & + hio_fabi_sun_si_cnlf => this%hvars(ih_fabi_sun_si_cnlf)%r82d, & + hio_fabi_sha_si_cnlf => this%hvars(ih_fabi_sha_si_cnlf)%r82d, & + hio_parprof_dir_si_cnlf => this%hvars(ih_parprof_dir_si_cnlf)%r82d, & + hio_parprof_dif_si_cnlf => this%hvars(ih_parprof_dif_si_cnlf)%r82d, & + hio_parprof_dir_si_cnlfpft => this%hvars(ih_parprof_dir_si_cnlfpft)%r82d, & + hio_parprof_dif_si_cnlfpft => this%hvars(ih_parprof_dif_si_cnlfpft)%r82d, & + hio_fabd_sun_top_si_can => this%hvars(ih_fabd_sun_top_si_can)%r82d, & + hio_fabd_sha_top_si_can => this%hvars(ih_fabd_sha_top_si_can)%r82d, & + hio_fabi_sun_top_si_can => this%hvars(ih_fabi_sun_top_si_can)%r82d, & + hio_fabi_sha_top_si_can => this%hvars(ih_fabi_sha_top_si_can)%r82d, & + hio_parsun_top_si_can => this%hvars(ih_parsun_top_si_can)%r82d, & + hio_parsha_top_si_can => this%hvars(ih_parsha_top_si_can)%r82d, & + hio_maint_resp_unreduced_si => this%hvars(ih_maint_resp_unreduced_si)%r81d, & + hio_tveg => this%hvars(ih_tveg_si)%r81d) - do_sites: do s = 1,nsites - - site_area_veg_inv = 0._r8 - cpatch => sites(s)%oldest_patch - do while(associated(cpatch)) - site_area_veg_inv = site_area_veg_inv + cpatch%total_canopy_area - cpatch => cpatch%younger - end do !patch loop + ! Flush the relevant history variables + call this%flush_hvars(nc,upfreq_in=2) - ! If there is no vegetation, go to the next site - if(site_area_veg_inv < nearzero) cycle do_sites + per_dt_tstep = 1.0_r8/dt_tstep - site_area_veg_inv = 1._r8/site_area_veg_inv + do s = 1,nsites + + call this%zero_site_hvars(sites(s), upfreq_in=2) io_si = sites(s)%h_gid + hio_nep_si(io_si) = -bc_in(s)%tot_het_resp * kg_per_g + hio_hr_si(io_si) = bc_in(s)%tot_het_resp * kg_per_g + ipa = 0 patch_area_by_age(1:nlevage) = 0._r8 canopy_area_by_age(1:nlevage) = 0._r8 - call this%zero_site_hvars(sites(s), upfreq_in=upfreq_hifr_multi) - + ! Calculate the site-level total vegetated area (i.e. non-bareground) + site_area_veg = area + if (hlm_use_nocomp .eq. itrue .and. hlm_use_fixed_biogeog .eq. itrue) then + site_area_veg = area - sites(s)%area_pft(0) + end if + cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - ipa = ipa + 1 - patch_area_by_age(cpatch%age_class) = & patch_area_by_age(cpatch%age_class) + cpatch%area canopy_area_by_age(cpatch%age_class) = & canopy_area_by_age(cpatch%age_class) + cpatch%total_canopy_area - - ! Canopy resitance terms hio_c_stomata_si_age(io_si,cpatch%age_class) = & hio_c_stomata_si_age(io_si,cpatch%age_class) + & @@ -4826,8 +4545,24 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep hio_c_lblayer_si_age(io_si,cpatch%age_class) + & cpatch%c_lblayer * cpatch%total_canopy_area * mol_per_umol - ccohort => cpatch%shortest - do while(associated(ccohort)) + hio_c_stomata_si(io_si) = hio_c_stomata_si(io_si) + & + cpatch%c_stomata * cpatch%total_canopy_area * mol_per_umol + + hio_c_lblayer_si(io_si) = hio_c_lblayer_si(io_si) + & + cpatch%c_lblayer * cpatch%total_canopy_area * mol_per_umol + + hio_rad_error_si(io_si) = hio_rad_error_si(io_si) + & + cpatch%radiation_error * cpatch%area * AREA_INV + + ! Only accumulate the instantaneous vegetation temperature for vegetated patches + if (cpatch%patchno .ne. 0) then + hio_tveg(io_si) = hio_tveg(io_si) + & + (bc_in(s)%t_veg_pa(cpatch%patchno) - t_water_freeze_k_1atm) * & + cpatch%area / site_area_veg + end if + + ccohort => cpatch%shortest + do while(associated(ccohort)) n_perm2 = ccohort%n * AREA_INV @@ -4841,17 +4576,63 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep associate( scpf => ccohort%size_by_pft_class, & scls => ccohort%size_class ) + ! scale up cohort fluxes to the site level + hio_npp_si(io_si) = hio_npp_si(io_si) + & + npp * n_perm2 * per_dt_tstep + + hio_gpp_si(io_si) = hio_gpp_si(io_si) + & + ccohort%gpp_tstep * n_perm2 * per_dt_tstep + + hio_aresp_si(io_si) = hio_aresp_si(io_si) + & + aresp * n_perm2 * per_dt_tstep + hio_growth_resp_si(io_si) = hio_growth_resp_si(io_si) + & + resp_g * n_perm2 * per_dt_tstep + hio_maint_resp_si(io_si) = hio_maint_resp_si(io_si) + & + ccohort%resp_m * n_perm2 * per_dt_tstep + + hio_maint_resp_unreduced_si(io_si) = hio_maint_resp_unreduced_si(io_si) + & + ccohort%resp_m_unreduced * n_perm2 * per_dt_tstep + + ! Secondary forest only + if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + hio_npp_secondary_si(io_si) = hio_npp_secondary_si(io_si) + & + npp * n_perm2 * per_dt_tstep + hio_gpp_secondary_si(io_si) = hio_gpp_secondary_si(io_si) + & + ccohort%gpp_tstep * n_perm2 * per_dt_tstep + hio_aresp_secondary_si(io_si) = hio_aresp_secondary_si(io_si) + & + aresp * n_perm2 * per_dt_tstep + hio_growth_resp_secondary_si(io_si) = hio_growth_resp_secondary_si(io_si) + & + resp_g * n_perm2 * per_dt_tstep + hio_maint_resp_secondary_si(io_si) = hio_maint_resp_secondary_si(io_si) + & + ccohort%resp_m * n_perm2 * per_dt_tstep + end if + + ! Add up the total Net Ecosystem Production + ! for this timestep. [kgC/m2/s] + hio_nep_si(io_si) = hio_nep_si(io_si) + & + npp * n_perm2 * per_dt_tstep + + ! aggregate MR fluxes to the site level + hio_leaf_mr_si(io_si) = hio_leaf_mr_si(io_si) + ccohort%rdark & + * n_perm2 + hio_froot_mr_si(io_si) = hio_froot_mr_si(io_si) + ccohort%froot_mr & + * n_perm2 + hio_livecroot_mr_si(io_si) = hio_livecroot_mr_si(io_si) + ccohort%livecroot_mr & + * n_perm2 + hio_livestem_mr_si(io_si) = hio_livestem_mr_si(io_si) + ccohort%livestem_mr & + * n_perm2 + ! Total AR (kgC/m2/s) = (kgC/plant/step) / (s/step) * (plant/m2) hio_ar_si_scpf(io_si,scpf) = hio_ar_si_scpf(io_si,scpf) + & - (ccohort%resp_tstep*dt_tstep_inv) * n_perm2 + (ccohort%resp_tstep*per_dt_tstep) * n_perm2 ! Growth AR (kgC/m2/s) hio_ar_grow_si_scpf(io_si,scpf) = hio_ar_grow_si_scpf(io_si,scpf) + & - (resp_g*dt_tstep_inv) * n_perm2 + (resp_g*per_dt_tstep) * n_perm2 ! Maint AR (kgC/m2/s) hio_ar_maint_si_scpf(io_si,scpf) = hio_ar_maint_si_scpf(io_si,scpf) + & - (ccohort%resp_m*dt_tstep_inv) * n_perm2 + (ccohort%resp_m*per_dt_tstep) * n_perm2 ! Maintenance AR partition variables are stored as rates (kgC/plant/s) ! (kgC/m2/s) = (kgC/plant/s) * (plant/m2) @@ -4870,16 +4651,24 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep hio_ar_frootm_si_scpf(io_si,scpf) = hio_ar_frootm_si_scpf(io_si,scpf) + & ccohort%froot_mr * n_perm2 + ! accumulate fluxes per patch age bin hio_gpp_si_age(io_si,cpatch%age_class) = hio_gpp_si_age(io_si,cpatch%age_class) & - + ccohort%gpp_tstep * ccohort%n * dt_tstep_inv - + + ccohort%gpp_tstep * ccohort%n * per_dt_tstep hio_npp_si_age(io_si,cpatch%age_class) = hio_npp_si_age(io_si,cpatch%age_class) & - + npp * ccohort%n * dt_tstep_inv + + npp * ccohort%n * per_dt_tstep ! accumulate fluxes on canopy- and understory- separated fluxes if (ccohort%canopy_layer .eq. 1) then + ! + ! bulk fluxes are in gC / m2 / s + hio_gpp_canopy_si(io_si) = hio_gpp_canopy_si(io_si) + & + ccohort%gpp_tstep * n_perm2 * per_dt_tstep + hio_ar_canopy_si(io_si) = hio_ar_canopy_si(io_si) + & + aresp * n_perm2 * per_dt_tstep + + ! ! size-resolved respiration fluxes are in kg C / m2 / s hio_rdark_canopy_si_scls(io_si,scls) = hio_rdark_canopy_si_scls(io_si,scls) + & ccohort%rdark * ccohort%n * ha_per_m2 @@ -4889,12 +4678,22 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep ccohort%livecroot_mr * ccohort%n * ha_per_m2 hio_froot_mr_canopy_si_scls(io_si,scls) = hio_froot_mr_canopy_si_scls(io_si,scls) + & ccohort%froot_mr * ccohort%n * ha_per_m2 + hio_resp_g_canopy_si_scls(io_si,scls) = hio_resp_g_canopy_si_scls(io_si,scls) + & - resp_g * ccohort%n * dt_tstep_inv * ha_per_m2 + resp_g * ccohort%n * per_dt_tstep * ha_per_m2 hio_resp_m_canopy_si_scls(io_si,scls) = hio_resp_m_canopy_si_scls(io_si,scls) + & - ccohort%resp_m * ccohort%n * dt_tstep_inv * ha_per_m2 + ccohort%resp_m * ccohort%n * per_dt_tstep * ha_per_m2 else + ! + ! bulk fluxes are in gC / m2 / s + hio_gpp_understory_si(io_si) = hio_gpp_understory_si(io_si) + & + ccohort%gpp_tstep * n_perm2 * per_dt_tstep + + hio_ar_understory_si(io_si) = hio_ar_understory_si(io_si) + & + aresp * n_perm2 * per_dt_tstep + + ! ! size-resolved respiration fluxes are in kg C / m2 / s hio_rdark_understory_si_scls(io_si,scls) = hio_rdark_understory_si_scls(io_si,scls) + & ccohort%rdark * ccohort%n * ha_per_m2 @@ -4905,9 +4704,9 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep hio_froot_mr_understory_si_scls(io_si,scls) = hio_froot_mr_understory_si_scls(io_si,scls) + & ccohort%froot_mr * ccohort%n * ha_per_m2 hio_resp_g_understory_si_scls(io_si,scls) = hio_resp_g_understory_si_scls(io_si,scls) + & - resp_g * ccohort%n * dt_tstep_inv * ha_per_m2 + resp_g * ccohort%n * per_dt_tstep * ha_per_m2 hio_resp_m_understory_si_scls(io_si,scls) = hio_resp_m_understory_si_scls(io_si,scls) + & - ccohort%resp_m * ccohort%n * dt_tstep_inv * ha_per_m2 + ccohort%resp_m * ccohort%n * per_dt_tstep * ha_per_m2 endif end associate endif @@ -4917,202 +4716,112 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep do ileaf=1,ccohort%nv cnlf_indx = ileaf + (ican-1) * nlevleaf hio_ts_net_uptake_si_cnlf(io_si, cnlf_indx) = hio_ts_net_uptake_si_cnlf(io_si, cnlf_indx) + & - ccohort%ts_net_uptake(ileaf) * dt_tstep_inv * ccohort%c_area * area_inv + ccohort%ts_net_uptake(ileaf) * per_dt_tstep * ccohort%c_area * area_inv end do ccohort => ccohort%taller enddo ! cohort loop - ! summarize radiation profiles through the canopy - ! -------------------------------------------------------------------- - - do_pft1: do ipft=1,numpft - do_canlev1: do ican=1,cpatch%ncl_p - do_leaflev1: do ileaf=1,cpatch%ncan(ican,ipft) - + do ipft=1,numpft + do ican=1,cpatch%ncl_p + do ileaf=1,cpatch%ncan(ican,ipft) ! calculate where we are on multiplexed dimensions - clllpf_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax + cnlfpft_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax cnlf_indx = ileaf + (ican-1) * nlevleaf - - ! canopy_area_profile is the fraction of the total canopy area that - ! is occupied by this bin. If you add up the top leaf layer bins in the - ! top canopy layers, for all pfts, that should equal to 1 - - clllpf_area = cpatch%canopy_area_profile(ican,ipft,ileaf)*cpatch%total_canopy_area - - ! Canopy by leaf by pft level diagnostics - ! ------------------------------------------------------------------- - hio_parsun_z_si_cnlfpft(io_si,clllpf_indx) = hio_parsun_z_si_cnlfpft(io_si,clllpf_indx) + & - cpatch%ed_parsun_z(ican,ipft,ileaf) * clllpf_area - - hio_parsha_z_si_cnlfpft(io_si,clllpf_indx) = hio_parsha_z_si_cnlfpft(io_si,clllpf_indx) + & - cpatch%ed_parsha_z(ican,ipft,ileaf) * clllpf_area - - ! elai_profile is the m2 of leaf inside the m2 of bin. - - hio_laisun_clllpf(io_si, clllpf_indx) = hio_laisun_clllpf(io_si, clllpf_indx) + & - cpatch%elai_profile(ican,ipft,ileaf)*cpatch%f_sun(ican,ipft,ileaf)*clllpf_area - - hio_laisha_clllpf(io_si,clllpf_indx) = hio_laisha_clllpf(io_si,clllpf_indx) + & - cpatch%elai_profile(ican,ipft,ileaf)*(1._r8-cpatch%f_sun(ican,ipft,ileaf))*clllpf_area - - hio_parprof_dir_si_cnlfpft(io_si,clllpf_indx) = hio_parprof_dir_si_cnlfpft(io_si,clllpf_indx) + & - cpatch%parprof_pft_dir_z(ican,ipft,ileaf) * clllpf_area - - hio_parprof_dif_si_cnlfpft(io_si,clllpf_indx) = hio_parprof_dif_si_cnlfpft(io_si,clllpf_indx) + & - cpatch%parprof_pft_dif_z(ican,ipft,ileaf) * clllpf_area - - ! The fractional area of Canopy layer and PFTs can be used - ! do upscale the CLLLPF properties - hio_crownfrac_clllpf(io_si,clllpf_indx) = hio_crownfrac_clllpf(io_si,clllpf_indx) + & - clllpf_area - - - ! Canopy by leaf layer (mean across pfts) level diagnostics - ! ---------------------------------------------------------------------------- - hio_parprof_dir_si_cnlf(io_si,cnlf_indx) = hio_parprof_dir_si_cnlf(io_si,cnlf_indx) + & - cpatch%parprof_pft_dir_z(ican,ipft,ileaf) * clllpf_area - - hio_parprof_dif_si_cnlf(io_si,cnlf_indx) = hio_parprof_dif_si_cnlf(io_si,cnlf_indx) + & - cpatch%parprof_pft_dif_z(ican,ipft,ileaf) * clllpf_area - + ! + ! first do all the canopy x leaf x pft calculations + hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + ! + hio_laisun_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_laisun_z_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_laisha_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_laisha_z_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + ! + hio_fabd_sun_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabd_sun_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabd_sha_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabd_sha_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabi_sun_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabi_sun_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabi_sha_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabi_sha_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + ! + hio_parprof_dir_si_cnlfpft(io_si,cnlfpft_indx) = hio_parprof_dir_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%parprof_pft_dir_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_parprof_dif_si_cnlfpft(io_si,cnlfpft_indx) = hio_parprof_dif_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%parprof_pft_dif_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + ! + ! summarize across all PFTs hio_parsun_z_si_cnlf(io_si,cnlf_indx) = hio_parsun_z_si_cnlf(io_si,cnlf_indx) + & - cpatch%ed_parsun_z(ican,ipft,ileaf) * clllpf_area - + cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV hio_parsha_z_si_cnlf(io_si,cnlf_indx) = hio_parsha_z_si_cnlf(io_si,cnlf_indx) + & - cpatch%ed_parsha_z(ican,ipft,ileaf) * clllpf_area - + cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + ! hio_laisun_z_si_cnlf(io_si,cnlf_indx) = hio_laisun_z_si_cnlf(io_si,cnlf_indx) + & - cpatch%f_sun(ican,ipft,ileaf)*clllpf_area - + cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV hio_laisha_z_si_cnlf(io_si,cnlf_indx) = hio_laisha_z_si_cnlf(io_si,cnlf_indx) + & - (1._r8-cpatch%f_sun(ican,ipft,ileaf))*clllpf_area - - ! Canopy mean diagnostics - ! -------------------------------------------------------------- - - hio_parsun_si_can(io_si,ican) = hio_parsun_si_can(io_si,ican) + & - cpatch%ed_parsun_z(ican,ipft,ileaf) * clllpf_area - hio_parsha_si_can(io_si,ican) = hio_parsha_si_can(io_si,ican) + & - cpatch%ed_parsha_z(ican,ipft,ileaf) * clllpf_area - - hio_laisun_si_can(io_si,ican) = hio_laisun_si_can(io_si,ican) + & - cpatch%f_sun(ican,ipft,ileaf)*cpatch%elai_profile(ican,ipft,ileaf) * clllpf_area - hio_laisha_si_can(io_si,ican) = hio_laisha_si_can(io_si,ican) + & - (1._r8-cpatch%f_sun(ican,ipft,ileaf))*cpatch%elai_profile(ican,ipft,ileaf) * clllpf_area - - - end do do_leaflev1 - end do do_canlev1 - end do do_pft1 - - cpatch => cpatch%younger - end do !patch loop - - ! Normalize the radiation multiplexed diagnostics - ! Set values that dont have canopy elements to ignore - ! ---------------------------------------------------------------------------- - - do_ican2: do ican = 1,nclmax + cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + ! + hio_fabd_sun_si_cnlf(io_si,cnlf_indx) = hio_fabd_sun_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabd_sha_si_cnlf(io_si,cnlf_indx) = hio_fabd_sha_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabi_sun_si_cnlf(io_si,cnlf_indx) = hio_fabi_sun_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabi_sha_si_cnlf(io_si,cnlf_indx) = hio_fabi_sha_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - cl_area = 0._r8 - do_ileaf2: do ileaf = 1,nlevleaf - - clll_area = 0._r8 - do_ipft2: do ipft = 1,numpft - - clllpf_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax - if( hio_crownfrac_clllpf(io_si,clllpf_indx) cpatch%younger + end do !patch loop - ! Normalize age stratified diagnostics - ! ---------------------------------------------------------------- do ipa2 = 1, nlevage if (patch_area_by_age(ipa2) .gt. nearzero) then - hio_gpp_si_age(io_si, ipa2) = & - hio_gpp_si_age(io_si, ipa2) / (patch_area_by_age(ipa2)) - hio_npp_si_age(io_si, ipa2) = & - hio_npp_si_age(io_si, ipa2) / (patch_area_by_age(ipa2)) + hio_gpp_si_age(io_si, ipa2) = hio_gpp_si_age(io_si, ipa2) / (patch_area_by_age(ipa2)) + hio_npp_si_age(io_si, ipa2) = hio_npp_si_age(io_si, ipa2) / (patch_area_by_age(ipa2)) else hio_gpp_si_age(io_si, ipa2) = 0._r8 hio_npp_si_age(io_si, ipa2) = 0._r8 @@ -5132,11 +4841,20 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep end do - enddo do_sites ! site loop + ! Normalize resistance diagnostics + if ( sum(canopy_area_by_age(1:nlevage)) .gt. nearzero) then + hio_c_stomata_si(io_si) = hio_c_stomata_si(io_si) / sum(canopy_area_by_age(1:nlevage)) + hio_c_lblayer_si(io_si) = hio_c_lblayer_si(io_si) / sum(canopy_area_by_age(1:nlevage)) + else + hio_c_stomata_si(io_si) = 0._r8 + hio_c_lblayer_si(io_si) = 0._r8 + end if - end associate + enddo ! site loop + + end associate - end subroutine update_history_hifrq_multi +end subroutine update_history_hifrq ! ===================================================================================== @@ -6716,46 +6434,6 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_rad_error_si) - call this%set_history_var(vname='FATES_VIS_SOLVE_ERROR', units='-', & - long='mean two-stream solver error for VIS', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_vis_solve_err_si) - - call this%set_history_var(vname='FATES_NIR_SOLVE_ERROR', units='-', & - long='mean two-stream solver error for NIR', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_nir_solve_err_si) - - call this%set_history_var(vname='FATES_VIS_CONSV_ERROR', units='-', & - long='mean two-stream conservation error for VIS', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_vis_consv_err_si) - - call this%set_history_var(vname='FATES_NIR_CONSV_ERROR', units='-', & - long='mean two-stream conservation error for NIR', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_nir_consv_err_si) - - call this%set_history_var(vname='FATES_VIS_SOLVE_ERROR_AGE', units='-', & - long='mean two-stream solver error for VIS by patch age', use_default='active', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_vis_solve_err_age_si) - - call this%set_history_var(vname='FATES_NIR_SOLVE_ERROR_AGE', units='-', & - long='mean two-stream solver error for NIR by patch age', use_default='active', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_nir_solve_err_age_si) - - call this%set_history_var(vname='FATES_VIS_CONSV_ERROR_AGE', units='-', & - long='mean two-stream conservation error for VIS by patch age', use_default='active', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_vis_consv_err_age_si) - - call this%set_history_var(vname='FATES_NIR_CONSV_ERROR_AGE', units='-', & - long='mean two-stream conservation error for NIR by patch age', use_default='active', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_nir_consv_err_age_si) - call this%set_history_var(vname='FATES_AR', units='gC/m^2/s', & long='autotrophic respiration', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & @@ -6825,7 +6503,7 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FATES_MAINT_RESP_UNREDUCED', units='kg m-2 s-1', & long='diagnostic maintenance respiration if the low-carbon-storage reduction is ignored', & - use_default='unactive', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + use_default='inactive', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_maint_resp_unreduced_si) @@ -6841,17 +6519,37 @@ subroutine define_history_vars(this, initialize_variables) upfreq=5, ivar=ivar, initialize=initialize_variables, & index = ih_excess_resp_si) - + ! Canopy resistance + call this%set_history_var(vname='FATES_STOMATAL_COND_AP', & + units='mol m-2 s-1', long='mean stomatal conductance - by patch age', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_c_stomata_si_age) call this%set_history_var(vname='FATES_AR_CANOPY', units='gC/m^2/s', & long='autotrophic respiration of canopy plants', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_ar_canopy_si ) - + call this%set_history_var(vname='FATES_LBLAYER_COND_AP', & + units='mol m-2 s-1', & + long='mean leaf boundary layer conductance - by patch age', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_c_lblayer_si_age) ! fast fluxes by age bin + call this%set_history_var(vname='FATES_NPP_AP', units='kg m-2 s-1', & + long='net primary productivity by age bin in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_si_age) + call this%set_history_var(vname='FATES_GPP_AP', units='kg m-2 s-1', & + long='gross primary productivity by age bin in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_gpp_si_age) call this%set_history_var(vname='FATES_AR_UNDERSTORY', units='gC/m^2/s', & long='autotrophic respiration of understory plants', use_default='active', & @@ -6886,302 +6584,196 @@ subroutine define_history_vars(this, initialize_variables) upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_ar_understory_si) + ! fast radiative fluxes resolved through the canopy + + call this%set_history_var(vname='FATES_PARSUN_Z_CLLL', units='W m-2', & + long='PAR absorbed in the sun by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_parsun_z_si_cnlf) + + call this%set_history_var(vname='FATES_PARSHA_Z_CLLL', units='W m-2', & + long='PAR absorbed in the shade by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_parsha_z_si_cnlf) + + call this%set_history_var(vname='FATES_PARSUN_Z_CLLLPF', units='W m-2', & + long='PAR absorbed in the sun by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parsun_z_si_cnlfpft) + + call this%set_history_var(vname='FATES_PARSHA_Z_CLLLPF', units='W m-2', & + long='PAR absorbed in the shade by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parsha_z_si_cnlfpft) + + call this%set_history_var(vname='FATES_PARSUN_Z_CL', units='W m-2', & + long='PAR absorbed in the sun by top leaf layer in each canopy layer', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parsun_top_si_can ) + + call this%set_history_var(vname='FATES_PARSHA_Z_CL', units='W m-2', & + long='PAR absorbed in the shade by top leaf layer in each canopy layer', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parsha_top_si_can) + + call this%set_history_var(vname='FATES_LAISUN_Z_CLLL', units='m2 m-2', & + long='LAI in the sun by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisun_z_si_cnlf) + + call this%set_history_var(vname='FATES_LAISHA_Z_CLLL', units='m2 m-2', & + long='LAI in the shade by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisha_z_si_cnlf) + + call this%set_history_var(vname='FATES_LAISUN_Z_CLLLPF', units='m2 m-2', & + long='LAI in the sun by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisun_z_si_cnlfpft) + + call this%set_history_var(vname='FATES_LAISHA_Z_CLLLPF', units='m2 m-2', & + long='LAI in the shade by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisha_z_si_cnlfpft) + + call this%set_history_var(vname='FATES_LAISUN_TOP_CL', units='m2 m-2', & + long='LAI in the sun by the top leaf layer of each canopy layer', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisun_top_si_can) + + call this%set_history_var(vname='FATES_LAISHA_TOP_CL', units='m2 m-2', & + long='LAI in the shade by the top leaf layer of each canopy layer', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisha_top_si_can) + + call this%set_history_var(vname='FATES_FABD_SUN_CLLLPF', units='1', & + long='sun fraction of direct light absorbed by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sun_si_cnlfpft) + + call this%set_history_var(vname='FATES_FABD_SHA_CLLLPF', units='1', & + long='shade fraction of direct light absorbed by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sha_si_cnlfpft) + + call this%set_history_var(vname='FATES_FABI_SUN_CLLLPF', units='1', & + long='sun fraction of indirect light absorbed by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sun_si_cnlfpft) + + call this%set_history_var(vname='FATES_FABI_SHA_CLLLPF', units='1', & + long='shade fraction of indirect light absorbed by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sha_si_cnlfpft) + + call this%set_history_var(vname='FATES_FABD_SUN_CLLL', units='1', & + long='sun fraction of direct light absorbed by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sun_si_cnlf) + + call this%set_history_var(vname='FATES_FABD_SHA_CLLL', units='1', & + long='shade fraction of direct light absorbed by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sha_si_cnlf) + + call this%set_history_var(vname='FATES_FABI_SUN_CLLL', units='1', & + long='sun fraction of indirect light absorbed by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sun_si_cnlf) + + call this%set_history_var(vname='FATES_FABI_SHA_CLLL', units='1', & + long='shade fraction of indirect light absorbed by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sha_si_cnlf) + + call this%set_history_var(vname='FATES_PARPROF_DIR_CLLLPF', units='W m-2', & + long='radiative profile of direct PAR through each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parprof_dir_si_cnlfpft) + + call this%set_history_var(vname='FATES_PARPROF_DIF_CLLLPF', units='W m-2', & + long='radiative profile of diffuse PAR through each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parprof_dif_si_cnlfpft) + + call this%set_history_var(vname='FATES_PARPROF_DIR_CLLL', units='W m-2', & + long='radiative profile of direct PAR through each canopy and leaf layer (averaged across PFTs)', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parprof_dir_si_cnlf) + + call this%set_history_var(vname='FATES_PARPROF_DIF_CLLL', units='W m-2', & + long='radiative profile of diffuse PAR through each canopy and leaf layer (averaged across PFTs)', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parprof_dif_si_cnlf) + + call this%set_history_var(vname='FATES_FABD_SUN_TOPLF_CL', units='1', & + long='sun fraction of direct light absorbed by the top leaf layer of each canopy layer', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sun_top_si_can) + + call this%set_history_var(vname='FATES_FABD_SHA_TOPLF_CL', units='1', & + long='shade fraction of direct light absorbed by the top leaf layer of each canopy layer', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sha_top_si_can) + + call this%set_history_var(vname='FATES_FABI_SUN_TOPLF_CL', units='1', & + long='sun fraction of indirect light absorbed by the top leaf layer of each canopy layer', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sun_top_si_can) + + call this%set_history_var(vname='FATES_FABI_SHA_TOPLF_CL', units='1', & + long='shade fraction of indirect light absorbed by the top leaf layer of each canopy layer', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sha_top_si_can) + + !!! canopy-resolved fluxes and structure + + call this%set_history_var(vname='FATES_NET_C_UPTAKE_CLLL', & + units='kg m-2 s-1', & + long='net carbon uptake in kg carbon per m2 per second by each canopy and leaf layer per unit ground area (i.e. divide by CROWNAREA_CLLL to make per leaf area)', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_ts_net_uptake_si_cnlf) + + call this%set_history_var(vname='FATES_CROWNAREA_CLLL', units='m2 m-2', & + long='total crown area that is occupied by leaves in each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_crownarea_si_cnlf) + + call this%set_history_var(vname='FATES_CROWNAREA_CL', units='m2 m-2', & + long='total crown area in each canopy layer', use_default='active', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_crownarea_si_can) - ! This next group are multidimensional variables that are updated - ! over the short timestep. We turn off these variables when we want - ! to save time (and some space) - - if_include_hifr_multi: if (hio_include_hifr_multi) then - - call this%set_history_var(vname='FATES_NPP_AP', units='kg m-2 s-1', & - long='net primary productivity by age bin in kg carbon per m2 per second', & - use_default='inactive', avgflag='A', vtype=site_age_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_npp_si_age) - - call this%set_history_var(vname='FATES_GPP_AP', units='kg m-2 s-1', & - long='gross primary productivity by age bin in kg carbon per m2 per second', & - use_default='inactive', avgflag='A', vtype=site_age_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_gpp_si_age) - - call this%set_history_var(vname='FATES_RDARK_USTORY_SZ', & - units = 'kg m-2 s-1', & - long='dark respiration for understory plants in kg carbon per m2 per second by size', & - use_default='inactive', avgflag='A', vtype=site_size_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, index = ih_rdark_understory_si_scls) - - call this%set_history_var(vname='FATES_LSTEMMAINTAR_USTORY_SZ', & - units = 'kg m-2 s-1', & - long='live stem maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & - use_default='inactive', avgflag='A', vtype=site_size_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, & - index = ih_livestem_mr_understory_si_scls) - - call this%set_history_var(vname='FATES_CROOTMAINTAR_USTORY_SZ', & - units = 'kg m-2 s-1', & - long='live coarse root maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & - use_default='inactive', avgflag='A', vtype=site_size_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, & - index = ih_livecroot_mr_understory_si_scls) - - call this%set_history_var(vname='FATES_FROOTMAINTAR_USTORY_SZ', & - units = 'kg m-2 s-1', & - long='fine root maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & - use_default='inactive', avgflag='A', vtype=site_size_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, & - index = ih_froot_mr_understory_si_scls) - - call this%set_history_var(vname='FATES_GROWAR_USTORY_SZ', & - units = 'kg m-2 s-1', & - long='growth autotrophic respiration of understory plants in kg carbon per m2 per second by size', & - use_default='inactive', avgflag='A', vtype=site_size_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, index = ih_resp_g_understory_si_scls) - - call this%set_history_var(vname='FATES_MAINTAR_USTORY_SZ', & - units = 'kg m-2 s-1', & - long='maintenance autotrophic respiration of understory plants in kg carbon per m2 per second by size', & - use_default='inactive', avgflag='A', vtype=site_size_r8, & - hlms='CLM:ALM', & - upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_resp_m_understory_si_scls) - - call this%set_history_var(vname='FATES_RDARK_CANOPY_SZ', & - units = 'kg m-2 s-1', & - long='dark respiration for canopy plants in kg carbon per m2 per second by size', & - use_default='inactive', avgflag='A', vtype=site_size_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, index = ih_rdark_canopy_si_scls) - - call this%set_history_var(vname='FATES_CROOTMAINTAR_CANOPY_SZ', & - units = 'kg m-2 s-1', & - long='live coarse root maintenance autotrophic respiration for canopy plants in kg carbon per m2 per second by size', & - use_default='inactive', avgflag='A', vtype=site_size_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, & - index = ih_livecroot_mr_canopy_si_scls) - - call this%set_history_var(vname='FATES_FROOTMAINTAR_CANOPY_SZ', & - units = 'kg m-2 s-1', & - long='live coarse root maintenance autotrophic respiration for canopy plants in kg carbon per m2 per second by size', & - use_default='inactive', avgflag='A', vtype=site_size_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, index = ih_froot_mr_canopy_si_scls) - - call this%set_history_var(vname='FATES_GROWAR_CANOPY_SZ', & - units = 'kg m-2 s-1', & - long='growth autotrophic respiration of canopy plants in kg carbon per m2 per second by size', & - use_default='inactive', avgflag='A', vtype=site_size_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, index = ih_resp_g_canopy_si_scls) - - call this%set_history_var(vname='FATES_MAINTAR_CANOPY_SZ', & - units = 'kg m-2 s-1', & - long='maintenance autotrophic respiration of canopy plants in kg carbon per m2 per second by size', & - use_default='inactive', avgflag='A', vtype=site_size_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, index = ih_resp_m_canopy_si_scls) - - call this%set_history_var(vname='FATES_LSTEMMAINTAR_CANOPY_SZ', & - units = 'kg m-2 s-1', & - long='live stem maintenance autotrophic respiration for canopy plants in kg carbon per m2 per second by size', & - use_default='inactive', avgflag='A', vtype=site_size_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, & - index = ih_livestem_mr_canopy_si_scls) - - call this%set_history_var(vname='FATES_AUTORESP_SZPF', & - units = 'kg m-2 s-1', & - long='total autotrophic respiration in kg carbon per m2 per second by pft/size', & - use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, index = ih_ar_si_scpf) - - call this%set_history_var(vname='FATES_GROWAR_SZPF', & - units = 'kg m-2 s-1', & - long='growth autotrophic respiration in kg carbon per m2 per second by pft/size', & - use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, index = ih_ar_grow_si_scpf) - - call this%set_history_var(vname='FATES_MAINTAR_SZPF', & - units = 'kg m-2 s-1', & - long='maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & - use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, index = ih_ar_maint_si_scpf) - - call this%set_history_var(vname='FATES_RDARK_SZPF', & - units = 'kg m-2 s-1', & - long='dark portion of maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & - use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, index = ih_ar_darkm_si_scpf) - - call this%set_history_var(vname='FATES_AGSAPMAINTAR_SZPF', & - units = 'kg m-2 s-1', & - long='above-ground sapwood maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & - use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, index = ih_ar_agsapm_si_scpf) - - call this%set_history_var(vname='FATES_BGSAPMAINTAR_SZPF', & - units = 'kg m-2 s-1', & - long='below-ground sapwood maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & - use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, index = ih_ar_crootm_si_scpf) - - call this%set_history_var(vname='FATES_FROOTMAINTAR_SZPF', & - units = 'kg m-2 s-1', & - long='fine root maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & - use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, index = ih_ar_frootm_si_scpf) - - call this%set_history_var(vname='FATES_PARSUN_CLLL', units='W m-2', & - long='PAR absorbed in the sun by each canopy and leaf layer', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, index = ih_parsun_z_si_cnlf) - - call this%set_history_var(vname='FATES_PARSHA_CLLL', units='W m-2', & - long='PAR absorbed in the shade by each canopy and leaf layer', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, index = ih_parsha_z_si_cnlf) - - call this%set_history_var(vname='FATES_PARSUN_CLLLPF', units='W m-2', & - long='PAR absorbed in the sun by each canopy, leaf, and PFT', & - use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_parsun_z_si_cnlfpft) - - call this%set_history_var(vname='FATES_PARSHA_CLLLPF', units='W m-2', & - long='PAR absorbed in the shade by each canopy, leaf, and PFT', & - use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_parsha_z_si_cnlfpft) - - call this%set_history_var(vname='FATES_PARSUN_CL', units='W m-2', & - long='PAR absorbed by sunlit leaves in each canopy layer', & - use_default='inactive', avgflag='A', vtype=site_can_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_parsun_si_can ) - - call this%set_history_var(vname='FATES_PARSHA_CL', units='W m-2', & - long='PAR absorbed by shaded leaves in each canopy layer', & - use_default='inactive', avgflag='A', vtype=site_can_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_parsha_si_can) - - call this%set_history_var(vname='FATES_LAISUN_CLLL', units='m2 m-2', & - long='LAI in the sun by each canopy and leaf layer', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_laisun_z_si_cnlf) - - call this%set_history_var(vname='FATES_LAISHA_CLLL', units='m2 m-2', & - long='LAI in the shade by each canopy and leaf layer', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_laisha_z_si_cnlf) - - call this%set_history_var(vname='FATES_LAISUN_CLLLPF', units='m2 m-2', & - long='Sunlit leaf area by each canopy, leaf, and PFT', & - use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_laisun_clllpf) - - call this%set_history_var(vname='FATES_LAISHA_CLLLPF', units='m2 m-2', & - long='Shaded leaf area by each canopy, leaf, and PFT', & - use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_laisha_clllpf) - - call this%set_history_var(vname='FATES_PARPROF_DIR_CLLLPF', units='W m-2', & - long='radiative profile of direct PAR through each canopy, leaf, and PFT', & - use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_parprof_dir_si_cnlfpft) - - call this%set_history_var(vname='FATES_PARPROF_DIF_CLLLPF', units='W m-2', & - long='radiative profile of diffuse PAR through each canopy, leaf, and PFT', & - use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_parprof_dif_si_cnlfpft) - - call this%set_history_var(vname='FATES_LAISUN_CL', units='m2 m-2', & - long='LAI of sunlit leaves by canopy layer', & - use_default='inactive', avgflag='A', vtype=site_can_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_laisun_si_can) - - call this%set_history_var(vname='FATES_LAISHA_CL', units='m2 m-2', & - long='LAI of shaded leaves by canopy layer', & - use_default='inactive', avgflag='A', vtype=site_can_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_laisha_si_can) - - call this%set_history_var(vname='FATES_PARPROF_DIR_CLLL', units='W m-2', & - long='radiative profile of direct PAR through each canopy and leaf layer (averaged across PFTs)', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_parprof_dir_si_cnlf) - - call this%set_history_var(vname='FATES_PARPROF_DIF_CLLL', units='W m-2', & - long='radiative profile of diffuse PAR through each canopy and leaf layer (averaged across PFTs)', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_parprof_dif_si_cnlf) - - ! canopy-resolved fluxes and structure - - call this%set_history_var(vname='FATES_NET_C_UPTAKE_CLLL', & - units='kg m-2 s-1', & - long='net carbon uptake in kg carbon per m2 per second by each canopy and leaf layer per unit ground area (i.e. divide by CROWNAREA_CLLL to make per leaf area)', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_ts_net_uptake_si_cnlf) - - call this%set_history_var(vname='FATES_CROWNFRAC_CLLLPF', units='m2 m-2', & - long='area fraction of the canopy footprint occupied by each canopy-leaf-pft layer', & - use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_crownfrac_clllpf) - - call this%set_history_var(vname='FATES_LBLAYER_COND_AP', & - units='mol m-2 s-1', & - long='mean leaf boundary layer conductance - by patch age', & - use_default='inactive', avgflag='A', vtype=site_age_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, & - initialize=initialize_variables, index = ih_c_lblayer_si_age) - - ! Canopy resistance - call this%set_history_var(vname='FATES_STOMATAL_COND_AP', & - units='mol m-2 s-1', long='mean stomatal conductance - by patch age', & - use_default='inactive', avgflag='A', vtype=site_age_r8, & - hlms='CLM:ALM', upfreq=upfreq_hifr_multi, ivar=ivar, initialize=initialize_variables, & - index = ih_c_stomata_si_age) - - end if if_include_hifr_multi - - call this%set_history_var(vname='FATES_CROWNAREA_CLLL', units='m2 m-2', & - long='area fraction of the total ground occupied by each canopy-leaf layer', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_crownarea_si_cnlf) - - call this%set_history_var(vname='FATES_CROWNAREA_CL', units='m2 m-2', & - long='area fraction of the canopy footprint occupied by each canopy-leaf layer', use_default='active', & - avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_crownarea_cl) - ! slow carbon fluxes associated with mortality from or transfer betweeen canopy and understory call this%set_history_var(vname='FATES_DEMOTION_CARBONFLUX', & @@ -7717,6 +7309,56 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_cwd_bg_out_si_cwdsc) + ! Size structured diagnostics that require rapid updates (upfreq=2) + + call this%set_history_var(vname='FATES_AUTORESP_SZPF', & + units = 'kg m-2 s-1', & + long='total autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_si_scpf) + + call this%set_history_var(vname='FATES_GROWAR_SZPF', & + units = 'kg m-2 s-1', & + long='growth autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_grow_si_scpf) + + call this%set_history_var(vname='FATES_MAINTAR_SZPF', & + units = 'kg m-2 s-1', & + long='maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_maint_si_scpf) + + call this%set_history_var(vname='FATES_RDARK_SZPF', & + units = 'kg m-2 s-1', & + long='dark portion of maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_darkm_si_scpf) + + call this%set_history_var(vname='FATES_AGSAPMAINTAR_SZPF', & + units = 'kg m-2 s-1', & + long='above-ground sapwood maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_agsapm_si_scpf) + + call this%set_history_var(vname='FATES_BGSAPMAINTAR_SZPF', & + units = 'kg m-2 s-1', & + long='below-ground sapwood maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_crootm_si_scpf) + + call this%set_history_var(vname='FATES_FROOTMAINTAR_SZPF', & + units = 'kg m-2 s-1', & + long='fine root maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_frootm_si_scpf) ! size-class only variables @@ -8145,11 +7787,49 @@ subroutine define_history_vars(this, initialize_variables) upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_livestem_mr_si) - + call this%set_history_var(vname='FATES_RDARK_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='dark respiration for canopy plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_rdark_canopy_si_scls) - + call this%set_history_var(vname='FATES_LSTEMMAINTAR_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='live stem maintenance autotrophic respiration for canopy plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, & + index = ih_livestem_mr_canopy_si_scls) + + call this%set_history_var(vname='FATES_CROOTMAINTAR_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='live coarse root maintenance autotrophic respiration for canopy plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, & + index = ih_livecroot_mr_canopy_si_scls) + call this%set_history_var(vname='FATES_FROOTMAINTAR_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='live coarse root maintenance autotrophic respiration for canopy plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_froot_mr_canopy_si_scls) + + call this%set_history_var(vname='FATES_GROWAR_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='growth autotrophic respiration of canopy plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_resp_g_canopy_si_scls) + call this%set_history_var(vname='FATES_MAINTAR_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='maintenance autotrophic respiration of canopy plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_resp_m_canopy_si_scls) call this%set_history_var(vname='FATES_LEAFCTURN_USTORY_SZ', & units = 'kg m-2 s-1', & @@ -8240,12 +7920,56 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_stor_understory_si_scls) + call this%set_history_var(vname='FATES_RDARK_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='dark respiration for understory plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_rdark_understory_si_scls) + call this%set_history_var(vname='FATES_LSTEMMAINTAR_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='live stem maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, & + index = ih_livestem_mr_understory_si_scls) + + call this%set_history_var(vname='FATES_CROOTMAINTAR_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='live coarse root maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, & + index = ih_livecroot_mr_understory_si_scls) + + call this%set_history_var(vname='FATES_FROOTMAINTAR_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='fine root maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, & + index = ih_froot_mr_understory_si_scls) + + call this%set_history_var(vname='FATES_GROWAR_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='growth autotrophic respiration of understory plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_resp_g_understory_si_scls) + + call this%set_history_var(vname='FATES_MAINTAR_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='maintenance autotrophic respiration of understory plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_resp_m_understory_si_scls) ! CROWN DAMAGE VARIABLES if_crowndamage: if(hlm_use_tree_damage .eq. itrue) then - + call this%set_history_var(vname='FATES_CROWNAREA_CANOPY_CD', units = 'm2 m-2 yr-1', & long='crownarea lost to damage each year', use_default='inactive', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', & From da541747b371a2b5bf2c37bbd01ee90ba1a7831a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 8 Dec 2023 12:14:23 -0500 Subject: [PATCH 213/250] attempts to revert history code in 2str to get b4b --- main/FatesHistoryInterfaceMod.F90 | 149 +++++------------------------- 1 file changed, 25 insertions(+), 124 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index c530656bda..95b7530ef3 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -680,10 +680,6 @@ module FatesHistoryInterfaceMod integer :: ih_parsha_z_si_cnlf integer :: ih_laisun_z_si_cnlf integer :: ih_laisha_z_si_cnlf - integer :: ih_fabd_sun_si_cnlf - integer :: ih_fabd_sha_si_cnlf - integer :: ih_fabi_sun_si_cnlf - integer :: ih_fabi_sha_si_cnlf integer :: ih_ts_net_uptake_si_cnlf integer :: ih_crownarea_si_cnlf integer :: ih_parprof_dir_si_cnlf @@ -694,10 +690,6 @@ module FatesHistoryInterfaceMod integer :: ih_parsha_z_si_cnlfpft integer :: ih_laisun_z_si_cnlfpft integer :: ih_laisha_z_si_cnlfpft - integer :: ih_fabd_sun_si_cnlfpft - integer :: ih_fabd_sha_si_cnlfpft - integer :: ih_fabi_sun_si_cnlfpft - integer :: ih_fabi_sha_si_cnlfpft integer :: ih_parprof_dir_si_cnlfpft integer :: ih_parprof_dif_si_cnlfpft @@ -729,10 +721,6 @@ module FatesHistoryInterfaceMod integer :: ih_parsha_top_si_can integer :: ih_laisun_top_si_can integer :: ih_laisha_top_si_can - integer :: ih_fabd_sun_top_si_can - integer :: ih_fabd_sha_top_si_can - integer :: ih_fabi_sun_top_si_can - integer :: ih_fabi_sha_top_si_can integer :: ih_crownarea_si_can ! indices to (patch age x fuel size class) variables @@ -780,7 +768,8 @@ module FatesHistoryInterfaceMod procedure :: assemble_history_output_types procedure :: update_history_dyn - procedure :: update_history_hifrq + procedure :: update_history_hifrq_simple + procedure :: update_history_hifrq_multi procedure :: update_history_hydraulics procedure :: update_history_nutrflux @@ -4386,7 +4375,23 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) return end subroutine update_history_dyn - subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) + subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,dt_tstep) + ! + ! Arguments + class(fates_history_interface_type) :: this + integer , intent(in) :: nc ! clump index + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type) , intent(in) :: bc_in(nsites) + real(r8) , intent(in) :: dt_tstep + + ! This is just a dummy file for compatibility + + return + end subroutine update_history_hifrq_multi + + + subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,dt_tstep) ! --------------------------------------------------------------------------------- ! This is the call to update the history IO arrays that are expected to only change @@ -4481,22 +4486,10 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_laisha_z_si_cnlfpft => this%hvars(ih_laisha_z_si_cnlfpft)%r82d, & hio_laisun_top_si_can => this%hvars(ih_laisun_top_si_can)%r82d, & hio_laisha_top_si_can => this%hvars(ih_laisha_top_si_can)%r82d, & - hio_fabd_sun_si_cnlfpft => this%hvars(ih_fabd_sun_si_cnlfpft)%r82d, & - hio_fabd_sha_si_cnlfpft => this%hvars(ih_fabd_sha_si_cnlfpft)%r82d, & - hio_fabi_sun_si_cnlfpft => this%hvars(ih_fabi_sun_si_cnlfpft)%r82d, & - hio_fabi_sha_si_cnlfpft => this%hvars(ih_fabi_sha_si_cnlfpft)%r82d, & - hio_fabd_sun_si_cnlf => this%hvars(ih_fabd_sun_si_cnlf)%r82d, & - hio_fabd_sha_si_cnlf => this%hvars(ih_fabd_sha_si_cnlf)%r82d, & - hio_fabi_sun_si_cnlf => this%hvars(ih_fabi_sun_si_cnlf)%r82d, & - hio_fabi_sha_si_cnlf => this%hvars(ih_fabi_sha_si_cnlf)%r82d, & hio_parprof_dir_si_cnlf => this%hvars(ih_parprof_dir_si_cnlf)%r82d, & hio_parprof_dif_si_cnlf => this%hvars(ih_parprof_dif_si_cnlf)%r82d, & hio_parprof_dir_si_cnlfpft => this%hvars(ih_parprof_dir_si_cnlfpft)%r82d, & hio_parprof_dif_si_cnlfpft => this%hvars(ih_parprof_dif_si_cnlfpft)%r82d, & - hio_fabd_sun_top_si_can => this%hvars(ih_fabd_sun_top_si_can)%r82d, & - hio_fabd_sha_top_si_can => this%hvars(ih_fabd_sha_top_si_can)%r82d, & - hio_fabi_sun_top_si_can => this%hvars(ih_fabi_sun_top_si_can)%r82d, & - hio_fabi_sha_top_si_can => this%hvars(ih_fabi_sha_top_si_can)%r82d, & hio_parsun_top_si_can => this%hvars(ih_parsun_top_si_can)%r82d, & hio_parsha_top_si_can => this%hvars(ih_parsha_top_si_can)%r82d, & hio_maint_resp_unreduced_si => this%hvars(ih_maint_resp_unreduced_si)%r81d, & @@ -4740,15 +4733,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV hio_laisha_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_laisha_z_si_cnlfpft(io_si,cnlfpft_indx) + & cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - ! - hio_fabd_sun_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabd_sun_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_fabd_sha_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabd_sha_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_fabi_sun_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabi_sun_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_fabi_sha_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabi_sha_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + ! hio_parprof_dir_si_cnlfpft(io_si,cnlfpft_indx) = hio_parprof_dir_si_cnlfpft(io_si,cnlfpft_indx) + & cpatch%parprof_pft_dir_z(ican,ipft,ileaf) * cpatch%area * AREA_INV @@ -4766,14 +4751,6 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_laisha_z_si_cnlf(io_si,cnlf_indx) = hio_laisha_z_si_cnlf(io_si,cnlf_indx) + & cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV ! - hio_fabd_sun_si_cnlf(io_si,cnlf_indx) = hio_fabd_sun_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_fabd_sha_si_cnlf(io_si,cnlf_indx) = hio_fabd_sha_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_fabi_sun_si_cnlf(io_si,cnlf_indx) = hio_fabi_sun_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_fabi_sha_si_cnlf(io_si,cnlf_indx) = hio_fabi_sha_si_cnlf(io_si,cnlf_indx) + & - cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV end do ! @@ -4788,14 +4765,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_laisha_top_si_can(io_si,ican) = hio_laisha_top_si_can(io_si,ican) + & cpatch%ed_laisha_z(ican,ipft,1) * cpatch%area * AREA_INV ! - hio_fabd_sun_top_si_can(io_si,ican) = hio_fabd_sun_top_si_can(io_si,ican) + & - cpatch%fabd_sun_z(ican,ipft,1) * cpatch%area * AREA_INV - hio_fabd_sha_top_si_can(io_si,ican) = hio_fabd_sha_top_si_can(io_si,ican) + & - cpatch%fabd_sha_z(ican,ipft,1) * cpatch%area * AREA_INV - hio_fabi_sun_top_si_can(io_si,ican) = hio_fabi_sun_top_si_can(io_si,ican) + & - cpatch%fabi_sun_z(ican,ipft,1) * cpatch%area * AREA_INV - hio_fabi_sha_top_si_can(io_si,ican) = hio_fabi_sha_top_si_can(io_si,ican) + & - cpatch%fabi_sha_z(ican,ipft,1) * cpatch%area * AREA_INV + ! end do end do @@ -4854,8 +4824,11 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) end associate -end subroutine update_history_hifrq + end subroutine update_history_hifrq_simple + + + ! ===================================================================================== subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) @@ -6658,54 +6631,6 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_laisha_top_si_can) - call this%set_history_var(vname='FATES_FABD_SUN_CLLLPF', units='1', & - long='sun fraction of direct light absorbed by each canopy, leaf, and PFT', & - use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_fabd_sun_si_cnlfpft) - - call this%set_history_var(vname='FATES_FABD_SHA_CLLLPF', units='1', & - long='shade fraction of direct light absorbed by each canopy, leaf, and PFT', & - use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_fabd_sha_si_cnlfpft) - - call this%set_history_var(vname='FATES_FABI_SUN_CLLLPF', units='1', & - long='sun fraction of indirect light absorbed by each canopy, leaf, and PFT', & - use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_fabi_sun_si_cnlfpft) - - call this%set_history_var(vname='FATES_FABI_SHA_CLLLPF', units='1', & - long='shade fraction of indirect light absorbed by each canopy, leaf, and PFT', & - use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_fabi_sha_si_cnlfpft) - - call this%set_history_var(vname='FATES_FABD_SUN_CLLL', units='1', & - long='sun fraction of direct light absorbed by each canopy and leaf layer', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_fabd_sun_si_cnlf) - - call this%set_history_var(vname='FATES_FABD_SHA_CLLL', units='1', & - long='shade fraction of direct light absorbed by each canopy and leaf layer', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_fabd_sha_si_cnlf) - - call this%set_history_var(vname='FATES_FABI_SUN_CLLL', units='1', & - long='sun fraction of indirect light absorbed by each canopy and leaf layer', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_fabi_sun_si_cnlf) - - call this%set_history_var(vname='FATES_FABI_SHA_CLLL', units='1', & - long='shade fraction of indirect light absorbed by each canopy and leaf layer', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_fabi_sha_si_cnlf) - call this%set_history_var(vname='FATES_PARPROF_DIR_CLLLPF', units='W m-2', & long='radiative profile of direct PAR through each canopy, leaf, and PFT', & use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & @@ -6730,30 +6655,6 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_parprof_dif_si_cnlf) - call this%set_history_var(vname='FATES_FABD_SUN_TOPLF_CL', units='1', & - long='sun fraction of direct light absorbed by the top leaf layer of each canopy layer', & - use_default='inactive', avgflag='A', vtype=site_can_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_fabd_sun_top_si_can) - - call this%set_history_var(vname='FATES_FABD_SHA_TOPLF_CL', units='1', & - long='shade fraction of direct light absorbed by the top leaf layer of each canopy layer', & - use_default='inactive', avgflag='A', vtype=site_can_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_fabd_sha_top_si_can) - - call this%set_history_var(vname='FATES_FABI_SUN_TOPLF_CL', units='1', & - long='sun fraction of indirect light absorbed by the top leaf layer of each canopy layer', & - use_default='inactive', avgflag='A', vtype=site_can_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_fabi_sun_top_si_can) - - call this%set_history_var(vname='FATES_FABI_SHA_TOPLF_CL', units='1', & - long='shade fraction of indirect light absorbed by the top leaf layer of each canopy layer', & - use_default='inactive', avgflag='A', vtype=site_can_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_fabi_sha_top_si_can) - !!! canopy-resolved fluxes and structure call this%set_history_var(vname='FATES_NET_C_UPTAKE_CLLL', & From 1df494acd0d47ea7de4b581ac4f686f0a133a308 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 12 Dec 2023 11:30:34 -0500 Subject: [PATCH 214/250] small b4b changes to two-stream --- biogeochem/EDCanopyStructureMod.F90 | 2 +- radiation/FatesRadiationDriveMod.F90 | 61 ++++++++++++++-------------- 2 files changed, 32 insertions(+), 31 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index bada4ab8a2..46b219e583 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1709,7 +1709,7 @@ subroutine leaf_area_profile( currentSite ) currentPatch%canopy_mask(:,:) = 0 do cl = 1,currentPatch%NCL_p do ft = 1,numpft - if(currentPatch%canopy_area_profile(cl,ft,1) > nearzero) currentPatch%canopy_mask(cl,ft) = 1 + if(currentPatch%canopy_area_profile(cl,ft,1) > 0._r8 ) currentPatch%canopy_mask(cl,ft) = 1 end do end do diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index ede4eeb65f..e52a7d624b 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -56,7 +56,8 @@ module FatesRadiationDriveMod character(len=*), parameter, private :: sourcefile = & __FILE__ - + logical :: preserve_b4b = .true. + contains subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) @@ -101,28 +102,28 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) - ! Zero diagnostics - currentPatch%f_sun (:,:,:) = 0._r8 - currentPatch%fabd_sun_z (:,:,:) = 0._r8 - currentPatch%fabd_sha_z (:,:,:) = 0._r8 - currentPatch%fabi_sun_z (:,:,:) = 0._r8 - currentPatch%fabi_sha_z (:,:,:) = 0._r8 - currentPatch%fabd (:) = 0._r8 - currentPatch%fabi (:) = 0._r8 - currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 - - currentPatch%solve_err(:) = hlm_hio_ignore_val - currentPatch%consv_err(:) = hlm_hio_ignore_val - - !cpatch%ed_parsun_z(ican,ipft,ileaf) - + ! do not do albedo calculations for bare ground patch in SP mode + ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein + ! ifp=1 is the first vegetated patch. + if_notbareground: if(currentpatch%nocomp_pft_label.ne.nocomp_bareground)then - ! do not do albedo calculations for bare ground patch in SP mode - ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein - ! ifp=1 is the first vegetated patch. - ifp = ifp+1 + ipf = ipf+1 + + ! Zero diagnostics + currentPatch%f_sun (:,:,:) = 0._r8 + currentPatch%fabd_sun_z (:,:,:) = 0._r8 + currentPatch%fabd_sha_z (:,:,:) = 0._r8 + currentPatch%fabi_sun_z (:,:,:) = 0._r8 + currentPatch%fabi_sha_z (:,:,:) = 0._r8 + currentPatch%fabd (:) = 0._r8 + currentPatch%fabi (:) = 0._r8 + currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 + + currentPatch%solve_err(:) = hlm_hio_ignore_val + currentPatch%consv_err(:) = hlm_hio_ignore_val + currentPatch%solar_zenith_flag = bc_in(s)%filter_vegzen_pa(ifp) currentPatch%solar_zenith_angle = bc_in(s)%coszen_pa(ifp) currentPatch%gnd_alb_dif(1:hlm_numSWb) = bc_in(s)%albgr_dif_rb(1:hlm_numSWb) @@ -141,15 +142,15 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) ! non-zero diffuse radiation when cosz<=0 ! Temporarily turn off to preserve b4b - - !!bc_out(s)%albd_parb(ifp,:) = 1._r8 - !!bc_out(s)%albi_parb(ifp,:) = 1._r8 - !!bc_out(s)%fabi_parb(ifp,:) = 0._r8 - !!bc_out(s)%fabd_parb(ifp,:) = 0._r8 - !!bc_out(s)%ftdd_parb(ifp,:) = 0._r8 - !!bc_out(s)%ftid_parb(ifp,:) = 0._r8 - !!bc_out(s)%ftii_parb(ifp,:) = 0._r8 - + if (.not.preserve_b4b) then + bc_out(s)%albd_parb(ifp,:) = 1._r8 + bc_out(s)%albi_parb(ifp,:) = 1._r8 + bc_out(s)%fabi_parb(ifp,:) = 0._r8 + bc_out(s)%fabd_parb(ifp,:) = 0._r8 + bc_out(s)%ftdd_parb(ifp,:) = 0._r8 + bc_out(s)%ftid_parb(ifp,:) = 0._r8 + bc_out(s)%ftii_parb(ifp,:) = 0._r8 + end if else bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM From 56aa3253205a74d5eab7af1fc189391627cd5965 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 12 Dec 2023 12:19:04 -0500 Subject: [PATCH 215/250] Creating seperate module for norman rad --- radiation/FatesNormanRadMod.F90 | 995 ++++++++++++++++++++++ radiation/FatesRadiationDriveMod.F90 | 1147 +++----------------------- 2 files changed, 1112 insertions(+), 1030 deletions(-) create mode 100644 radiation/FatesNormanRadMod.F90 diff --git a/radiation/FatesNormanRadMod.F90 b/radiation/FatesNormanRadMod.F90 new file mode 100644 index 0000000000..380331468f --- /dev/null +++ b/radiation/FatesNormanRadMod.F90 @@ -0,0 +1,995 @@ +module FatesNormanRadMod + + !------------------------------------------------------------------------------------- + ! EDSurfaceRadiation + ! + ! This module contains function and type definitions for all things related + ! to radiative transfer in ED modules at the land surface. + ! + !------------------------------------------------------------------------------------- + +#include "shr_assert.h" + + use EDTypesMod , only : ed_site_type + use FatesPatchMod, only : fates_patch_type + use EDParamsMod, only : maxpft + use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : itrue + use FatesConstantsMod , only : pi_const + use FatesConstantsMod , only : nocomp_bareground + use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : bc_out_type + use FatesInterfaceTypesMod , only : hlm_numSWb + use FatesInterfaceTypesMod , only : numpft + use EDParamsMod , only : maxSWb + use EDParamsMod , only : nclmax + use EDParamsMod , only : nlevleaf + use EDTypesMod , only : n_rad_stream_types + use EDTypesMod , only : idiffuse + use EDTypesMod , only : idirect + use EDParamsMod , only : ivis + use EDParamsMod , only : inir + use EDParamsMod , only : ipar + use EDCanopyStructureMod, only: calc_areaindex + use FatesGlobals , only : fates_log + use FatesGlobals, only : endrun => fates_endrun + use EDPftvarcon, only : EDPftvarcon_inst + + ! CIME globals + use shr_log_mod , only : errMsg => shr_log_errMsg + + implicit none + + private + public :: PatchNormanRadiation + + logical :: debug = .false. ! for debugging this module + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + ! real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + ! (/ 0.80_r8, 0.55_r8 /) + + !parameters of canopy snow reflectance model. + ! the parameters in the 2-stream model are not directly analagous to those here + ! and so they are stored here for now in common with the ice parameters above. + ! in principle these could be moved to the parameter file. + + real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + (/ 0.80_r8, 0.55_r8 /) + real(r8), public :: rho_snow(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + (/ 0.80_r8, 0.55_r8 /) + real(r8), public :: tau_snow(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + (/ 0.01_r8, 0.01_r8 /) +contains + + subroutine PatchNormanRadiation (currentPatch, & + albd_parb_out, & ! (ifp,ib) + albi_parb_out, & ! (ifp,ib) + fabd_parb_out, & ! (ifp,ib) + fabi_parb_out, & ! (ifp,ib) + ftdd_parb_out, & ! (ifp,ib) + ftid_parb_out, & ! (ifp,ib) + ftii_parb_out) ! (ifp,ib) + + ! ----------------------------------------------------------------------------------- + ! + ! This routine performs the Norman Radiation scattering for each patch. + ! + ! ----------------------------------------------------------------------------------- + + ! ----------------------------------------------------------------------------------- + ! !ARGUMENTS: + ! ----------------------------------------------------------------------------------- + + type(fates_patch_type), intent(inout), target :: currentPatch + real(r8), intent(inout) :: albd_parb_out(hlm_numSWb) + real(r8), intent(inout) :: albi_parb_out(hlm_numSWb) + real(r8), intent(inout) :: fabd_parb_out(hlm_numSWb) + real(r8), intent(inout) :: fabi_parb_out(hlm_numSWb) + real(r8), intent(inout) :: ftdd_parb_out(hlm_numSWb) + real(r8), intent(inout) :: ftid_parb_out(hlm_numSWb) + real(r8), intent(inout) :: ftii_parb_out(hlm_numSWb) + + ! Locals + ! ----------------------------------------------------------------------------------- + + integer :: radtype, L, ft, j + integer :: iter ! Iteration index + integer :: irep ! Flag to exit iteration loop + real(r8) :: sb + real(r8) :: error ! Error check + real(r8) :: down_rad, up_rad ! Iterative solution do Dif_dn and Dif_up + real(r8) :: ftweight(nclmax,maxpft,nlevleaf) + real(r8) :: k_dir(maxpft) ! Direct beam extinction coefficient + real(r8) :: tr_dir_z(nclmax,maxpft,nlevleaf) ! Exponential transmittance of direct beam radiation through a single layer + real(r8) :: tr_dif_z(nclmax,maxpft,nlevleaf) ! Exponential transmittance of diffuse radiation through a single layer + real(r8) :: weighted_dir_tr(nclmax) + real(r8) :: weighted_fsun(nclmax) + real(r8) :: weighted_dif_ratio(nclmax,maxSWb) + real(r8) :: weighted_dif_down(nclmax) + real(r8) :: weighted_dif_up(nclmax) + real(r8) :: refl_dif(nclmax,maxpft,nlevleaf,maxSWb) ! Term for diffuse radiation reflected by laye + real(r8) :: tran_dif(nclmax,maxpft,nlevleaf,maxSWb) ! Term for diffuse radiation transmitted by layer + real(r8) :: dif_ratio(nclmax,maxpft,nlevleaf,maxSWb) ! Ratio of upward to forward diffuse fluxes + real(r8) :: Dif_dn(nclmax,maxpft,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) + real(r8) :: Dif_up(nclmax,maxpft,nlevleaf) ! Upward diffuse flux above canopy layer J (W/m**2 ground area) + real(r8) :: lai_change(nclmax,maxpft,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) + + real(r8) :: frac_lai ! Fraction of lai in each layer + real(r8) :: frac_sai ! Fraction of sai in each layer + real(r8) :: f_abs(nclmax,maxpft,nlevleaf,maxSWb) ! Fraction of light absorbed by surfaces. + real(r8) :: rho_layer(nclmax,maxpft,nlevleaf,maxSWb)! Weighted verage reflectance of layer + real(r8) :: tau_layer(nclmax,maxpft,nlevleaf,maxSWb)! Weighted average transmittance of layer + real(r8) :: f_abs_leaf(nclmax,maxpft,nlevleaf,maxSWb) + real(r8) :: Abs_dir_z(maxpft,nlevleaf) + real(r8) :: Abs_dif_z(maxpft,nlevleaf) + real(r8) :: abs_rad(maxSWb) !radiation absorbed by soil + real(r8) :: tr_soili ! Radiation transmitted to the soil surface. + real(r8) :: tr_soild ! Radiation transmitted to the soil surface. + real(r8) :: phi1b(maxpft) ! Radiation transmitted to the soil surface. + real(r8) :: phi2b(maxpft) + real(r8) :: laisum ! cumulative lai+sai for canopy layer (at middle of layer) + real(r8) :: angle + + real(r8),parameter :: tolerance = 0.000000001_r8 + + + integer, parameter :: max_diag_nlevleaf = 4 + integer, parameter :: diag_nlevleaf = min(nlevleaf,max_diag_nlevleaf) ! for diagnostics, write a small number of leaf layers + + real(r8) :: denom + real(r8) :: lai_reduction(nclmax) + + integer :: fp,iv,s ! array indices + integer :: ib ! waveband number + real(r8) :: cosz ! 0.001 <= coszen <= 1.000 + real(r8) :: gdir + + + real(r8), parameter :: forc_dir(n_rad_stream_types) = (/ 1.0_r8, 0.0_r8 /) ! These are binary switches used + real(r8), parameter :: forc_dif(n_rad_stream_types) = (/ 0.0_r8, 1.0_r8 /) ! to turn off and on radiation streams + + + + associate(& + rhol => EDPftvarcon_inst%rhol , & ! Input: [real(r8) (:) ] leaf reflectance: 1=vis, 2=nir + rhos => EDPftvarcon_inst%rhos , & ! Input: [real(r8) (:) ] stem reflectance: 1=vis, 2=nir + taul => EDPftvarcon_inst%taul , & ! Input: [real(r8) (:) ] leaf transmittance: 1=vis, 2=nir + taus => EDPftvarcon_inst%taus , & ! Input: [real(r8) (:) ] stem transmittance: 1=vis, 2=nir + xl => EDPftvarcon_inst%xl , & ! Input: [real(r8) (:) ] ecophys const - leaf/stem orientation index + clumping_index => EDPftvarcon_inst%clumping_index) + + + + ! Initialize local arrays + + weighted_dir_tr(:) = 0._r8 + weighted_dif_down(:) = 0._r8 + weighted_dif_up(:) = 0._r8 + + tr_dir_z(:,:,:) = 0._r8 + tr_dif_z(:,:,:) = 0._r8 + lai_change(:,:,:) = 0._r8 + Dif_up(:,:,:) = 0._r8 + Dif_dn(:,:,:) = 0._r8 + refl_dif(:,:,:,:) = 0.0_r8 + tran_dif(:,:,:,:) = 0.0_r8 + dif_ratio(:,:,:,:) = 0.0_r8 + + + ! Initialize the ouput arrays + ! --------------------------------------------------------------------------------- + albd_parb_out(1:hlm_numSWb) = 0.0_r8 + albi_parb_out(1:hlm_numSWb) = 0.0_r8 + fabd_parb_out(1:hlm_numSWb) = 0.0_r8 + fabi_parb_out(1:hlm_numSWb) = 0.0_r8 + ftdd_parb_out(1:hlm_numSWb) = 1.0_r8 + ftid_parb_out(1:hlm_numSWb) = 1.0_r8 + ftii_parb_out(1:hlm_numSWb) = 1.0_r8 + + ! Is this pft/canopy layer combination present in this patch? + rho_layer(:,:,:,:)=0.0_r8 + tau_layer(:,:,:,:)=0.0_r8 + f_abs(:,:,:,:)=0.0_r8 + f_abs_leaf(:,:,:,:)=0._r8 + do L = 1,nclmax + do ft = 1,numpft + currentPatch%canopy_mask(L,ft) = 0 + do iv = 1, currentPatch%nrad(L,ft) + if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then + currentPatch%canopy_mask(L,ft) = 1 + + if(currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv).gt.0.0_r8) then + frac_lai = currentPatch%elai_profile(L,ft,iv)/& + (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) + else + frac_lai = 1.0_r8 + endif + !frac_lai = 1.0_r8 ! make the same as previous codebase, in theory. + frac_sai = 1.0_r8 - frac_lai + + ! layer level reflectance qualities + do ib = 1,hlm_numSWb !vis, nir + + rho_layer(L,ft,iv,ib)=frac_lai*rhol(ft,ib)+frac_sai*rhos(ft,ib) + tau_layer(L,ft,iv,ib)=frac_lai*taul(ft,ib)+frac_sai*taus(ft,ib) + + ! adjust reflectance and transmittance for canopy snow + rho_layer(L,ft,iv,ib)=rho_layer(L,ft,iv,ib)*(1.0_r8- currentPatch%fcansno) & + + rho_snow(ib) * currentPatch%fcansno + tau_layer(L,ft,iv,ib)=tau_layer(L,ft,iv,ib)*(1.0_r8- currentPatch%fcansno) & + + tau_snow(ib) * currentPatch%fcansno + + ! fraction of incoming light absorbed by leaves or stems. + f_abs(L,ft,iv,ib) = 1.0_r8 - tau_layer(L,ft,iv,ib) - rho_layer(L,ft,iv,ib) + + ! the fraction of the vegetation absorbed light which is absorbed by leaves + f_abs_leaf(L,ft,iv,ib) = (1.0_r8- currentPatch%fcansno) * frac_lai* & + (1.0_r8 - rhol(ft,ib) - taul(ft,ib))/f_abs(L,ft,iv,ib) + + end do !ib + endif + end do !iv + end do !ft + end do !L + + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Direct beam extinction coefficient, k_dir. PFT specific. + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + cosz = max(0.001_r8, currentPatch%solar_zenith_angle ) !copied from previous radiation code... + do ft = 1,numpft + sb = (90._r8 - (acos(cosz)*180._r8/pi_const)) * (pi_const / 180._r8) + phi1b(ft) = 0.5_r8 - 0.633_r8*xl(ft) - 0.330_r8*xl(ft)*xl(ft) + phi2b(ft) = 0.877_r8 * (1._r8 - 2._r8*phi1b(ft)) !0 = horiz leaves, 1 - vert leaves. + gdir = phi1b(ft) + phi2b(ft) * sin(sb) + !how much direct light penetrates a singleunit of lai? + k_dir(ft) = clumping_index(ft) * gdir / sin(sb) + end do !FT + + + + + !do this once for one unit of diffuse, and once for one unit of direct radiation + do radtype = 1, n_rad_stream_types + + ! Extract information that needs to be provided by ED into local array. + ! RGK: NOT SURE WHY WE NEED FTWEIGHT ... + ! ------------------------------------------------------------------------------ + + ftweight(:,:,:) = 0._r8 + do L = 1,currentPatch%NCL_p + do ft = 1,numpft + do iv = 1, currentPatch%nrad(L,ft) + !this is already corrected for area in CLAP + ftweight(L,ft,iv) = currentPatch%canopy_area_profile(L,ft,iv) + end do !iv + end do !ft1 + end do !L + + if(debug)then + if (sum(ftweight(1,:,1))<0.999_r8)then + write(fates_log(),*) 'canopy not full',ftweight(1,:,1) + endif + if (sum(ftweight(1,:,1))>1.0001_r8)then + write(fates_log(),*) 'canopy too full',ftweight(1,:,1) + endif + end if + + do L = 1,currentPatch%NCL_p !start at the top canopy layer (1 is the top layer.) + + weighted_dir_tr(L) = 0.0_r8 + weighted_fsun(L) = 0._r8 + weighted_dif_ratio(L,1:hlm_numSWb) = 0._r8 + + !Each canopy layer (canopy, understorey) has multiple 'parallel' pft's + + do ft =1,numpft + + if (currentPatch%canopy_mask(L,ft) == 1)then !only do calculation if there are the appropriate leaves. + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Diffuse transmittance, tr_dif, do each layer with thickness elai_z. + ! Estimated do nine sky angles in increments of 10 degrees + ! PFT specific... + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + tr_dif_z(L,ft,:) = 0._r8 + do iv = 1,currentPatch%nrad(L,ft) + do j = 1,9 + angle = (5._r8 + real(j - 1,r8) * 10._r8) * pi_const / 180._r8 + gdir = phi1b(ft) + phi2b(ft) * sin(angle) + tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-clumping_index(ft) * & + gdir / sin(angle) * & + (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))) * & + sin(angle)*cos(angle) + end do + + tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) * 2._r8 * (10._r8 * pi_const / 180._r8) + + end do + + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Direct beam transmittance, tr_dir_z, uses cumulative LAI above layer J to give + ! unscattered direct beam onto layer J. do each PFT section. + ! This is just an decay curve based on k_dir. (leaf & sun angle) + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + if (L==1)then + tr_dir_z(L,ft,1) = 1._r8 + else + tr_dir_z(L,ft,1) = weighted_dir_tr(L-1) + endif + laisum = 0.00_r8 + !total direct beam getting to the bottom of the top canopy. + do iv = 1,currentPatch%nrad(L,ft) + laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) + lai_change(L,ft,iv) = 0.0_r8 + if (( ftweight(L,ft,iv+1) > 0.0_r8 ) .and. ( ftweight(L,ft,iv+1) < ftweight(L,ft,iv) ))then + !where there is a partly empty leaf layer, some fluxes go straight through. + lai_change(L,ft,iv) = ftweight(L,ft,iv)-ftweight(L,ft,iv+1) + endif + if(debug)then + if (ftweight(L,ft,iv+1) - ftweight(L,ft,iv) > 1.e-10_r8)then + write(fates_log(),*) 'lower layer has more coverage. This is wrong' , & + ftweight(L,ft,iv),ftweight(L,ft,iv+1),ftweight(L,ft,iv+1)-ftweight(L,ft,iv) + endif + end if + + !n.b. in theory lai_change could be calculated daily in the ED code. + !This is light coming striaght through the canopy. + if (L==1)then + tr_dir_z(L,ft,iv+1) = exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + else + tr_dir_z(L,ft,iv+1) = weighted_dir_tr(L-1)*exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + endif + + if (iv == 1)then + !this is the top layer. + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & + ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) + else + !the lai_change(iv) affects the light incident on layer iv+2 not iv+1 + ! light coming from the layer above (iv-1) goes through iv and onto iv+1. + if (lai_change(L,ft,iv-1) > 0.0_r8)then + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv)* & + lai_change(L,ft,iv-1) / ftweight(L,ft,1) + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv-1)* & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) + else + !account fot the light that comes striaght down from unfilled layers above. + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & + ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) + endif + endif + + end do + + !add up all the weighted contributions from the different PFT columns. + weighted_dir_tr(L) = weighted_dir_tr(L) + tr_dir_z(L,ft,currentPatch%nrad(L,ft)+1)*ftweight(L,ft,1) + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Sunlit and shaded fraction of leaf layer + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + + !laisum = 0._r8 + do iv = 1,currentPatch%nrad(L,ft) + ! Cumulative leaf area. Original code uses cumulative lai do layer. + ! Now use cumulative lai at center of layer. + ! Same as tr_dir_z calcualtions, but in the middle of the layer? FIX(RF,032414)-WHY? + if (iv == 1) then + laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) + else + laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) + end if + + + if (L == 1)then !top canopy layer + currentPatch%f_sun(L,ft,iv) = exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + else + currentPatch%f_sun(L,ft,iv) = weighted_fsun(L-1)* exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + endif + + if ( iv > 1 ) then ! becasue we are looking at this layer (not the next) + ! we only ever add fluxes if iv>1 + if (lai_change(L,ft,iv-1) > 0.0_r8)then + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv) * & + lai_change(L,ft,iv-1)/ftweight(L,ft,1) + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv-1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) + else + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv-1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif + endif + + end do !iv + + weighted_fsun(L) = weighted_fsun(L) + currentPatch%f_sun(L,ft,currentPatch%nrad(L,ft))* & + ftweight(L,ft,1) + + ! instance where the first layer ftweight is used a proxy for the whole column. FTWA + ! this is possibly a source of slight error. If we use the ftweight at the top of the PFT column, + ! then we willl underestimate fsun, but if we use ftweight at the bottom of the column, we will + ! underestimate it. Really, we should be tracking the release of direct light from the column as it tapers + ! towards the ground. Is that necessary to get energy closure? It would be quite hard... + endif !present. + end do!pft loop + end do !L + + + do L = currentPatch%NCL_p,1, -1 !start at the bottom and work up. + do ft = 1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + + !==============================================================================! + ! Iterative solution do scattering + !==============================================================================! + + do ib = 1,hlm_numSWb !vis, nir + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Leaf scattering coefficient and terms do diffuse radiation reflected + ! and transmitted by a layer + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + + do iv = 1,currentPatch%nrad(L,ft) + !How much diffuse light is intercepted and then reflected? + refl_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * rho_layer(L,ft,iv,ib) + !How much diffuse light in this layer is transmitted? + tran_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * & + tau_layer(L,ft,iv,ib) + tr_dif_z(L,ft,iv) + end do + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Ratio of upward to forward diffuse fluxes, dif_ratio + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Soil diffuse reflectance (ratio of down to up radiation). + iv = currentPatch%nrad(L,ft) + 1 + if (L == currentPatch%NCL_p)then !nearest the soil + dif_ratio(L,ft,iv,ib) = currentPatch%gnd_alb_dif(ib) !bc_in(s)%albgr_dif_rb(ib) + else + dif_ratio(L,ft,iv,ib) = weighted_dif_ratio(L+1,ib) + end if + ! Canopy layers, working upwardfrom soil with dif_ratio(iv+1) known + ! FIX(RF,032414) ray tracing eqution - need to find derivation of this... + ! for each unit going down, there are x units going up. + do iv = currentPatch%nrad(L,ft),1, -1 + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv+1,ib) * & + tran_dif(L,ft,iv,ib)*tran_dif(L,ft,iv,ib) / & + (1._r8 - dif_ratio(L,ft,iv+1,ib) * refl_dif(L,ft,iv,ib)) & + + refl_dif(L,ft,iv,ib) + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) * & + ftweight(L,ft,iv)/ftweight(L,ft,1) + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) + dif_ratio(L,ft,iv+1,ib) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + end do + weighted_dif_ratio(L,ib) = weighted_dif_ratio(L,ib) + & + dif_ratio(L,ft,1,ib) * ftweight(L,ft,1) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + end do!hlm_numSWb + endif ! currentPatch%canopy_mask + end do!ft + end do!L + + ! Zero out the radiation error for the current patch before conducting the conservation check + currentPatch%radiation_error = 0.0_r8 + + do ib = 1,hlm_numSWb + Dif_dn(:,:,:) = 0.00_r8 + Dif_up(:,:,:) = 0.00_r8 + do L = 1, currentPatch%NCL_p !work down from the top of the canopy. + weighted_dif_down(L) = 0._r8 + do ft = 1, numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! First estimates do downward and upward diffuse flux + ! + ! Dif_dn = forward diffuse flux onto layer J + ! Dif_up = Upward diffuse flux above layer J + ! + ! Solved here without direct beam radiation and using dif_ratio = Dif_up / Dif_dn + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! downward diffuse flux onto the top surface of the canopy + + if (L == 1)then + Dif_dn(L,ft,1) = forc_dif(radtype) + else + Dif_dn(L,ft,1) = weighted_dif_down(L-1) + end if + ! forward diffuse flux within the canopy and at soil, working forward through canopy + do iv = 1,currentPatch%nrad(L,ft) + denom = refl_dif(L,ft,iv,ib) * dif_ratio(L,ft,iv,ib) + denom = 1._r8 - denom + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) / & + denom *ftweight(L,ft,iv)/ftweight(L,ft,1) + if (iv > 1)then + if (lai_change(L,ft,iv-1) > 0.0_r8)then + !here we are thinking about whether the layer above had an laichange, + !but calculating the flux onto the layer below. + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv)* & + lai_change(L,ft,iv-1)/ftweight(L,ft,1) + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv-1)* & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1)/ftweight(L,ft,1)) + else + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif + else + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif + end do + + weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & + ftweight(L,ft,1) + + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif !present + end do !ft + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is the the (incomplete) understorey? + !Add on the radiation going through the canopy gaps. + weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1)*(1.0-sum(ftweight(L,:,1))) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif + end do !L + + do L = currentPatch%NCL_p,1 ,-1 !work up from the bottom. + weighted_dif_up(L) = 0._r8 + do ft = 1, numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + !Bounce diffuse radiation off soil surface. + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then !is this the bottom layer ? + Dif_up(L,ft,iv) = currentPatch%gnd_alb_dif(ib) * Dif_dn(L,ft,iv) + else + Dif_up(L,ft,iv) = weighted_dif_up(L+1) + end if + ! Upward diffuse flux within the canopy and above the canopy, working upward through canopy + + do iv = currentPatch%nrad(L,ft), 1, -1 + if (lai_change(L,ft,iv) > 0.0_r8)then + Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * & + ftweight(L,ft,iv) / ftweight(L,ft,1) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & + tran_dif(L,ft,iv,ib) * lai_change(L,ft,iv)/ftweight(L,ft,1) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + !nb is this the right constuction? + ! the radiation that hits the empty space is not reflected. + else + Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * ftweight(L,ft,iv) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * (1.0_r8-ftweight(L,ft,iv)) + endif + end do + + weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif !present + end do !ft + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? + !Add on the radiation coming up through the canopy gaps. + !diffuse to diffuse + weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & + weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) + !direct to diffuse + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & + weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) * currentPatch%gnd_alb_dir(ib) + endif + end do !L + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! 3. Iterative calculation of forward and upward diffuse fluxes, iNCL_puding + ! scattered direct beam + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + + ! Flag to exit iteration loop: 0 = exit and 1 = iterate + irep = 1 + ! Iteration loop + iter = 0 + do while(irep ==1 .and. iter<50) + + iter = iter + 1 + irep = 0 + do L = 1,currentPatch%NCL_p !working from the top down + weighted_dif_down(L) = 0._r8 + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + ! forward diffuse flux within the canopy and at soil, working forward through canopy + ! with Dif_up -from previous iteration-. Dif_dn(1) is the forward diffuse flux onto the canopy. + ! Note: down = forward flux onto next layer + if (L == 1)then !is this the top layer? + Dif_dn(L,ft,1) = forc_dif(radtype) + else + Dif_dn(L,ft,1) = weighted_dif_down(L-1) + end if + down_rad = 0._r8 + + do iv = 1, currentPatch%nrad(L,ft) + ! down rad'n is the sum of the down and upwards reflected diffuse fluxes... + down_rad = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) + & + Dif_up(L,ft,iv+1) * refl_dif(L,ft,iv,ib) + + !... plus the direct beam intercepted and intransmitted by this layer. + down_rad = down_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - & + exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & + currentPatch%esai_profile(L,ft,iv)) )) * tau_layer(L,ft,iv,ib) + + + !... plus the direct beam intercepted and intransmitted by this layer. + ! modified to spread it out over the whole of incomplete layers. + + down_rad = down_rad *(ftweight(L,ft,iv)/ftweight(L,ft,1)) + + if (iv > 1)then + if (lai_change(L,ft,iv-1) > 0.0_r8)then + down_rad = down_rad + Dif_dn(L,ft,iv) * lai_change(L,ft,iv-1)/ftweight(L,ft,1) + down_rad = down_rad + Dif_dn(L,ft,iv-1) * (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ & + ftweight(L,ft,1) + else + down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & + ftweight(L,ft,1) + endif + else + down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & + ftweight(L,ft,1) + endif + + !this is just Dif down, plus refl up, plus dir intercepted and turned into dif... , + if (abs(down_rad - Dif_dn(L,ft,iv+1)) > tolerance)then + irep = 1 + end if + Dif_dn(L,ft,iv+1) = down_rad + + end do !iv + + weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & + ftweight(L,ft,1) + + endif !present + end do!ft + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? + weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1) * & + (1.0_r8-sum(ftweight(L,1:numpft,1))) + end if + end do ! do L loop + + do L = 1, currentPatch%NCL_p ! working from the top down. + weighted_dif_up(L) = 0._r8 + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + ! Upward diffuse flux at soil or from lower canopy (forward diffuse and unscattered direct beam) + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then !In the bottom canopy layer, reflect off the soil + Dif_up(L,ft,iv) = Dif_dn(L,ft,iv) * currentPatch%gnd_alb_dif(ib) + & + forc_dir(radtype) * tr_dir_z(L,ft,iv) * currentPatch%gnd_alb_dir(ib) + else !In the other canopy layers, reflect off the underlying vegetation. + Dif_up(L,ft,iv) = weighted_dif_up(L+1) + end if + + ! Upward diffuse flux within and above the canopy, working upward through canopy + ! with Dif_dn from previous interation. Note: up = upward flux above current layer + do iv = currentPatch%nrad(L,ft),1,-1 + !this is radiation up, by layer transmittance, by + + !reflection of the lower layer, + up_rad = Dif_dn(L,ft,iv) * refl_dif(L,ft,iv,ib) + up_rad = up_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - exp(-k_dir(ft) * & + (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))))* & + rho_layer(L,ft,iv,ib) + up_rad = up_rad + Dif_up(L,ft,iv+1) * tran_dif(L,ft,iv,ib) + up_rad = up_rad * ftweight(L,ft,iv)/ftweight(L,ft,1) + up_rad = up_rad + Dif_up(L,ft,iv+1) *(ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + ! THE LOWER LAYER FLUX IS HOMOGENIZED, SO WE DON"T CONSIDER THE LAI_CHANGE HERE... + + if (abs(up_rad - Dif_up(L,ft,iv)) > tolerance) then !are we close to the tolerance level? + irep = 1 + end if + Dif_up(L,ft,iv) = up_rad + + end do !iv + weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) + end if !present + end do!ft + + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? + !Add on the radiation coming up through the canopy gaps. + weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & + weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & + weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1)))*currentPatch%gnd_alb_dir(ib) + end if + end do!L + end do ! do while over iter + + abs_rad(ib) = 0._r8 + tr_soili = 0._r8 + tr_soild = 0._r8 + + do L = 1, currentPatch%NCL_p !working from the top down. + abs_dir_z(:,:) = 0._r8 + abs_dif_z(:,:) = 0._r8 + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + !==============================================================================! + ! Compute absorbed flux densities + !==============================================================================! + + ! Absorbed direct beam and diffuse do leaf layers + do iv = 1, currentPatch%nrad(L,ft) + Abs_dir_z(ft,iv) = ftweight(L,ft,iv)* forc_dir(radtype) * tr_dir_z(L,ft,iv) * & + (1.00_r8 - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & + currentPatch%esai_profile(L,ft,iv)) )) * f_abs(L,ft,iv,ib) + Abs_dif_z(ft,iv) = ftweight(L,ft,iv)* ((Dif_dn(L,ft,iv) + & + Dif_up(L,ft,iv+1)) * (1.00_r8 - tr_dif_z(L,ft,iv)) * f_abs(L,ft,iv,ib)) + end do + + ! Absorbed direct beam and diffuse do soil + if (L == currentPatch%NCL_p)then + iv = currentPatch%nrad(L,ft) + 1 + Abs_dif_z(ft,iv) = ftweight(L,ft,1)*Dif_dn(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dif(ib) ) + Abs_dir_z(ft,iv) = ftweight(L,ft,1)*forc_dir(radtype) * & + tr_dir_z(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dir(ib) ) + tr_soild = tr_soild + ftweight(L,ft,1)*forc_dir(radtype) * tr_dir_z(L,ft,iv) + tr_soili = tr_soili + ftweight(L,ft,1)*Dif_dn(L,ft,iv) + end if + + ! Absorbed radiation, shaded and sunlit portions of leaf layers + !here we get one unit of diffuse radiation... how much of + !it is absorbed? + if (ib == ivis) then ! only set the absorbed PAR for the visible light band. + do iv = 1, currentPatch%nrad(L,ft) + if (radtype==idirect) then + if ( debug ) then + write(fates_log(),*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) + write(fates_log(),*) 'EDsurfAlb 731 ', currentPatch%fabd_sha_z(L,ft,iv), & + currentPatch%fabd_sun_z(L,ft,iv) + endif + currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + (1._r8 - currentPatch%f_sun(L,ft,iv))*f_abs_leaf(L,ft,iv,ib) + currentPatch%fabd_sun_z(L,ft,iv) =( Abs_dif_z(ft,iv) * & + currentPatch%f_sun(L,ft,iv) + & + Abs_dir_z(ft,iv))*f_abs_leaf(L,ft,iv,ib) + else + currentPatch%fabi_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + (1._r8 - currentPatch%f_sun(L,ft,iv))*f_abs_leaf(L,ft,iv,ib) + currentPatch%fabi_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + currentPatch%f_sun(L,ft,iv)*f_abs_leaf(L,ft,iv,ib) + endif + if ( debug ) then + write(fates_log(),*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & + currentPatch%fabd_sun_z(L,ft,iv) + endif + end do + endif ! ib + + + !==============================================================================! + ! Sum fluxes + !==============================================================================! + ! Solar radiation absorbed by ground + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then + abs_rad(ib) = abs_rad(ib) + (Abs_dir_z(ft,iv) + Abs_dif_z(ft,iv)) + end if + ! Solar radiation absorbed by vegetation and sunlit/shaded leaves + do iv = 1,currentPatch%nrad(L,ft) + if (radtype == idirect)then + currentPatch%fabd(ib) = currentPatch%fabd(ib) + & + Abs_dir_z(ft,iv)+Abs_dif_z(ft,iv) + ! bc_out(s)%fabd_parb_out(ib) = currentPatch%fabd(ib) + else + currentPatch%fabi(ib) = currentPatch%fabi(ib) + Abs_dif_z(ft,iv) + ! bc_out(s)%fabi_parb_out(ib) = currentPatch%fabi(ib) + endif + end do + + ! Albefor + if (L==1)then !top canopy layer. + if (radtype == idirect)then + albd_parb_out(ib) = albd_parb_out(ib) + & + Dif_up(L,ft,1) * ftweight(L,ft,1) + else + albi_parb_out(ib) = albi_parb_out(ib) + & + Dif_up(L,ft,1) * ftweight(L,ft,1) + end if + end if + + ! pass normalized PAR profiles for use in diagnostic averaging for history fields + if (ib == ivis) then ! only diagnose PAR profiles for the visible band + do iv = 1, currentPatch%nrad(L,ft) + currentPatch%nrmlzd_parprof_pft_dir_z(radtype,L,ft,iv) = & + forc_dir(radtype) * tr_dir_z(L,ft,iv) + currentPatch%nrmlzd_parprof_pft_dif_z(radtype,L,ft,iv) = & + Dif_dn(L,ft,iv) + Dif_up(L,ft,iv) + ! + currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) = & + currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) + & + (forc_dir(radtype) * tr_dir_z(L,ft,iv)) * & + (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) + currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) = & + currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) + & + (Dif_dn(L,ft,iv) + Dif_up(L,ft,iv)) * & + (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) + end do + end if ! ib = visible + end if ! present + end do !ft + if (radtype == idirect)then + fabd_parb_out(ib) = currentPatch%fabd(ib) + else + fabi_parb_out(ib) = currentPatch%fabi(ib) + endif + + + !radiation absorbed from fluxes through unfilled part of lower canopy. + if (currentPatch%NCL_p > 1.and.L == currentPatch%NCL_p)then + abs_rad(ib) = abs_rad(ib) + weighted_dif_down(L-1) * & + (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dif(ib) ) + abs_rad(ib) = abs_rad(ib) + forc_dir(radtype) * weighted_dir_tr(L-1) * & + (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dir(ib) ) + tr_soili = tr_soili + weighted_dif_down(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) + tr_soild = tr_soild + forc_dir(radtype) * weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) + endif + + if (radtype == idirect)then + currentPatch%tr_soil_dir(ib) = tr_soild + currentPatch%tr_soil_dir_dif(ib) = tr_soili + currentPatch%sabs_dir(ib) = abs_rad(ib) + ftdd_parb_out(ib) = tr_soild + ftid_parb_out(ib) = tr_soili + else + currentPatch%tr_soil_dif(ib) = tr_soili + currentPatch%sabs_dif(ib) = abs_rad(ib) + ftii_parb_out(ib) = tr_soili + end if + + end do!l + + + !==============================================================================! + ! Conservation check + !==============================================================================! + ! Total radiation balance: absorbed = incoming - outgoing + + if (radtype == idirect)then + error = abs(currentPatch%sabs_dir(ib) - (currentPatch%tr_soil_dir(ib) * & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + & + currentPatch%tr_soil_dir_dif(ib) * (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) + + if(debug)then + if ( abs(error) > 0.0001)then + write(fates_log(),*)'dir ground absorption error',error,currentPatch%sabs_dir(ib), & + currentPatch%tr_soil_dir(ib)* & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) + write(fates_log(),*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + do ft =1,numpft + iv = currentPatch%nrad(1,ft) + 1 + write(fates_log(),*) 'abs soil fluxes', Abs_dir_z(ft,iv),Abs_dif_z(ft,iv) + end do + end if + end if + + else + if (debug) then + if ( abs(currentPatch%sabs_dif(ib)-(currentPatch%tr_soil_dif(ib) * & + (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) > 0.0001_r8)then + write(fates_log(),*)'dif ground absorption error',currentPatch%sabs_dif(ib) , & + (currentPatch%tr_soil_dif(ib)* & + (1.0_r8-currentPatch%gnd_alb_dif(ib) )),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) + endif + end if + endif + + if (radtype == idirect)then + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) + else + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) + endif + + ! ignore the current patch radiation error if the veg-covered fraction of the patch is really small + if ( (currentPatch%total_canopy_area / currentPatch%area) .gt. tolerance ) then + ! normalize rad error by the veg-covered fraction of the patch because that is + ! the only part that this code applies to + currentPatch%radiation_error = currentPatch%radiation_error + error & + * currentPatch%total_canopy_area / currentPatch%area + endif + + lai_reduction(:) = 0.0_r8 + do L = 1, currentPatch%NCL_p + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + do iv = 1, currentPatch%nrad(L,ft) + if (lai_change(L,ft,iv) > 0.0_r8)then + lai_reduction(L) = max(lai_reduction(L),lai_change(L,ft,iv)) + endif + enddo + endif + enddo + enddo + + if (radtype == idirect)then + !here we are adding a within-ED radiation scheme tolerance, and then adding the diffrence onto the albedo + !it is important that the lower boundary for this is ~1000 times smaller than the tolerance in surface albedo. + if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then + albd_parb_out(ib) = albd_parb_out(ib) + error + !this terms adds the error back on to the albedo. While this is partly inexcusable, it is + ! in the medium term a solution that + ! prevents the model from crashing with small and occasional energy balances issues. + ! These are extremely difficult to debug, many have been solved already, leading + ! to the complexity of this code, but where the system generates occasional errors, we + ! will deal with them for now. + end if + + if (abs(error) > 0.15_r8)then + if(debug)then + write(fates_log(),*) 'Large Dir Radn consvn error',error ,ib + write(fates_log(),*) 'diags', albd_parb_out(ib), ftdd_parb_out(ib), & + ftid_parb_out(ib), fabd_parb_out(ib) + write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'ftweight',ftweight(1,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) + end if + albd_parb_out(ib) = albd_parb_out(ib) + error + end if + else + + if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then + albi_parb_out(ib) = albi_parb_out(ib) + error + end if + + if (abs(error) > 0.15_r8)then + if(debug)then + write(fates_log(),*) 'lg Dif Radn consvn error',error ,ib + write(fates_log(),*) 'diags', albi_parb_out(ib), ftii_parb_out(ib), & + fabi_parb_out(ib) + !write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + !write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + !write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + !write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) + !write(fates_log(),*) 'rhol',rhol(1:numpft,:) + !write(fates_log(),*) 'ftw',sum(ftweight(1,1:numpft,1)),ftweight(1,1:numpft,1) + !write(fates_log(),*) 'present',currentPatch%canopy_mask(1,1:numpft) + !write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:numpft,1) + end if + albi_parb_out(ib) = albi_parb_out(ib) + error + end if + + if (radtype == idirect)then + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) + else + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) + endif + + if(debug) then + if (abs(error) > 0.00000001_r8)then + write(fates_log(),*) 'there is still error after correction',error ,ib + end if + end if + + end if + end do !hlm_numSWb + + enddo ! rad-type + + + end associate + return +end subroutine PatchNormanRadiation + + +end module FatesNormanRadMod diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index e52a7d624b..36a5394913 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -41,7 +41,8 @@ module FatesRadiationDriveMod use FatesGlobals , only : fates_log use FatesGlobals, only : endrun => fates_endrun use EDPftvarcon, only : EDPftvarcon_inst - + use FatesNormanRadMod only : PatchNormanRadiation + ! CIME globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -49,7 +50,6 @@ module FatesRadiationDriveMod private public :: FatesNormalizedCanopyRadiation ! Surface albedo and two-stream fluxes - public :: PatchNormanRadiation public :: FatesSunShadeFracs logical :: debug = .false. ! for debugging this module @@ -250,928 +250,6 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) return end subroutine FatesNormalizedCanopyRadiation - - ! ====================================================================================== - - subroutine PatchNormanRadiation (currentPatch, & - albd_parb_out, & ! (ifp,ib) - albi_parb_out, & ! (ifp,ib) - fabd_parb_out, & ! (ifp,ib) - fabi_parb_out, & ! (ifp,ib) - ftdd_parb_out, & ! (ifp,ib) - ftid_parb_out, & ! (ifp,ib) - ftii_parb_out) ! (ifp,ib) - - ! ----------------------------------------------------------------------------------- - ! - ! This routine performs the Norman Radiation scattering for each patch. - ! - ! ----------------------------------------------------------------------------------- - - ! ----------------------------------------------------------------------------------- - ! !ARGUMENTS: - ! ----------------------------------------------------------------------------------- - - type(fates_patch_type), intent(inout), target :: currentPatch - real(r8), intent(inout) :: albd_parb_out(hlm_numSWb) - real(r8), intent(inout) :: albi_parb_out(hlm_numSWb) - real(r8), intent(inout) :: fabd_parb_out(hlm_numSWb) - real(r8), intent(inout) :: fabi_parb_out(hlm_numSWb) - real(r8), intent(inout) :: ftdd_parb_out(hlm_numSWb) - real(r8), intent(inout) :: ftid_parb_out(hlm_numSWb) - real(r8), intent(inout) :: ftii_parb_out(hlm_numSWb) - - ! Locals - ! ----------------------------------------------------------------------------------- - - integer :: radtype, L, ft, j - integer :: iter ! Iteration index - integer :: irep ! Flag to exit iteration loop - real(r8) :: sb - real(r8) :: error ! Error check - real(r8) :: down_rad, up_rad ! Iterative solution do Dif_dn and Dif_up - real(r8) :: ftweight(nclmax,maxpft,nlevleaf) - real(r8) :: k_dir(maxpft) ! Direct beam extinction coefficient - real(r8) :: tr_dir_z(nclmax,maxpft,nlevleaf) ! Exponential transmittance of direct beam radiation through a single layer - real(r8) :: tr_dif_z(nclmax,maxpft,nlevleaf) ! Exponential transmittance of diffuse radiation through a single layer - real(r8) :: weighted_dir_tr(nclmax) - real(r8) :: weighted_fsun(nclmax) - real(r8) :: weighted_dif_ratio(nclmax,num_swb) - real(r8) :: weighted_dif_down(nclmax) - real(r8) :: weighted_dif_up(nclmax) - real(r8) :: refl_dif(nclmax,maxpft,nlevleaf,num_swb) ! Term for diffuse radiation reflected by laye - real(r8) :: tran_dif(nclmax,maxpft,nlevleaf,num_swb) ! Term for diffuse radiation transmitted by layer - real(r8) :: dif_ratio(nclmax,maxpft,nlevleaf,num_swb) ! Ratio of upward to forward diffuse fluxes - real(r8) :: Dif_dn(nclmax,maxpft,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) - real(r8) :: Dif_up(nclmax,maxpft,nlevleaf) ! Upward diffuse flux above canopy layer J (W/m**2 ground area) - real(r8) :: lai_change(nclmax,maxpft,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) - - real(r8) :: frac_lai ! Fraction of lai in each layer - real(r8) :: frac_sai ! Fraction of sai in each layer - real(r8) :: f_abs(nclmax,maxpft,nlevleaf,num_swb) ! Fraction of light absorbed by surfaces. - real(r8) :: rho_layer(nclmax,maxpft,nlevleaf,num_swb)! Weighted verage reflectance of layer - real(r8) :: tau_layer(nclmax,maxpft,nlevleaf,num_swb)! Weighted average transmittance of layer - real(r8) :: f_abs_leaf(nclmax,maxpft,nlevleaf,num_swb) - real(r8) :: Abs_dir_z(maxpft,nlevleaf) - real(r8) :: Abs_dif_z(maxpft,nlevleaf) - real(r8) :: abs_rad(num_swb) !radiation absorbed by soil - real(r8) :: tr_soili ! Radiation transmitted to the soil surface. - real(r8) :: tr_soild ! Radiation transmitted to the soil surface. - real(r8) :: phi1b(maxpft) ! Radiation transmitted to the soil surface. - real(r8) :: phi2b(maxpft) - real(r8) :: laisum ! cumulative lai+sai for canopy layer (at middle of layer) - real(r8) :: angle - - real(r8),parameter :: tolerance = 0.000000001_r8 - - - integer, parameter :: max_diag_nlevleaf = 4 - integer, parameter :: diag_nlevleaf = min(nlevleaf,max_diag_nlevleaf) ! for diagnostics, write a small number of leaf layers - - real(r8) :: denom - real(r8) :: lai_reduction(nclmax) - - integer :: fp,iv,s ! array indices - integer :: ib ! waveband number - real(r8) :: cosz ! 0.001 <= coszen <= 1.000 - real(r8) :: gdir - - - real(r8), parameter :: forc_dir(num_rad_stream_types) = (/ 1.0_r8, 0.0_r8 /) ! These are binary switches used - real(r8), parameter :: forc_dif(num_rad_stream_types) = (/ 0.0_r8, 1.0_r8 /) ! to turn off and on radiation streams - - - - associate(& - rhol => EDPftvarcon_inst%rhol , & ! Input: [real(r8) (:) ] leaf reflectance: 1=vis, 2=nir - rhos => EDPftvarcon_inst%rhos , & ! Input: [real(r8) (:) ] stem reflectance: 1=vis, 2=nir - taul => EDPftvarcon_inst%taul , & ! Input: [real(r8) (:) ] leaf transmittance: 1=vis, 2=nir - taus => EDPftvarcon_inst%taus , & ! Input: [real(r8) (:) ] stem transmittance: 1=vis, 2=nir - xl => EDPftvarcon_inst%xl , & ! Input: [real(r8) (:) ] ecophys const - leaf/stem orientation index - clumping_index => EDPftvarcon_inst%clumping_index) - - - - ! Initialize local arrays - - weighted_dir_tr(:) = 0._r8 - weighted_dif_down(:) = 0._r8 - weighted_dif_up(:) = 0._r8 - - tr_dir_z(:,:,:) = 0._r8 - tr_dif_z(:,:,:) = 0._r8 - lai_change(:,:,:) = 0._r8 - Dif_up(:,:,:) = 0._r8 - Dif_dn(:,:,:) = 0._r8 - refl_dif(:,:,:,:) = 0.0_r8 - tran_dif(:,:,:,:) = 0.0_r8 - dif_ratio(:,:,:,:) = 0.0_r8 - - - ! Initialize the ouput arrays - ! --------------------------------------------------------------------------------- - albd_parb_out(1:hlm_numSWb) = 0.0_r8 - albi_parb_out(1:hlm_numSWb) = 0.0_r8 - fabd_parb_out(1:hlm_numSWb) = 0.0_r8 - fabi_parb_out(1:hlm_numSWb) = 0.0_r8 - ftdd_parb_out(1:hlm_numSWb) = 1.0_r8 - ftid_parb_out(1:hlm_numSWb) = 1.0_r8 - ftii_parb_out(1:hlm_numSWb) = 1.0_r8 - - ! Is this pft/canopy layer combination present in this patch? - rho_layer(:,:,:,:)=0.0_r8 - tau_layer(:,:,:,:)=0.0_r8 - f_abs(:,:,:,:)=0.0_r8 - f_abs_leaf(:,:,:,:)=0._r8 - do L = 1,nclmax - do ft = 1,numpft - currentPatch%canopy_mask(L,ft) = 0 - do iv = 1, currentPatch%nrad(L,ft) - if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then - currentPatch%canopy_mask(L,ft) = 1 - - if(currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv).gt.0.0_r8) then - frac_lai = currentPatch%elai_profile(L,ft,iv)/& - (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) - else - frac_lai = 1.0_r8 - endif - !frac_lai = 1.0_r8 ! make the same as previous codebase, in theory. - frac_sai = 1.0_r8 - frac_lai - - ! layer level reflectance qualities - do ib = 1,hlm_numSWb !vis, nir - - rho_layer(L,ft,iv,ib)=frac_lai*rhol(ft,ib)+frac_sai*rhos(ft,ib) - tau_layer(L,ft,iv,ib)=frac_lai*taul(ft,ib)+frac_sai*taus(ft,ib) - - ! adjust reflectance and transmittance for canopy snow - rho_layer(L,ft,iv,ib)=rho_layer(L,ft,iv,ib)*(1.0_r8- currentPatch%fcansno) & - + rho_snow(ib) * currentPatch%fcansno - tau_layer(L,ft,iv,ib)=tau_layer(L,ft,iv,ib)*(1.0_r8- currentPatch%fcansno) & - + tau_snow(ib) * currentPatch%fcansno - - ! fraction of incoming light absorbed by leaves or stems. - f_abs(L,ft,iv,ib) = 1.0_r8 - tau_layer(L,ft,iv,ib) - rho_layer(L,ft,iv,ib) - - ! the fraction of the vegetation absorbed light which is absorbed by leaves - f_abs_leaf(L,ft,iv,ib) = (1.0_r8- currentPatch%fcansno) * frac_lai* & - (1.0_r8 - rhol(ft,ib) - taul(ft,ib))/f_abs(L,ft,iv,ib) - - end do !ib - endif - end do !iv - end do !ft - end do !L - - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Direct beam extinction coefficient, k_dir. PFT specific. - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - cosz = max(0.001_r8, currentPatch%solar_zenith_angle ) !copied from previous radiation code... - do ft = 1,numpft - sb = (90._r8 - (acos(cosz)*180._r8/pi_const)) * (pi_const / 180._r8) - phi1b(ft) = 0.5_r8 - 0.633_r8*xl(ft) - 0.330_r8*xl(ft)*xl(ft) - phi2b(ft) = 0.877_r8 * (1._r8 - 2._r8*phi1b(ft)) !0 = horiz leaves, 1 - vert leaves. - gdir = phi1b(ft) + phi2b(ft) * sin(sb) - !how much direct light penetrates a singleunit of lai? - k_dir(ft) = clumping_index(ft) * gdir / sin(sb) - end do !ft - - - - - !do this once for one unit of diffuse, and once for one unit of direct radiation - do radtype = 1, num_rad_stream_types - - ! Extract information that needs to be provided by ED into local array. - ! RGK: NOT SURE WHY WE NEED FTWEIGHT ... - ! ------------------------------------------------------------------------------ - - ftweight(:,:,:) = 0._r8 - do L = 1,currentPatch%ncl_p - do ft = 1,numpft - do iv = 1, currentPatch%nrad(L,ft) - !this is already corrected for area in CLAP - ftweight(L,ft,iv) = currentPatch%canopy_area_profile(L,ft,iv) - end do !iv - end do !ft1 - end do !L - - if(debug)then - if (sum(ftweight(1,:,1))<0.999_r8)then - write(fates_log(),*) 'canopy not full',ftweight(1,:,1) - endif - if (sum(ftweight(1,:,1))>1.0001_r8)then - write(fates_log(),*) 'canopy too full',ftweight(1,:,1) - endif - end if - - do L = 1,currentPatch%ncl_p !start at the top canopy layer (1 is the top layer.) - - weighted_dir_tr(L) = 0.0_r8 - weighted_fsun(L) = 0._r8 - weighted_dif_ratio(L,1:hlm_numSWb) = 0._r8 - - !Each canopy layer (canopy, understorey) has multiple 'parallel' pft's - - do ft =1,numpft - - if (currentPatch%canopy_mask(L,ft) == 1)then !only do calculation if there are the appropriate leaves. - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Diffuse transmittance, tr_dif, do each layer with thickness elai_z. - ! Estimated do nine sky angles in increments of 10 degrees - ! PFT specific... - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - tr_dif_z(L,ft,:) = 0._r8 - do iv = 1,currentPatch%nrad(L,ft) - do j = 1,9 - angle = (5._r8 + real(j - 1,r8) * 10._r8) * pi_const / 180._r8 - gdir = phi1b(ft) + phi2b(ft) * sin(angle) - tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-clumping_index(ft) * & - gdir / sin(angle) * & - (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))) * & - sin(angle)*cos(angle) - end do - - tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) * 2._r8 * (10._r8 * pi_const / 180._r8) - - end do - - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Direct beam transmittance, tr_dir_z, uses cumulative LAI above layer J to give - ! unscattered direct beam onto layer J. do each PFT section. - ! This is just an decay curve based on k_dir. (leaf & sun angle) - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - if (L==1)then - tr_dir_z(L,ft,1) = 1._r8 - else - tr_dir_z(L,ft,1) = weighted_dir_tr(L-1) - endif - laisum = 0.00_r8 - !total direct beam getting to the bottom of the top canopy. - do iv = 1,currentPatch%nrad(L,ft) - laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) - lai_change(L,ft,iv) = 0.0_r8 - if (( ftweight(L,ft,iv+1) > 0.0_r8 ) .and. ( ftweight(L,ft,iv+1) < ftweight(L,ft,iv) ))then - !where there is a partly empty leaf layer, some fluxes go straight through. - lai_change(L,ft,iv) = ftweight(L,ft,iv)-ftweight(L,ft,iv+1) - endif - if(debug)then - if (ftweight(L,ft,iv+1) - ftweight(L,ft,iv) > 1.e-10_r8)then - write(fates_log(),*) 'lower layer has more coverage. This is wrong' , & - ftweight(L,ft,iv),ftweight(L,ft,iv+1),ftweight(L,ft,iv+1)-ftweight(L,ft,iv) - endif - end if - - !n.b. in theory lai_change could be calculated daily in the ED code. - !This is light coming striaght through the canopy. - if (L==1)then - tr_dir_z(L,ft,iv+1) = exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - else - tr_dir_z(L,ft,iv+1) = weighted_dir_tr(L-1)*exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - endif - - if (iv == 1)then - !this is the top layer. - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & - ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) - else - !the lai_change(iv) affects the light incident on layer iv+2 not iv+1 - ! light coming from the layer above (iv-1) goes through iv and onto iv+1. - if (lai_change(L,ft,iv-1) > 0.0_r8)then - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv)* & - lai_change(L,ft,iv-1) / ftweight(L,ft,1) - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv-1)* & - (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) - else - !account fot the light that comes striaght down from unfilled layers above. - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & - ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) - endif - endif - - end do - - !add up all the weighted contributions from the different PFT columns. - weighted_dir_tr(L) = weighted_dir_tr(L) + tr_dir_z(L,ft,currentPatch%nrad(L,ft)+1)*ftweight(L,ft,1) - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Sunlit and shaded fraction of leaf layer - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - - !laisum = 0._r8 - do iv = 1,currentPatch%nrad(L,ft) - ! Cumulative leaf area. Original code uses cumulative lai do layer. - ! Now use cumulative lai at center of layer. - ! Same as tr_dir_z calcualtions, but in the middle of the layer? FIX(RF,032414)-WHY? - if (iv == 1) then - laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) - else - laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) - end if - - - if (L == 1)then !top canopy layer - currentPatch%f_sun(L,ft,iv) = exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - else - currentPatch%f_sun(L,ft,iv) = weighted_fsun(L-1)* exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - endif - - if ( iv > 1 ) then ! becasue we are looking at this layer (not the next) - ! we only ever add fluxes if iv>1 - if (lai_change(L,ft,iv-1) > 0.0_r8)then - currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & - currentPatch%f_sun(L,ft,iv) * & - lai_change(L,ft,iv-1)/ftweight(L,ft,1) - currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & - currentPatch%f_sun(L,ft,iv-1) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) - else - currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & - currentPatch%f_sun(L,ft,iv-1) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - endif - endif - - end do !iv - - weighted_fsun(L) = weighted_fsun(L) + currentPatch%f_sun(L,ft,currentPatch%nrad(L,ft))* & - ftweight(L,ft,1) - - ! instance where the first layer ftweight is used a proxy for the whole column. FTWA - ! this is possibly a source of slight error. If we use the ftweight at the top of the PFT column, - ! then we willl underestimate fsun, but if we use ftweight at the bottom of the column, we will - ! underestimate it. Really, we should be tracking the release of direct light from the column as it tapers - ! towards the ground. Is that necessary to get energy closure? It would be quite hard... - endif !present. - end do!pft loop - end do !L - - - do L = currentPatch%ncl_p,1, -1 !start at the bottom and work up. - do ft = 1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - - !==============================================================================! - ! Iterative solution do scattering - !==============================================================================! - - do ib = 1,hlm_numSWb !vis, nir - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Leaf scattering coefficient and terms do diffuse radiation reflected - ! and transmitted by a layer - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - - do iv = 1,currentPatch%nrad(L,ft) - !How much diffuse light is intercepted and then reflected? - refl_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * rho_layer(L,ft,iv,ib) - !How much diffuse light in this layer is transmitted? - tran_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * & - tau_layer(L,ft,iv,ib) + tr_dif_z(L,ft,iv) - end do - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Ratio of upward to forward diffuse fluxes, dif_ratio - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Soil diffuse reflectance (ratio of down to up radiation). - iv = currentPatch%nrad(L,ft) + 1 - if (L == currentPatch%ncl_p)then !nearest the soil - dif_ratio(L,ft,iv,ib) = currentPatch%gnd_alb_dif(ib) !bc_in(s)%albgr_dif_rb(ib) - else - dif_ratio(L,ft,iv,ib) = weighted_dif_ratio(L+1,ib) - end if - ! Canopy layers, working upwardfrom soil with dif_ratio(iv+1) known - ! FIX(RF,032414) ray tracing eqution - need to find derivation of this... - ! for each unit going down, there are x units going up. - do iv = currentPatch%nrad(L,ft),1, -1 - dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv+1,ib) * & - tran_dif(L,ft,iv,ib)*tran_dif(L,ft,iv,ib) / & - (1._r8 - dif_ratio(L,ft,iv+1,ib) * refl_dif(L,ft,iv,ib)) & - + refl_dif(L,ft,iv,ib) - dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) * & - ftweight(L,ft,iv)/ftweight(L,ft,1) - dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) + dif_ratio(L,ft,iv+1,ib) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - end do - weighted_dif_ratio(L,ib) = weighted_dif_ratio(L,ib) + & - dif_ratio(L,ft,1,ib) * ftweight(L,ft,1) - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - end do!hlm_numSWb - endif ! currentPatch%canopy_mask - end do!ft - end do!L - - ! Zero out the radiation error for the current patch before conducting the conservation check - currentPatch%radiation_error = 0.0_r8 - - do ib = 1,hlm_numSWb - Dif_dn(:,:,:) = 0.00_r8 - Dif_up(:,:,:) = 0.00_r8 - do L = 1, currentPatch%ncl_p !work down from the top of the canopy. - weighted_dif_down(L) = 0._r8 - do ft = 1, numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! First estimates do downward and upward diffuse flux - ! - ! Dif_dn = forward diffuse flux onto layer J - ! Dif_up = Upward diffuse flux above layer J - ! - ! Solved here without direct beam radiation and using dif_ratio = Dif_up / Dif_dn - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! downward diffuse flux onto the top surface of the canopy - - if (L == 1)then - Dif_dn(L,ft,1) = forc_dif(radtype) - else - Dif_dn(L,ft,1) = weighted_dif_down(L-1) - end if - ! forward diffuse flux within the canopy and at soil, working forward through canopy - do iv = 1,currentPatch%nrad(L,ft) - denom = refl_dif(L,ft,iv,ib) * dif_ratio(L,ft,iv,ib) - denom = 1._r8 - denom - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) / & - denom *ftweight(L,ft,iv)/ftweight(L,ft,1) - if (iv > 1)then - if (lai_change(L,ft,iv-1) > 0.0_r8)then - !here we are thinking about whether the layer above had an laichange, - !but calculating the flux onto the layer below. - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv)* & - lai_change(L,ft,iv-1)/ftweight(L,ft,1) - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv-1)* & - (ftweight(L,ft,1)-ftweight(L,ft,iv-1)/ftweight(L,ft,1)) - else - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - endif - else - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - endif - end do - - weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & - ftweight(L,ft,1) - - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - endif !present - end do !ft - if (L == currentPatch%ncl_p.and.currentPatch%ncl_p > 1)then !is the the (incomplete) understorey? - !Add on the radiation going through the canopy gaps. - weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1)*(1.0-sum(ftweight(L,:,1))) - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - endif - end do !L - - do L = currentPatch%ncl_p,1 ,-1 !work up from the bottom. - weighted_dif_up(L) = 0._r8 - do ft = 1, numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - !Bounce diffuse radiation off soil surface. - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%ncl_p)then !is this the bottom layer ? - Dif_up(L,ft,iv) = currentPatch%gnd_alb_dif(ib) * Dif_dn(L,ft,iv) - else - Dif_up(L,ft,iv) = weighted_dif_up(L+1) - end if - ! Upward diffuse flux within the canopy and above the canopy, working upward through canopy - - do iv = currentPatch%nrad(L,ft), 1, -1 - if (lai_change(L,ft,iv) > 0.0_r8)then - Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * & - ftweight(L,ft,iv) / ftweight(L,ft,1) - Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & - tran_dif(L,ft,iv,ib) * lai_change(L,ft,iv)/ftweight(L,ft,1) - Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - !nb is this the right constuction? - ! the radiation that hits the empty space is not reflected. - else - Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * ftweight(L,ft,iv) - Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * (1.0_r8-ftweight(L,ft,iv)) - endif - end do - weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - endif !present - end do !ft - if (L == currentPatch%ncl_p.and.currentPatch%ncl_p > 1)then !is this the (incomplete) understorey? - !Add on the radiation coming up through the canopy gaps. - !diffuse to diffuse - weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & - weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) - !direct to diffuse - weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & - weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) * currentPatch%gnd_alb_dir(ib) - endif - end do !L - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! 3. Iterative calculation of forward and upward diffuse fluxes, incl_puding - ! scattered direct beam - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - - ! Flag to exit iteration loop: 0 = exit and 1 = iterate - irep = 1 - ! Iteration loop - iter = 0 - do while(irep ==1 .and. iter<50) - - iter = iter + 1 - irep = 0 - do L = 1,currentPatch%ncl_p !working from the top down - weighted_dif_down(L) = 0._r8 - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - ! forward diffuse flux within the canopy and at soil, working forward through canopy - ! with Dif_up -from previous iteration-. Dif_dn(1) is the forward diffuse flux onto the canopy. - ! Note: down = forward flux onto next layer - if (L == 1)then !is this the top layer? - Dif_dn(L,ft,1) = forc_dif(radtype) - else - Dif_dn(L,ft,1) = weighted_dif_down(L-1) - end if - down_rad = 0._r8 - - do iv = 1, currentPatch%nrad(L,ft) - ! down rad'n is the sum of the down and upwards reflected diffuse fluxes... - down_rad = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) + & - Dif_up(L,ft,iv+1) * refl_dif(L,ft,iv,ib) - - !... plus the direct beam intercepted and intransmitted by this layer. - down_rad = down_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - & - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & - currentPatch%esai_profile(L,ft,iv)) )) * tau_layer(L,ft,iv,ib) - - - !... plus the direct beam intercepted and intransmitted by this layer. - ! modified to spread it out over the whole of incomplete layers. - - down_rad = down_rad *(ftweight(L,ft,iv)/ftweight(L,ft,1)) - - if (iv > 1)then - if (lai_change(L,ft,iv-1) > 0.0_r8)then - down_rad = down_rad + Dif_dn(L,ft,iv) * lai_change(L,ft,iv-1)/ftweight(L,ft,1) - down_rad = down_rad + Dif_dn(L,ft,iv-1) * (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ & - ftweight(L,ft,1) - else - down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & - ftweight(L,ft,1) - endif - else - down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & - ftweight(L,ft,1) - endif - - !this is just Dif down, plus refl up, plus dir intercepted and turned into dif... , - if (abs(down_rad - Dif_dn(L,ft,iv+1)) > tolerance)then - irep = 1 - end if - Dif_dn(L,ft,iv+1) = down_rad - - end do !iv - - weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & - ftweight(L,ft,1) - - endif !present - end do!ft - if (L == currentPatch%ncl_p.and.currentPatch%ncl_p > 1)then !is this the (incomplete) understorey? - weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1) * & - (1.0_r8-sum(ftweight(L,1:numpft,1))) - end if - end do ! do L loop - - do L = 1, currentPatch%ncl_p ! working from the top down. - weighted_dif_up(L) = 0._r8 - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - ! Upward diffuse flux at soil or from lower canopy (forward diffuse and unscattered direct beam) - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%ncl_p)then !In the bottom canopy layer, reflect off the soil - Dif_up(L,ft,iv) = Dif_dn(L,ft,iv) * currentPatch%gnd_alb_dif(ib) + & - forc_dir(radtype) * tr_dir_z(L,ft,iv) * currentPatch%gnd_alb_dir(ib) - else !In the other canopy layers, reflect off the underlying vegetation. - Dif_up(L,ft,iv) = weighted_dif_up(L+1) - end if - - ! Upward diffuse flux within and above the canopy, working upward through canopy - ! with Dif_dn from previous interation. Note: up = upward flux above current layer - do iv = currentPatch%nrad(L,ft),1,-1 - !this is radiation up, by layer transmittance, by - - !reflection of the lower layer, - up_rad = Dif_dn(L,ft,iv) * refl_dif(L,ft,iv,ib) - up_rad = up_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - exp(-k_dir(ft) * & - (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))))* & - rho_layer(L,ft,iv,ib) - up_rad = up_rad + Dif_up(L,ft,iv+1) * tran_dif(L,ft,iv,ib) - up_rad = up_rad * ftweight(L,ft,iv)/ftweight(L,ft,1) - up_rad = up_rad + Dif_up(L,ft,iv+1) *(ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - ! THE LOWER LAYER FLUX IS HOMOGENIZED, SO WE DON"T CONSIDER THE LAI_CHANGE HERE... - - if (abs(up_rad - Dif_up(L,ft,iv)) > tolerance) then !are we close to the tolerance level? - irep = 1 - end if - Dif_up(L,ft,iv) = up_rad - - end do !iv - weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) - end if !present - end do!ft - - if (L == currentPatch%ncl_p.and.currentPatch%ncl_p > 1)then !is this the (incomplete) understorey? - !Add on the radiation coming up through the canopy gaps. - weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & - weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) - weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & - weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1)))*currentPatch%gnd_alb_dir(ib) - end if - end do!L - end do ! do while over iter - - abs_rad(ib) = 0._r8 - tr_soili = 0._r8 - tr_soild = 0._r8 - - do L = 1, currentPatch%ncl_p !working from the top down. - abs_dir_z(:,:) = 0._r8 - abs_dif_z(:,:) = 0._r8 - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - !==============================================================================! - ! Compute absorbed flux densities - !==============================================================================! - - ! Absorbed direct beam and diffuse do leaf layers - do iv = 1, currentPatch%nrad(L,ft) - Abs_dir_z(ft,iv) = ftweight(L,ft,iv)* forc_dir(radtype) * tr_dir_z(L,ft,iv) * & - (1.00_r8 - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & - currentPatch%esai_profile(L,ft,iv)) )) * f_abs(L,ft,iv,ib) - Abs_dif_z(ft,iv) = ftweight(L,ft,iv)* ((Dif_dn(L,ft,iv) + & - Dif_up(L,ft,iv+1)) * (1.00_r8 - tr_dif_z(L,ft,iv)) * f_abs(L,ft,iv,ib)) - end do - - ! Absorbed direct beam and diffuse do soil - if (L == currentPatch%ncl_p)then - iv = currentPatch%nrad(L,ft) + 1 - Abs_dif_z(ft,iv) = ftweight(L,ft,1)*Dif_dn(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dif(ib) ) - Abs_dir_z(ft,iv) = ftweight(L,ft,1)*forc_dir(radtype) * & - tr_dir_z(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dir(ib) ) - tr_soild = tr_soild + ftweight(L,ft,1)*forc_dir(radtype) * tr_dir_z(L,ft,iv) - tr_soili = tr_soili + ftweight(L,ft,1)*Dif_dn(L,ft,iv) - end if - - ! Absorbed radiation, shaded and sunlit portions of leaf layers - !here we get one unit of diffuse radiation... how much of - !it is absorbed? - if (ib == ivis) then ! only set the absorbed PAR for the visible light band. - do iv = 1, currentPatch%nrad(L,ft) - if (radtype==idirect) then - if ( debug ) then - write(fates_log(),*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) - write(fates_log(),*) 'EDsurfAlb 731 ', currentPatch%fabd_sha_z(L,ft,iv), & - currentPatch%fabd_sun_z(L,ft,iv) - endif - currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - (1._r8 - currentPatch%f_sun(L,ft,iv))*f_abs_leaf(L,ft,iv,ib) - currentPatch%fabd_sun_z(L,ft,iv) =( Abs_dif_z(ft,iv) * & - currentPatch%f_sun(L,ft,iv) + & - Abs_dir_z(ft,iv))*f_abs_leaf(L,ft,iv,ib) - else - currentPatch%fabi_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - (1._r8 - currentPatch%f_sun(L,ft,iv))*f_abs_leaf(L,ft,iv,ib) - currentPatch%fabi_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - currentPatch%f_sun(L,ft,iv)*f_abs_leaf(L,ft,iv,ib) - endif - if ( debug ) then - write(fates_log(),*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & - currentPatch%fabd_sun_z(L,ft,iv) - endif - end do - endif ! ib - - - !==============================================================================! - ! Sum fluxes - !==============================================================================! - ! Solar radiation absorbed by ground - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%ncl_p)then - abs_rad(ib) = abs_rad(ib) + (Abs_dir_z(ft,iv) + Abs_dif_z(ft,iv)) - end if - ! Solar radiation absorbed by vegetation and sunlit/shaded leaves - do iv = 1,currentPatch%nrad(L,ft) - if (radtype == idirect)then - currentPatch%fabd(ib) = currentPatch%fabd(ib) + & - Abs_dir_z(ft,iv)+Abs_dif_z(ft,iv) - ! bc_out(s)%fabd_parb_out(ib) = currentPatch%fabd(ib) - else - currentPatch%fabi(ib) = currentPatch%fabi(ib) + Abs_dif_z(ft,iv) - ! bc_out(s)%fabi_parb_out(ib) = currentPatch%fabi(ib) - endif - end do - - ! Albefor - if (L==1)then !top canopy layer. - if (radtype == idirect)then - albd_parb_out(ib) = albd_parb_out(ib) + & - Dif_up(L,ft,1) * ftweight(L,ft,1) - else - albi_parb_out(ib) = albi_parb_out(ib) + & - Dif_up(L,ft,1) * ftweight(L,ft,1) - end if - end if - - ! pass normalized PAR profiles for use in diagnostic averaging for history fields - if (ib == ivis) then ! only diagnose PAR profiles for the visible band - do iv = 1, currentPatch%nrad(L,ft) - currentPatch%nrmlzd_parprof_pft_dir_z(radtype,L,ft,iv) = & - forc_dir(radtype) * tr_dir_z(L,ft,iv) - - currentPatch%nrmlzd_parprof_pft_dif_z(radtype,L,ft,iv) = & - Dif_dn(L,ft,iv) + Dif_up(L,ft,iv) - - end do - end if ! ib = visible - end if ! present - end do !ft - if (radtype == idirect)then - fabd_parb_out(ib) = currentPatch%fabd(ib) - else - fabi_parb_out(ib) = currentPatch%fabi(ib) - endif - - - !radiation absorbed from fluxes through unfilled part of lower canopy. - if (currentPatch%ncl_p > 1.and.L == currentPatch%ncl_p)then - abs_rad(ib) = abs_rad(ib) + weighted_dif_down(L-1) * & - (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dif(ib) ) - abs_rad(ib) = abs_rad(ib) + forc_dir(radtype) * weighted_dir_tr(L-1) * & - (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dir(ib) ) - tr_soili = tr_soili + weighted_dif_down(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) - tr_soild = tr_soild + forc_dir(radtype) * weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) - endif - - if (radtype == idirect)then - currentPatch%tr_soil_dir(ib) = tr_soild - currentPatch%tr_soil_dir_dif(ib) = tr_soili - currentPatch%sabs_dir(ib) = abs_rad(ib) - ftdd_parb_out(ib) = tr_soild - ftid_parb_out(ib) = tr_soili - else - currentPatch%tr_soil_dif(ib) = tr_soili - currentPatch%sabs_dif(ib) = abs_rad(ib) - ftii_parb_out(ib) = tr_soili - end if - - end do!l - - - !==============================================================================! - ! Conservation check - !==============================================================================! - ! Total radiation balance: absorbed = incoming - outgoing - - if (radtype == idirect)then - error = abs(currentPatch%sabs_dir(ib) - (currentPatch%tr_soil_dir(ib) * & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + & - currentPatch%tr_soil_dir_dif(ib) * (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) - - if(debug)then - if ( abs(error) > 0.0001)then - write(fates_log(),*)'dir ground absorption error',error,currentPatch%sabs_dir(ib), & - currentPatch%tr_soil_dir(ib)* & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ),currentPatch%ncl_p,ib,sum(ftweight(1,1:numpft,1)) - write(fates_log(),*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ) - do ft =1,numpft - iv = currentPatch%nrad(1,ft) + 1 - write(fates_log(),*) 'abs soil fluxes', Abs_dir_z(ft,iv),Abs_dif_z(ft,iv) - end do - end if - end if - - else - if (debug) then - if ( abs(currentPatch%sabs_dif(ib)-(currentPatch%tr_soil_dif(ib) * & - (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) > 0.0001_r8)then - write(fates_log(),*)'dif ground absorption error',currentPatch%sabs_dif(ib) , & - (currentPatch%tr_soil_dif(ib)* & - (1.0_r8-currentPatch%gnd_alb_dif(ib) )),currentPatch%ncl_p,ib,sum(ftweight(1,1:numpft,1)) - endif - end if - endif - - if (radtype == idirect)then - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) - else - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) - endif - - ! ignore the current patch radiation error if the veg-covered fraction of the patch is really small - if ( (currentPatch%total_canopy_area / currentPatch%area) .gt. tolerance ) then - ! normalize rad error by the veg-covered fraction of the patch because that is - ! the only part that this code applies to - currentPatch%radiation_error = currentPatch%radiation_error + error & - * currentPatch%total_canopy_area / currentPatch%area - endif - - lai_reduction(:) = 0.0_r8 - do L = 1, currentPatch%ncl_p - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - do iv = 1, currentPatch%nrad(L,ft) - if (lai_change(L,ft,iv) > 0.0_r8)then - lai_reduction(L) = max(lai_reduction(L),lai_change(L,ft,iv)) - endif - enddo - endif - enddo - enddo - - if (radtype == idirect)then - !here we are adding a within-ED radiation scheme tolerance, and then adding the diffrence onto the albedo - !it is important that the lower boundary for this is ~1000 times smaller than the tolerance in surface albedo. - if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then - albd_parb_out(ib) = albd_parb_out(ib) + error - !this terms adds the error back on to the albedo. While this is partly inexcusable, it is - ! in the medium term a solution that - ! prevents the model from crashing with small and occasional energy balances issues. - ! These are extremely difficult to debug, many have been solved already, leading - ! to the complexity of this code, but where the system generates occasional errors, we - ! will deal with them for now. - end if - - if (abs(error) > 0.15_r8)then - if(debug)then - write(fates_log(),*) 'Large Dir Radn consvn error',error ,ib - write(fates_log(),*) 'diags', albd_parb_out(ib), ftdd_parb_out(ib), & - ftid_parb_out(ib), fabd_parb_out(ib) - write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'ftweight',ftweight(1,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno - write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) - end if - albd_parb_out(ib) = albd_parb_out(ib) + error - end if - else - - if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then - albi_parb_out(ib) = albi_parb_out(ib) + error - end if - - if (abs(error) > 0.15_r8)then - if(debug)then - write(fates_log(),*) 'lg Dif Radn consvn error',error ,ib - write(fates_log(),*) 'diags', albi_parb_out(ib), ftii_parb_out(ib), & - fabi_parb_out(ib) - !write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - !write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - !write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - !write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno - write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) - !write(fates_log(),*) 'rhol',rhol(1:numpft,:) - !write(fates_log(),*) 'ftw',sum(ftweight(1,1:numpft,1)),ftweight(1,1:numpft,1) - !write(fates_log(),*) 'present',currentPatch%canopy_mask(1,1:numpft) - !write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:numpft,1) - end if - albi_parb_out(ib) = albi_parb_out(ib) + error - end if - - if (radtype == idirect)then - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) - else - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) - endif - - if(debug) then - if (abs(error) > 0.00000001_r8)then - write(fates_log(),*) 'there is still error after correction',error ,ib - end if - end if - - end if - end do !hlm_numSWb - - enddo ! rad-type - - end associate - return - end subroutine PatchNormanRadiation - ! ====================================================================================== subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) @@ -1210,166 +288,174 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) do while (associated(cpatch)) - ! Initialize diagnostics - cpatch%ed_parsun_z(:,:,:) = 0._r8 - cpatch%ed_parsha_z(:,:,:) = 0._r8 - cpatch%parprof_pft_dir_z(:,:,:) = 0._r8 - cpatch%parprof_pft_dif_z(:,:,:) = 0._r8 - if_notbareground:if(cpatch%nocomp_pft_label.ne.nocomp_bareground)then !only for veg patches ! do not do albedo calculations for bare ground patch in SP mode ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein ! ifp=1 is the first vegetated patch. ifp=ifp+1 - bc_out(s)%fsun_pa(ifp) = 0._r8 - bc_out(s)%laisun_pa(ifp) = 0._r8 - bc_out(s)%laisha_pa(ifp) = calc_areaindex(cpatch,'elai') - - ! If there is no sun out, we have a trivial solution - if_zenithflag: if(cpatch%solar_zenith_flag ) then - - sunlai = 0._r8 - shalai = 0._r8 - if_norm_twostr: if (radiation_model.eq.norman_solver) then + ! Initialize diagnostics + cpatch%ed_parsun_z(:,:,:) = 0._r8 + cpatch%ed_parsha_z(:,:,:) = 0._r8 - ! Loop over patches to calculate laisun_z and laisha_z for each layer. - ! Derive canopy laisun, laisha, and fsun from layer sums. - ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from - ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. + cpatch%parprof_pft_dir_z(:,:,:) = 0._r8 + cpatch%parprof_pft_dif_z(:,:,:) = 0._r8 - ! cpatch%f_sun is calculated in the surface_albedo routine... + bc_out(s)%fsun_pa(ifp) = 0._r8 - do cl = 1, cpatch%ncl_p - do ft = 1,numpft + if(.not.preserve_b4b)then + bc_out(s)%laisun_pa(ifp) = 0._r8 + bc_out(s)%laisha_pa(ifp) = calc_areaindex(cpatch,'elai') + end if - !needed for the VOC emissions, etc. + sunlai = 0._r8 + shalai = 0._r8 + if_norm_twostr: if (radiation_model.eq.norman_solver) then + + ! Loop over patches to calculate laisun_z and laisha_z for each layer. + ! Derive canopy laisun, laisha, and fsun from layer sums. + ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from + ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. + + ! cpatch%f_sun is calculated in the surface_albedo routine... + + do cl = 1, cpatch%ncl_p + do ft = 1,numpft + if(.not.preserve_b4b) then sunlai = sunlai + sum(cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & cpatch%f_sun(cl,ft,1:cpatch%nrad(cl,ft))) shalai = shalai + sum(cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft))) - - end do + else + do iv = 1,cpatch%nrad(cl,ft) + sunlai = sunlai + cpatch%elai_profile(cl,ft,iv) * & + cpatch%f_sun(cl,ft,iv) + shalai = shalai + cpatch%elai_profile(cl,ft,iv) * & + (1._r8 - cpatch%f_sun(cl,ft,iv)) + end do + end if end do + end do + if(.not.preserve_b4b)then shalai = shalai-sunlai - - if(sunlai+shalai > 0._r8)then - bc_out(s)%fsun_pa(ifp) = sunlai / (sunlai+shalai) - else - bc_out(s)%fsun_pa(ifp) = 0._r8 - endif - - if(debug)then - if(bc_out(s)%fsun_pa(ifp) > 1._r8)then - write(fates_log(),*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & - sunlai,shalai - endif - end if - - elai = calc_areaindex(cpatch,'elai') - - bc_out(s)%laisun_pa(ifp) = elai*bc_out(s)%fsun_pa(ifp) - bc_out(s)%laisha_pa(ifp) = elai*(1.0_r8-bc_out(s)%fsun_pa(ifp)) - - ! Absorbed PAR profile through canopy - ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo - ! are canopy integrated so that layer values equal big leaf values. - - do cl = 1, cpatch%ncl_p - do ft = 1,numpft - do iv = 1, cpatch%nrad(cl,ft) - - cpatch%ed_parsun_z(cl,ft,iv) = & - bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(cl,ft,iv) + & - bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(cl,ft,iv) - - if ( debug )write(fates_log(),*) 'edsurfRad 663 ', cpatch%ed_parsun_z(cl,ft,iv) - - cpatch%ed_parsha_z(cl,ft,iv) = & - bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sha_z(cl,ft,iv) + & - bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sha_z(cl,ft,iv) - - if ( debug ) write(fates_log(),*) 'edsurfRad 669 ', cpatch%ed_parsha_z(cl,ft,iv) - - end do !iv - end do !ft - end do !cl - - ! Convert normalized radiation error units from fraction of radiation to W/m2 - cpatch%radiation_error = cpatch%radiation_error * (bc_in(s)%solad_parb(ifp,ipar) + & - bc_in(s)%solai_parb(ifp,ipar)) - - ! output the actual PAR profiles through the canopy for diagnostic purposes - do cl = 1, cpatch%ncl_p - do ft = 1,numpft - do iv = 1, cpatch%nrad(cl,ft) - cpatch%parprof_pft_dir_z(cl,ft,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dir_z(idirect,cl,ft,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dir_z(idiffuse,cl,ft,iv)) - - cpatch%parprof_pft_dif_z(cl,ft,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dif_z(idirect,cl,ft,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dif_z(idiffuse,cl,ft,iv)) - - end do ! iv - end do ! ft - end do ! cl - + end if + + if(sunlai+shalai > 0._r8)then + bc_out(s)%fsun_pa(ifp) = sunlai / (sunlai+shalai) else + bc_out(s)%fsun_pa(ifp) = 0._r8 + endif + + if(debug)then + if(bc_out(s)%fsun_pa(ifp) > 1._r8)then + write(fates_log(),*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & + sunlai,shalai + endif + end if + + elai = calc_areaindex(cpatch,'elai') + + bc_out(s)%laisun_pa(ifp) = elai*bc_out(s)%fsun_pa(ifp) + bc_out(s)%laisha_pa(ifp) = elai*(1.0_r8-bc_out(s)%fsun_pa(ifp)) + + ! Absorbed PAR profile through canopy + ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo + ! are canopy integrated so that layer values equal big leaf values. + + do cl = 1, cpatch%ncl_p + do ft = 1,numpft + do iv = 1, cpatch%nrad(cl,ft) + + cpatch%ed_parsun_z(cl,ft,iv) = & + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(cl,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(cl,ft,iv) + + cpatch%ed_parsha_z(cl,ft,iv) = & + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sha_z(cl,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sha_z(cl,ft,iv) + + end do !iv + end do !ft + end do !cl + + ! Convert normalized radiation error units from fraction of radiation to W/m2 + cpatch%radiation_error = cpatch%radiation_error * (bc_in(s)%solad_parb(ifp,ipar) + & + bc_in(s)%solai_parb(ifp,ipar)) + + ! output the actual PAR profiles through the canopy for diagnostic purposes + do cl = 1, cpatch%ncl_p + do ft = 1,numpft + do iv = 1, cpatch%nrad(cl,ft) + cpatch%parprof_pft_dir_z(cl,ft,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dir_z(idirect,cl,ft,iv)) + & + (bc_in(s)%solai_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dir_z(idiffuse,cl,ft,iv)) + + cpatch%parprof_pft_dif_z(cl,ft,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dif_z(idirect,cl,ft,iv)) + & + (bc_in(s)%solai_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dif_z(idiffuse,cl,ft,iv)) + + end do ! iv + end do ! ft + end do ! cl + + else + ! If there is no sun out, we have a trivial solution + if_zenithflag: if(cpatch%solar_zenith_flag ) then + ! Two-stream ! ----------------------------------------------------------- do ib = 1,hlm_numSWb cpatch%twostr%band(ib)%Rbeam_atm = bc_in(s)%solad_parb(ifp,ib) cpatch%twostr%band(ib)%Rdiff_atm = bc_in(s)%solai_parb(ifp,ib) end do - + area_vlpfcl(:,:,:) = 0._r8 cpatch%f_sun(:,:,:) = 0._r8 - + call FatesPatchFSun(cpatch, & bc_out(s)%fsun_pa(ifp), & bc_out(s)%laisun_pa(ifp), & bc_out(s)%laisha_pa(ifp)) - + associate(twostr => cpatch%twostr) - + do_cl: do cl = 1,twostr%n_lyr do_icol: do icol = 1,twostr%n_col(cl) - + ft = twostr%scelg(cl,icol)%pft if_notair: if (ft>0) then area_frac = twostr%scelg(cl,icol)%area vai = twostr%scelg(cl,icol)%sai+twostr%scelg(cl,icol)%lai nv = minloc(dlower_vai, DIM=1, MASK=(dlower_vai>vai)) do iv = 1, nv - + vai_top = dlower_vai(iv)-dinc_vai(iv) vai_bot = min(dlower_vai(iv),twostr%scelg(cl,icol)%sai+twostr%scelg(cl,icol)%lai) - + cpatch%parprof_pft_dir_z(cl,ft,iv) = cpatch%parprof_pft_dir_z(cl,ft,iv) + & area_frac*twostr%GetRb(cl,icol,ivis,vai_top) cpatch%parprof_pft_dif_z(cl,ft,iv) = cpatch%parprof_pft_dif_z(cl,ft,iv) + & area_frac*twostr%GetRdDn(cl,icol,ivis,vai_top) + & area_frac*twostr%GetRdUp(cl,icol,ivis,vai_top) - + call twostr%GetAbsRad(cl,icol,ipar,vai_top,vai_bot, & Rb_abs,Rd_abs,Rd_abs_leaf,Rb_abs_leaf,R_abs_stem,R_abs_snow,leaf_sun_frac) - + cpatch%f_sun(cl,ft,iv) = cpatch%f_sun(cl,ft,iv) + & area_frac*leaf_sun_frac cpatch%ed_parsun_z(cl,ft,iv) = cpatch%ed_parsun_z(cl,ft,iv) + & area_frac*(rd_abs_leaf*leaf_sun_frac + rb_abs_leaf) cpatch%ed_parsha_z(cl,ft,iv) = cpatch%ed_parsha_z(cl,ft,iv) + & area_frac*rd_abs_leaf*(1._r8-leaf_sun_frac) - + area_vlpfcl(iv,ft,cl) = area_vlpfcl(iv,ft,cl) + area_frac end do end if if_notair end do do_icol - + do ft = 1,numpft do_iv: do iv = 1, nlevleaf if(area_vlpfcl(iv,ft,cl) cpatch%younger enddo From 8cc57c9a3926bf489aac2121d11384d4ef1753a0 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 12 Dec 2023 21:29:43 -0700 Subject: [PATCH 216/250] fixed some typos --- main/FatesRestartInterfaceMod.F90 | 2 +- radiation/FatesNormanRadMod.F90 | 16 ++++++++-------- radiation/FatesRadiationDriveMod.F90 | 4 ++-- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 7c9fe0b964..534ef6ae33 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -3606,7 +3606,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) ! called upon restart reads. ! ------------------------------------------------------------------------- - use FatesRadiationDriveMod, only : PatchNormanRadiation + use FatesNormanRadMod, only : PatchNormanRadiation use EDTypesMod, only : ed_site_type use FatesPatchMod, only : fates_patch_type use FatesInterfaceTypesMod, only : hlm_numSWb diff --git a/radiation/FatesNormanRadMod.F90 b/radiation/FatesNormanRadMod.F90 index 380331468f..7da38a34ce 100644 --- a/radiation/FatesNormanRadMod.F90 +++ b/radiation/FatesNormanRadMod.F90 @@ -808,14 +808,14 @@ subroutine PatchNormanRadiation (currentPatch, & currentPatch%nrmlzd_parprof_pft_dif_z(radtype,L,ft,iv) = & Dif_dn(L,ft,iv) + Dif_up(L,ft,iv) ! - currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) = & - currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) + & - (forc_dir(radtype) * tr_dir_z(L,ft,iv)) * & - (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) - currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) = & - currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) + & - (Dif_dn(L,ft,iv) + Dif_up(L,ft,iv)) * & - (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) + !currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) = & + ! currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) + & + ! (forc_dir(radtype) * tr_dir_z(L,ft,iv)) * & + ! (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) + !currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) = & + ! currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) + & + ! (Dif_dn(L,ft,iv) + Dif_up(L,ft,iv)) * & + ! (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) end do end if ! ib = visible end if ! present diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index 36a5394913..28d978ebac 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -41,7 +41,7 @@ module FatesRadiationDriveMod use FatesGlobals , only : fates_log use FatesGlobals, only : endrun => fates_endrun use EDPftvarcon, only : EDPftvarcon_inst - use FatesNormanRadMod only : PatchNormanRadiation + use FatesNormanRadMod, only : PatchNormanRadiation ! CIME globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -108,7 +108,7 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) if_notbareground: if(currentpatch%nocomp_pft_label.ne.nocomp_bareground)then - ipf = ipf+1 + ifp = ifp+1 ! Zero diagnostics currentPatch%f_sun (:,:,:) = 0._r8 From 7abc732d997add36d649d3e90e7f2c29a45e1cfb Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 13 Dec 2023 11:47:12 -0500 Subject: [PATCH 217/250] cleaning up photosynthesis code w/two-stream --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 4295 ++++++++++---------- 1 file changed, 2126 insertions(+), 2169 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 63dfbf3d36..db1ea5e367 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -83,9 +83,9 @@ module FATESPlantRespPhotosynthMod character(len=*), parameter, private :: sourcefile = & __FILE__ - + character(len=1024) :: warn_msg ! for defining a warning message - + !------------------------------------------------------------------------------------- ! maximum stomatal resistance [s/m] (used across several procedures) @@ -108,7 +108,7 @@ module FATESPlantRespPhotosynthMod ! Constants used to define conductance models integer, parameter :: medlyn_model = 2 integer, parameter :: ballberry_model = 1 - + ! Alternatively, Gross Assimilation can be used to estimate ! leaf co2 partial pressure and therefore conductance. The default ! is to use anet @@ -116,7 +116,7 @@ module FATESPlantRespPhotosynthMod integer, parameter :: gross_assim_model = 2 logical, parameter :: preserve_b4b = .true. - + contains !-------------------------------------------------------------------------------------- @@ -150,7 +150,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) use DamageMainMod, only : GetCrownReduction use FatesInterfaceTypesMod, only : hlm_use_tree_damage - + ! ARGUMENTS: ! ----------------------------------------------------------------------------------- integer,intent(in) :: nsites @@ -238,14 +238,14 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: maintresp_reduction_factor ! factor by which to reduce maintenance - ! respiration when storage pools are low + ! respiration when storage pools are low real(r8) :: b_leaf ! leaf biomass kgC real(r8) :: frac ! storage pool as a fraction of target leaf biomass ! over each cohort x layer. real(r8) :: cohort_eleaf_area ! This is the effective leaf area [m2] reported by each cohort real(r8) :: lnc_top ! Leaf nitrogen content per unit area at canopy top [gN/m2] real(r8) :: lmr25top ! canopy top leaf maint resp rate at 25C - ! for this plant or pft (umol CO2/m**2/s) + ! for this plant or pft (umol CO2/m**2/s) real(r8) :: leaf_inc ! LAI-only portion of the vegetation increment of dinc_vai real(r8) :: lai_canopy_above ! the LAI in the canopy layers above the layer of interest real(r8) :: lai_layers_above ! the LAI in the leaf layers, within the current canopy, @@ -306,8 +306,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! Photosynthesis and stomatal conductance parameters, from: ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 ! ----------------------------------------------------------------------------------- - - + + associate( & c3psn => EDPftvarcon_inst%c3psn , & @@ -317,2261 +317,2218 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) stomatal_intercept => EDPftvarcon_inst%stomatal_intercept ) !Unstressed minimum stomatal conductance - do s = 1,nsites + do s = 1,nsites + + ! Multi-layer parameters scaled by leaf nitrogen profile. + ! Loop through each canopy layer to calculate nitrogen profile using + ! cumulative lai at the midpoint of the layer + + + + ! Pre-process some variables that are PFT dependent + ! but not environmentally dependent + ! ------------------------------------------------------------------------ + + allocate(rootfr_ft(numpft, bc_in(s)%nlevsoil)) + + do ft = 1,numpft + call set_root_fraction(rootfr_ft(ft,:), ft, & + bc_in(s)%zi_sisl, & + bc_in(s)%max_rooting_depth_index_col) + end do + + + ifp = 0 + currentpatch => sites(s)%oldest_patch + do while (associated(currentpatch)) + if_notbare: if(currentpatch%nocomp_pft_label.ne.nocomp_bareground)then + ifp = ifp+1 + NCL_p = currentPatch%NCL_p + + ! Part I. Zero output boundary conditions + ! --------------------------------------------------------------------------- + bc_out(s)%rssun_pa(ifp) = 0._r8 + bc_out(s)%rssha_pa(ifp) = 0._r8 + + g_sb_leaves = 0._r8 + patch_la = 0._r8 + + ! Part II. Filter out patches + ! Patch level filter flag for photosynthesis calculations + ! has a short memory, flags: + ! 1 = patch has not been called + ! 2 = patch is currently marked for photosynthesis + ! 3 = patch has been called for photosynthesis already + ! --------------------------------------------------------------------------- + if_filter2: if(bc_in(s)%filter_photo_pa(ifp)==2)then + + + ! Part III. Calculate the number of sublayers for each pft and layer. + ! And then identify which layer/pft combinations have things in them. + ! Output: + ! currentPatch%ncan(:,:) + ! currentPatch%canopy_mask(:,:) + call UpdateCanopyNCanNRadPresent(currentPatch) + + + ! Part IV. Identify some environmentally derived parameters: + ! These quantities are biologically irrelevant + ! Michaelis-Menten constant for CO2 (Pa) + ! Michaelis-Menten constant for O2 (Pa) + ! CO2 compensation point (Pa) + ! leaf boundary layer conductance of h20 + ! constrained vapor pressure + + call GetCanopyGasParameters(bc_in(s)%forc_pbot, & ! in + bc_in(s)%oair_pa(ifp), & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + bc_in(s)%tgcm_pa(ifp), & ! in + bc_in(s)%eair_pa(ifp), & ! in + bc_in(s)%esat_tv_pa(ifp), & ! in + bc_in(s)%rb_pa(ifp), & ! in + mm_kco2, & ! out + mm_ko2, & ! out + co2_cpoint, & ! out + cf, & ! out + gb_mol, & ! out + ceair) ! out + + ! ------------------------------------------------------------------------ + ! Part VI: Loop over all leaf layers. + ! The concept of leaf layers is a result of the radiative transfer scheme. + ! A leaf layer has uniform radiation environment. Leaf layers are a group + ! of vegetation surfaces (stems and leaves) which inhabit the same + ! canopy-layer "CL", have the same functional type "ft" and within those + ! two partitions are further partitioned into vertical layers where + ! downwelling radiation attenuates in order. + ! In this phase we loop over the leaf layers and calculate the + ! photosynthesis and respiration of the layer (since all biophysical + ! properties are homogeneous). After this step, we can loop through + ! our cohort list, associate each cohort with its list of leaf-layers + ! and transfer these quantities to the cohort. + ! With plant hydraulics, we must realize that photosynthesis and + ! respiration will be different for leaves of each cohort in the leaf + ! layers, as they will have there own hydraulic limitations. + ! NOTE: Only need to flush mask on the number of used pfts, not the whole + ! scratch space. + ! ------------------------------------------------------------------------ + rate_mask_z(:,1:numpft,:) = .false. + + if_any_cohorts: if(currentPatch%countcohorts > 0.0)then + currentCohort => currentPatch%tallest + do_cohort_drive: do while (associated(currentCohort)) ! Cohort loop + + ! Identify the canopy layer (cl), functional type (ft) + ! and the leaf layer (IV) for this cohort + ft = currentCohort%pft + cl = currentCohort%canopy_layer + + ! Calculate the cohort specific elai profile + ! And the top and bottom edges of the veg area index + ! of each layer bin are. Note, if the layers + ! sink below the ground snow line, then the effective + ! LAI and SAI start to shrink to zero, as well as + ! the difference between vaitop and vaibot. + if(currentCohort%treesai>0._r8)then + do iv = 1,currentCohort%nv + call VegAreaLayer(currentCohort%treelai, & + currentCohort%treesai, & + currentCohort%height, & + iv, & + currentCohort%nv, & + currentCohort%pft, & + sites(s)%snow_depth, & + cohort_vaitop(iv), & + cohort_vaibot(iv), & + cohort_layer_elai(iv), & + cohort_layer_esai(iv)) + end do + + cohort_elai = sum(cohort_layer_elai(1:currentCohort%nv)) + cohort_esai = sum(cohort_layer_esai(1:currentCohort%nv)) + + + else + cohort_layer_elai(:) = 0._r8 + cohort_layer_esai(:) = 0._r8 + cohort_vaitop(:) = 0._r8 + cohort_vaibot(:) = 0._r8 + cohort_elai = 0._r8 + cohort_esai = 0._r8 + end if + + ! MLO. Assuming target to be related to leaf biomass when leaves are fully + ! flushed. But unsure whether this call is correct or not, shouldn't we get + ! the target value directly from the bstore_allom? + call bleaf(currentCohort%dbh,currentCohort%pft,& + currentCohort%crowndamage,currentCohort%canopy_trim,1.0_r8,store_c_target) + ! call bstore_allom(currentCohort%dbh,currentCohort%pft, & + ! currentCohort%canopy_trim,store_c_target) + + call storage_fraction_of_target(store_c_target, & + currentCohort%prt%GetState(store_organ, carbon12_element), & + frac) + call lowstorage_maintresp_reduction(frac,currentCohort%pft, & + maintresp_reduction_factor) + + ! are there any leaves of this pft in this layer? + canopy_mask_if: if(currentPatch%canopy_mask(cl,ft) == 1)then + + ! Loop over leaf-layers + leaf_layer_loop : do iv = 1,currentCohort%nv + + ! ------------------------------------------------------------ + ! If we are doing plant hydro-dynamics (or any run-type + ! where cohorts may generate different photosynthetic rates + ! of other cohorts in the same canopy-pft-layer combo), + ! we re-calculate the leaf biophysical rates for the + ! cohort-layer combo of interest. + ! but in the vanilla case, we only re-calculate if it has + ! not been done yet. + ! Other cases where we need to solve for every cohort + ! in every leaf layer: nutrient dynamic mode, multiple leaf + ! age classes + ! ------------------------------------------------------------ + + rate_mask_if: if ( .not.rate_mask_z(iv,ft,cl) .or. & + (hlm_use_planthydro.eq.itrue) .or. & + (radiation_model .eq. twostr_solver ) .or. & + (nleafage > 1) .or. & + (hlm_parteh_mode .ne. prt_carbon_allom_hyp ) ) then + + if (hlm_use_planthydro.eq.itrue ) then + + stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentCohort%co_hydr%btran ) + btran_eff = currentCohort%co_hydr%btran + + ! dinc_vai(:) is the total vegetation area index of each "leaf" layer + ! we convert to the leaf only portion of the increment + ! ------------------------------------------------------ + leaf_inc = dinc_vai(iv) * & + currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) + + ! Now calculate the cumulative top-down lai of the current layer's midpoint + lai_canopy_above = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + + lai_layers_above = (dlower_vai(iv) - dinc_vai(iv)) * & + currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) + lai_current = min(leaf_inc, currentCohort%treelai - lai_layers_above) + cumulative_lai = lai_canopy_above + lai_layers_above + 0.5*lai_current + + leaf_psi = currentCohort%co_hydr%psi_ag(1) + + else + + stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentPatch%btran_ft(ft) ) - ! Multi-layer parameters scaled by leaf nitrogen profile. - ! Loop through each canopy layer to calculate nitrogen profile using - ! cumulative lai at the midpoint of the layer + btran_eff = currentPatch%btran_ft(ft) + ! For consistency sake, we use total LAI here, and not exposed + ! if the plant is under-snow, it will be effectively dormant for + ! the purposes of nscaler + + cumulative_lai = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + & + sum(currentPatch%tlai_profile(cl,ft,1:iv-1)) + & + 0.5*currentPatch%tlai_profile(cl,ft,iv) + leaf_psi = fates_unset_r8 + end if - ! Pre-process some variables that are PFT dependent - ! but not environmentally dependent - ! ------------------------------------------------------------------------ + if(do_fates_salinity)then + btran_eff = btran_eff*currentPatch%bstress_sal_ft(ft) + endif - allocate(rootfr_ft(numpft, bc_in(s)%nlevsoil)) - do ft = 1,numpft - call set_root_fraction(rootfr_ft(ft,:), ft, & - bc_in(s)%zi_sisl, & - bc_in(s)%max_rooting_depth_index_col) - end do - - - ifp = 0 - currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) - if_notbare: if(currentpatch%nocomp_pft_label.ne.nocomp_bareground)then - ifp = ifp+1 - NCL_p = currentPatch%NCL_p - - ! Part I. Zero output boundary conditions - ! --------------------------------------------------------------------------- - bc_out(s)%rssun_pa(ifp) = 0._r8 - bc_out(s)%rssha_pa(ifp) = 0._r8 - - g_sb_leaves = 0._r8 - patch_la = 0._r8 - - ! Part II. Filter out patches - ! Patch level filter flag for photosynthesis calculations - ! has a short memory, flags: - ! 1 = patch has not been called - ! 2 = patch is currently marked for photosynthesis - ! 3 = patch has been called for photosynthesis already - ! --------------------------------------------------------------------------- - if_filter2: if(bc_in(s)%filter_photo_pa(ifp)==2)then - - - ! Part III. Calculate the number of sublayers for each pft and layer. - ! And then identify which layer/pft combinations have things in them. - ! Output: - ! currentPatch%ncan(:,:) - ! currentPatch%canopy_mask(:,:) - call UpdateCanopyNCanNRadPresent(currentPatch) - - - ! Part IV. Identify some environmentally derived parameters: - ! These quantities are biologically irrelevant - ! Michaelis-Menten constant for CO2 (Pa) - ! Michaelis-Menten constant for O2 (Pa) - ! CO2 compensation point (Pa) - ! leaf boundary layer conductance of h20 - ! constrained vapor pressure - - call GetCanopyGasParameters(bc_in(s)%forc_pbot, & ! in - bc_in(s)%oair_pa(ifp), & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - bc_in(s)%tgcm_pa(ifp), & ! in - bc_in(s)%eair_pa(ifp), & ! in - bc_in(s)%esat_tv_pa(ifp), & ! in - bc_in(s)%rb_pa(ifp), & ! in - mm_kco2, & ! out - mm_ko2, & ! out - co2_cpoint, & ! out - cf, & ! out - gb_mol, & ! out - ceair) ! out - - ! ------------------------------------------------------------------------ - ! Part VI: Loop over all leaf layers. - ! The concept of leaf layers is a result of the radiative transfer scheme. - ! A leaf layer has uniform radiation environment. Leaf layers are a group - ! of vegetation surfaces (stems and leaves) which inhabit the same - ! canopy-layer "CL", have the same functional type "ft" and within those - ! two partitions are further partitioned into vertical layers where - ! downwelling radiation attenuates in order. - ! In this phase we loop over the leaf layers and calculate the - ! photosynthesis and respiration of the layer (since all biophysical - ! properties are homogeneous). After this step, we can loop through - ! our cohort list, associate each cohort with its list of leaf-layers - ! and transfer these quantities to the cohort. - ! With plant hydraulics, we must realize that photosynthesis and - ! respiration will be different for leaves of each cohort in the leaf - ! layers, as they will have there own hydraulic limitations. - ! NOTE: Only need to flush mask on the number of used pfts, not the whole - ! scratch space. - ! ------------------------------------------------------------------------ - rate_mask_z(:,1:numpft,:) = .false. - - if(currentPatch%countcohorts > 0.0)then - currentCohort => currentPatch%tallest - do_cohort_drive: do while (associated(currentCohort)) ! Cohort loop - - ! Identify the canopy layer (cl), functional type (ft) - ! and the leaf layer (IV) for this cohort - ft = currentCohort%pft - cl = currentCohort%canopy_layer - - ! Calculate the cohort specific elai profile - ! And the top and bottom edges of the veg area index - ! of each layer bin are. Note, if the layers - ! sink below the ground snow line, then the effective - ! LAI and SAI start to shrink to zero, as well as - ! the difference between vaitop and vaibot. - if(currentCohort%treesai>0._r8)then - do iv = 1,currentCohort%nv - call VegAreaLayer(currentCohort%treelai, & - currentCohort%treesai, & - currentCohort%height, & - iv, & - currentCohort%nv, & - currentCohort%pft, & - sites(s)%snow_depth, & - cohort_vaitop(iv), & - cohort_vaibot(iv), & - cohort_layer_elai(iv), & - cohort_layer_esai(iv)) - end do - - cohort_elai = sum(cohort_layer_elai(1:currentCohort%nv)) - cohort_esai = sum(cohort_layer_esai(1:currentCohort%nv)) - + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 used + ! kn = 0.11. Here, derive kn from vcmax25 as in Lloyd et al + ! (2010) Biogeosciences, 7, 1833-1859 - else - cohort_layer_elai(:) = 0._r8 - cohort_layer_esai(:) = 0._r8 - cohort_vaitop(:) = 0._r8 - cohort_vaibot(:) = 0._r8 - cohort_elai = 0._r8 - cohort_esai = 0._r8 - end if - - ! MLO. Assuming target to be related to leaf biomass when leaves are fully - ! flushed. But unsure whether this call is correct or not, shouldn't we get - ! the target value directly from the bstore_allom? - call bleaf(currentCohort%dbh,currentCohort%pft,& - currentCohort%crowndamage,currentCohort%canopy_trim,1.0_r8,store_c_target) - ! call bstore_allom(currentCohort%dbh,currentCohort%pft, & - ! currentCohort%canopy_trim,store_c_target) - - call storage_fraction_of_target(store_c_target, & - currentCohort%prt%GetState(store_organ, carbon12_element), & - frac) - call lowstorage_maintresp_reduction(frac,currentCohort%pft, & - maintresp_reduction_factor) - - ! are there any leaves of this pft in this layer? - canopy_mask_if: if(currentPatch%canopy_mask(cl,ft) == 1)then - - ! Loop over leaf-layers - leaf_layer_loop : do iv = 1,currentCohort%nv - - ! ------------------------------------------------------------ - ! If we are doing plant hydro-dynamics (or any run-type - ! where cohorts may generate different photosynthetic rates - ! of other cohorts in the same canopy-pft-layer combo), - ! we re-calculate the leaf biophysical rates for the - ! cohort-layer combo of interest. - ! but in the vanilla case, we only re-calculate if it has - ! not been done yet. - ! Other cases where we need to solve for every cohort - ! in every leaf layer: nutrient dynamic mode, multiple leaf - ! age classes - ! ------------------------------------------------------------ + kn = decay_coeff_kn(ft,currentCohort%vcmax25top) - rate_mask_if: if ( .not.rate_mask_z(iv,ft,cl) .or. & - (hlm_use_planthydro.eq.itrue) .or. & - (radiation_model .eq. twostr_solver ) .or. & - (nleafage > 1) .or. & - (hlm_parteh_mode .ne. prt_carbon_allom_hyp ) ) then - - if (hlm_use_planthydro.eq.itrue ) then + ! Scale for leaf nitrogen profile + nscaler = exp(-kn * cumulative_lai) - stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentCohort%co_hydr%btran ) - btran_eff = currentCohort%co_hydr%btran + ! Leaf maintenance respiration to match the base rate used in CN + ! but with the new temperature functions for C3 and C4 plants. - ! dinc_vai(:) is the total vegetation area index of each "leaf" layer - ! we convert to the leaf only portion of the increment - ! ------------------------------------------------------ - leaf_inc = dinc_vai(iv) * & - currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) + ! CN respiration has units: g C / g N [leaf] / s. This needs to be + ! converted from g C / g N [leaf] / s to umol CO2 / m**2 [leaf] / s - ! Now calculate the cumulative top-down lai of the current layer's midpoint - lai_canopy_above = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + ! Then scale this value at the top of the canopy for canopy depth + ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp) - lai_layers_above = (dlower_vai(iv) - dinc_vai(iv)) * & - currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) - lai_current = min(leaf_inc, currentCohort%treelai - lai_layers_above) - cumulative_lai = lai_canopy_above + lai_layers_above + 0.5*lai_current - - leaf_psi = currentCohort%co_hydr%psi_ag(1) - - else - - stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentPatch%btran_ft(ft) ) - - btran_eff = currentPatch%btran_ft(ft) - ! For consistency sake, we use total LAI here, and not exposed - ! if the plant is under-snow, it will be effectively dormant for - ! the purposes of nscaler - - cumulative_lai = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + & - sum(currentPatch%tlai_profile(cl,ft,1:iv-1)) + & - 0.5*currentPatch%tlai_profile(cl,ft,iv) - - leaf_psi = fates_unset_r8 - - end if - - if(do_fates_salinity)then - btran_eff = btran_eff*currentPatch%bstress_sal_ft(ft) - endif - - - ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 used - ! kn = 0.11. Here, derive kn from vcmax25 as in Lloyd et al - ! (2010) Biogeosciences, 7, 1833-1859 - - kn = decay_coeff_kn(ft,currentCohort%vcmax25top) - - ! Scale for leaf nitrogen profile - nscaler = exp(-kn * cumulative_lai) - - ! Leaf maintenance respiration to match the base rate used in CN - ! but with the new temperature functions for C3 and C4 plants. - - ! CN respiration has units: g C / g N [leaf] / s. This needs to be - ! converted from g C / g N [leaf] / s to umol CO2 / m**2 [leaf] / s - - ! Then scale this value at the top of the canopy for canopy depth - ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) - select case(hlm_parteh_mode) - case (prt_carbon_allom_hyp) - - lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) - - case (prt_cnp_flex_allom_hyp) - - leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element) - if( (leaf_c*slatop(ft)) > nearzero) then - leaf_n = currentCohort%prt%GetState(leaf_organ, nitrogen_element) - lnc_top = leaf_n / (slatop(ft) * leaf_c ) - else - lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) - end if - - ! If one wants to break coupling with dynamic N conentrations, - ! use the stoichiometry parameter - ! lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) - - end select - - ! Part VII: Calculate dark respiration (leaf maintenance) for this layer - - select case (maintresp_leaf_model) - - case (lmrmodel_ryan_1991) - - call LeafLayerMaintenanceRespiration_Ryan_1991( lnc_top, & ! in - nscaler, & ! in - ft, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - lmr_z(iv,ft,cl)) ! out - - case (lmrmodel_atkin_etal_2017) - - call LeafLayerMaintenanceRespiration_Atkin_etal_2017(lnc_top, & ! in - nscaler, & ! in - ft, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - currentPatch%tveg_lpa%GetMean(), & ! in - lmr_z(iv,ft,cl)) ! out - - case default - - write (fates_log(),*)'error, incorrect leaf respiration model specified' - call endrun(msg=errMsg(sourcefile, __LINE__)) - - end select - - ! Pre-process PAR absorbed per unit leaf area for different schemes - ! par_per_sunla = [W absorbed beam+diffuse radiation / m2 of sunlit leaves] - ! par_per_shala = [W absorbed diffuse radiation / m2 of shaded leaves] - ! fsun = [m2 of sunlit leaves / m2 of total leaves] - ! ------------------------------------------------------------------ - - if_radsolver: if(radiation_model.eq.norman_solver) then - - laisun = currentPatch%elai_profile(cl,ft,iv)*currentPatch%f_sun(cl,ft,iv) - laisha = currentPatch%elai_profile(cl,ft,iv)*(1._r8-currentPatch%f_sun(cl,ft,iv)) - - if_nonnzero_lai: if((laisun+laisha)>0._r8) then - - if(((laisun*currentPatch%canopy_area_profile(cl,ft,iv)) >0.0000000001_r8)) then ! .and. & - !(currentPatch%ed_parsun_z(cl,ft,iv)>nearzero)) then - - ! laisun: m2 of exposed leaf, per m2 of crown. If this is the lowest layer - ! for the pft/canopy group, than the m2 per crown is probably not - ! as large as the layer above. - ! ed_parsun_z: this is W/m2 ground times the canopy_area_profile, which is the - ! fraction of m2 of ground in the crown per m2 ground in the - ! total canopy area. This results in W/m2 of total canopy. - - par_per_sunla = currentPatch%ed_parsun_z(cl,ft,iv) / & - (laisun*currentPatch%canopy_area_profile(cl,ft,iv)) - else - par_per_sunla = 0._r8 - end if - - !!if(((laisha*currentPatch%canopy_area_profile(cl,ft,iv)) >nearzero) .and. & - !! (currentPatch%ed_parsha_z(cl,ft,iv)>nearzero)) then - - par_per_shala = currentPatch%ed_parsha_z(cl,ft,iv) / & - (laisha*currentPatch%canopy_area_profile(cl,ft,iv)) - elai_layer = currentPatch%elai_profile(cl,ft,iv) - - else - - par_per_sunla = 0._r8 - par_per_shala = 0._r8 - elai_layer = 0._r8 - - end if if_nonnzero_lai - - fsun = currentPatch%f_sun(cl,ft,iv) - - - else ! Two-stream - - if(cohort_layer_elai(iv) > nearzero .and. currentPatch%solar_zenith_flag) then - - call FatesGetCohortAbsRad(currentPatch, currentCohort, ipar, & - cohort_vaitop(iv), cohort_vaibot(iv), cohort_elai, cohort_esai, & - rb_abs, rd_abs, rb_abs_leaf, rd_abs_leaf, fsun) - - ! rd_abs_leaf: Watts of diffuse light absorbed by leaves over this - ! depth interval and ground footprint (m2) - ! rd_abs_leaf*fsun Watts of diffuse light absorbed by sunlit leaves - ! over this depth interval and ground footprint (m2) - ! rb_abs_leaf Watts of beam absorbed by sunlit leaves over this - ! depth interval and ground footprint (m2) - ! cohort_layer_elai*fsun Leaf area in sunlight within this interval and ground footprint - ! cohort_layer_elai*(1-fsun) Leaf area in shade within this interval and ground footprint - - if(fsun>nearzero) then - par_per_sunla = (rd_abs_leaf*fsun + rb_abs_leaf) / (fsun*cohort_layer_elai(iv)) - else - par_per_sunla = 0._r8 - end if - par_per_shala = rd_abs_leaf*(1._r8-fsun) / ((1._r8 - fsun)*cohort_layer_elai(iv)) - - else - - par_per_sunla = 0._r8 - par_per_shala = 0._r8 - fsun = 0.5_r8 !avoid div0, should have no impact - end if - - elai_layer = cohort_layer_elai(iv) - - end if if_radsolver - - ! Part VII: Calculate (1) maximum rate of carboxylation (vcmax), - ! (2) maximum electron transport rate, (3) triose phosphate - ! utilization rate and (4) the initial slope of CO2 response curve - ! (C4 plants). Earlier we calculated their base rates as dictated - ! by their plant functional type and some simple scaling rules for - ! nitrogen limitation baesd on canopy position (not prognostic). - ! These rates are the specific rates used in the actual photosynthesis - ! calculations that take localized environmental effects (temperature) - ! into consideration. - - call LeafLayerBiophysicalRates(par_per_sunla, & ! in - ft, & ! in - currentCohort%vcmax25top, & ! in - currentCohort%jmax25top, & ! in - currentCohort%kp25top, & ! in - nscaler, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - currentPatch%tveg_lpa%GetMean(), & ! in - currentPatch%tveg_longterm%GetMean(),& ! in - btran_eff, & ! in - vcmax_z, & ! out - jmax_z, & ! out - kp_z ) ! out - - ! Part IX: This call calculates the actual photosynthesis for the - ! leaf layer, as well as the stomatal resistance and the net assimilated carbon. - - call LeafLayerPhotosynthesis(fsun, & ! in - par_per_sunla, & ! in - par_per_shala, & ! in - elai_layer, & ! in - ft, & ! in - vcmax_z, & ! in - jmax_z, & ! in - kp_z, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - bc_in(s)%esat_tv_pa(ifp), & ! in - bc_in(s)%forc_pbot, & ! in - bc_in(s)%cair_pa(ifp), & ! in - bc_in(s)%oair_pa(ifp), & ! in - btran_eff, & ! in - stomatal_intercept_btran, & ! in - cf, & ! in - gb_mol, & ! in - ceair, & ! in - mm_kco2, & ! in - mm_ko2, & ! in - co2_cpoint, & ! in - lmr_z(iv,ft,cl), & ! in - leaf_psi, & ! in - bc_in(s)%rb_pa(ifp), & ! in - currentPatch%psn_z(cl,ft,iv), & ! out - rs_z(iv,ft,cl), & ! out - anet_av_z(iv,ft,cl), & ! out - c13disc_z(cl,ft,iv)) ! out - - rate_mask_z(iv,ft,cl) = .true. - - end if rate_mask_if - end do leaf_layer_loop - - ! Zero cohort flux accumulators. - currentCohort%npp_tstep = 0.0_r8 - currentCohort%resp_tstep = 0.0_r8 - currentCohort%gpp_tstep = 0.0_r8 - currentCohort%rdark = 0.0_r8 - currentCohort%resp_m = 0.0_r8 - currentCohort%ts_net_uptake = 0.0_r8 - currentCohort%c13disc_clm = 0.0_r8 - - ! --------------------------------------------------------------- - ! Part VII: Transfer leaf flux rates (like maintenance respiration, - ! carbon assimilation and conductance) that are defined by the - ! leaf layer (which is area independent, ie /m2) onto each cohort - ! (where the rates become per cohort, ie /individual). Most likely - ! a sum over layers. - ! --------------------------------------------------------------- - nv = currentCohort%nv - - ! Temporary bypass to preserve B4B behavior - if(radiation_model.eq.norman_solver) then - - call ScaleLeafLayerFluxToCohort(nv, & !in - currentPatch%psn_z(cl,ft,1:nv), & !in - lmr_z(1:nv,ft,cl), & !in - rs_z(1:nv,ft,cl), & !in - currentPatch%elai_profile(cl,ft,1:nv), & !in - c13disc_z(cl, ft, 1:nv), & !in - currentCohort%c_area, & !in - currentCohort%n, & !in - bc_in(s)%rb_pa(ifp), & !in - maintresp_reduction_factor, & !in - currentCohort%g_sb_laweight, & !out - currentCohort%gpp_tstep, & !out - currentCohort%rdark, & !out - currentCohort%c13disc_clm, & !out - cohort_eleaf_area) !out - - else - - call ScaleLeafLayerFluxToCohort(nv, & !in - currentPatch%psn_z(cl,ft,1:nv), & !in - lmr_z(1:nv,ft,cl), & !in - rs_z(1:nv,ft,cl), & !in - cohort_layer_elai(1:nv), & !in - c13disc_z(cl, ft, 1:nv), & !in - currentCohort%c_area, & !in - currentCohort%n, & !in - bc_in(s)%rb_pa(ifp), & !in - maintresp_reduction_factor, & !in - currentCohort%g_sb_laweight, & !out - currentCohort%gpp_tstep, & !out - currentCohort%rdark, & !out - currentCohort%c13disc_clm, & !out - cohort_eleaf_area) !out - end if - - - ! Net Uptake does not need to be scaled, just transfer directly - currentCohort%ts_net_uptake(1:nv) = anet_av_z(1:nv,ft,cl) * umolC_to_kgC - - else - - ! In this case, the cohort had no leaves, - ! so no productivity,conductance, transpiration uptake - ! or dark respiration - cohort_eleaf_area = 0.0_r8 - currentCohort%gpp_tstep = 0.0_r8 - currentCohort%rdark = 0.0_r8 - currentCohort%g_sb_laweight = 0.0_r8 - currentCohort%ts_net_uptake(:) = 0.0_r8 - - end if canopy_mask_if - - - ! ------------------------------------------------------------------ - ! Part VIII: Calculate maintenance respiration in the sapwood and - ! fine root pools. - ! ------------------------------------------------------------------ - - ! Calculate the amount of nitrogen in the above and below ground - ! stem and root pools, used for maint resp - ! We are using the fine-root C:N ratio as an approximation for - ! the sapwood pools. - ! Units are in (kgN/plant) - ! ------------------------------------------------------------------ - - sapw_c = currentCohort%prt%GetState(sapw_organ, carbon12_element) - fnrt_c = currentCohort%prt%GetState(fnrt_organ, carbon12_element) - - if (hlm_use_tree_damage .eq. itrue) then - - ! Crown damage currenly only reduces the aboveground portion of - ! sapwood. Therefore we calculate the aboveground and the belowground portion - ! sapwood for use in stem respiration. - call GetCrownReduction(currentCohort%crowndamage, crown_reduction) - - else - crown_reduction = 0.0_r8 - end if - - ! If crown reduction is zero, undamaged sapwood target will equal sapwood carbon - agb_frac = prt_params%allom_agb_frac(currentCohort%pft) - branch_frac = param_derived%branch_frac(currentCohort%pft) - sapw_c_undamaged = sapw_c / (1.0_r8 - (agb_frac * branch_frac * crown_reduction)) - - ! Undamaged below ground portion - sapw_c_bgw = sapw_c_undamaged * (1.0_r8 - agb_frac) - - ! Damaged aboveground portion - sapw_c_agw = sapw_c - sapw_c_bgw - - - select case(hlm_parteh_mode) - case (prt_carbon_allom_hyp) - - live_stem_n = sapw_c_agw * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) - - live_croot_n = sapw_c_bgw * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) - - fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(fnrt_organ)) - - case(prt_cnp_flex_allom_hyp) - - live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & - currentCohort%prt%GetState(sapw_organ, nitrogen_element) + lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) - live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & - currentCohort%prt%GetState(sapw_organ, nitrogen_element) + case (prt_cnp_flex_allom_hyp) + leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element) + if( (leaf_c*slatop(ft)) > nearzero) then + leaf_n = currentCohort%prt%GetState(leaf_organ, nitrogen_element) + lnc_top = leaf_n / (slatop(ft) * leaf_c ) + else + lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) + end if - fnrt_n = currentCohort%prt%GetState(fnrt_organ, nitrogen_element) + ! If one wants to break coupling with dynamic N conentrations, + ! use the stoichiometry parameter + ! lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) - if (hlm_use_tree_damage .eq. itrue) then + end select - sapw_n = currentCohort%prt%GetState(sapw_organ, nitrogen_element) + ! Part VII: Calculate dark respiration (leaf maintenance) for this layer - sapw_n_undamaged = sapw_n / & - (1.0_r8 - (agb_frac * branch_frac * crown_reduction)) + select case (maintresp_leaf_model) - sapw_n_bgw = sapw_n_undamaged * (1.0_r8 - agb_frac) - sapw_n_agw = sapw_n - sapw_n_bgw + case (lmrmodel_ryan_1991) - live_croot_n = sapw_n_bgw + call LeafLayerMaintenanceRespiration_Ryan_1991( lnc_top, & ! in + nscaler, & ! in + ft, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + lmr_z(iv,ft,cl)) ! out - live_stem_n = sapw_n_agw + case (lmrmodel_atkin_etal_2017) - end if + call LeafLayerMaintenanceRespiration_Atkin_etal_2017(lnc_top, & ! in + nscaler, & ! in + ft, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + currentPatch%tveg_lpa%GetMean(), & ! in + lmr_z(iv,ft,cl)) ! out - ! If one wants to break coupling with dynamic N conentrations, - ! use the stoichiometry parameter - ! - ! live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & - ! sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) - ! live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & - ! sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) - ! fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(fnrt_organ)) + case default + write (fates_log(),*)'error, incorrect leaf respiration model specified' + call endrun(msg=errMsg(sourcefile, __LINE__)) - case default + end select + ! Pre-process PAR absorbed per unit leaf area for different schemes + ! par_per_sunla = [W absorbed beam+diffuse radiation / m2 of sunlit leaves] + ! par_per_shala = [W absorbed diffuse radiation / m2 of shaded leaves] + ! fsun = [m2 of sunlit leaves / m2 of total leaves] + ! ------------------------------------------------------------------ - end select + if_radsolver: if(radiation_model.eq.norman_solver) then - !------------------------------------------------------------------------------ - ! Calculate Whole Plant Respiration - ! (this doesn't really need to be in this iteration at all, surely?) - ! Response: (RGK 12-2016): I think the positioning of these calls is - ! appropriate as of now. Maintenance calculations in sapwood and roots - ! vary by cohort and with changing temperature at the minimum, and there are - ! no sub-pools chopping up those pools any finer that need to be dealt with. - !------------------------------------------------------------------------------ + laisun = currentPatch%elai_profile(cl,ft,iv)*currentPatch%f_sun(cl,ft,iv) + laisha = currentPatch%elai_profile(cl,ft,iv)*(1._r8-currentPatch%f_sun(cl,ft,iv)) - ! Live stem MR (kgC/plant/s) (above ground sapwood) - ! ------------------------------------------------------------------ - if ( int(woody(ft)) == itrue) then - tcwood = q10_mr**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) - ! kgC/s = kgN * kgC/kgN/s - currentCohort%livestem_mr = live_stem_n * maintresp_nonleaf_baserate * tcwood * maintresp_reduction_factor - else - currentCohort%livestem_mr = 0._r8 - end if + if_nonnzero_lai: if((laisun+laisha)>0._r8) then + if(((laisun*currentPatch%canopy_area_profile(cl,ft,iv)) >0.0000000001_r8)) then ! .and. & + !(currentPatch%ed_parsun_z(cl,ft,iv)>nearzero)) then - ! Fine Root MR (kgC/plant/s) - ! and calculate the N fixation rate as a function of the fixation-specific root respiration - ! for now use dev_arbitrary_pft as scaling term between 0 and 1 as additional increment of root respiration used for N fixation - ! ------------------------------------------------------------------ - currentCohort%froot_mr = 0._r8 - currentCohort%sym_nfix_tstep = 0._r8 + ! laisun: m2 of exposed leaf, per m2 of crown. If this is the lowest layer + ! for the pft/canopy group, than the m2 per crown is probably not + ! as large as the layer above. + ! ed_parsun_z: this is W/m2 ground times the canopy_area_profile, which is the + ! fraction of m2 of ground in the crown per m2 ground in the + ! total canopy area. This results in W/m2 of total canopy. - ! n_fixation is integrated over the course of the day - ! this variable is zeroed at the end of the FATES dynamics sequence + par_per_sunla = currentPatch%ed_parsun_z(cl,ft,iv) / & + (laisun*currentPatch%canopy_area_profile(cl,ft,iv)) + else + par_per_sunla = 0._r8 + end if + + !!if(((laisha*currentPatch%canopy_area_profile(cl,ft,iv)) >nearzero) .and. & + !! (currentPatch%ed_parsha_z(cl,ft,iv)>nearzero)) then + + par_per_shala = currentPatch%ed_parsha_z(cl,ft,iv) / & + (laisha*currentPatch%canopy_area_profile(cl,ft,iv)) + elai_layer = currentPatch%elai_profile(cl,ft,iv) + + else + + par_per_sunla = 0._r8 + par_per_shala = 0._r8 + elai_layer = 0._r8 + + end if if_nonnzero_lai + + fsun = currentPatch%f_sun(cl,ft,iv) + + + else ! Two-stream + + if(cohort_layer_elai(iv) > nearzero .and. currentPatch%solar_zenith_flag) then + + call FatesGetCohortAbsRad(currentPatch, currentCohort, ipar, & + cohort_vaitop(iv), cohort_vaibot(iv), cohort_elai, cohort_esai, & + rb_abs, rd_abs, rb_abs_leaf, rd_abs_leaf, fsun) + + ! rd_abs_leaf: Watts of diffuse light absorbed by leaves over this + ! depth interval and ground footprint (m2) + ! rd_abs_leaf*fsun Watts of diffuse light absorbed by sunlit leaves + ! over this depth interval and ground footprint (m2) + ! rb_abs_leaf Watts of beam absorbed by sunlit leaves over this + ! depth interval and ground footprint (m2) + ! cohort_layer_elai*fsun Leaf area in sunlight within this interval and ground footprint + ! cohort_layer_elai*(1-fsun) Leaf area in shade within this interval and ground footprint + + if(fsun>nearzero) then + par_per_sunla = (rd_abs_leaf*fsun + rb_abs_leaf) / (fsun*cohort_layer_elai(iv)) + else + par_per_sunla = 0._r8 + end if + par_per_shala = rd_abs_leaf*(1._r8-fsun) / ((1._r8 - fsun)*cohort_layer_elai(iv)) + + else + + par_per_sunla = 0._r8 + par_per_shala = 0._r8 + fsun = 0.5_r8 !avoid div0, should have no impact + end if + + elai_layer = cohort_layer_elai(iv) + + end if if_radsolver + + ! Part VII: Calculate (1) maximum rate of carboxylation (vcmax), + ! (2) maximum electron transport rate, (3) triose phosphate + ! utilization rate and (4) the initial slope of CO2 response curve + ! (C4 plants). Earlier we calculated their base rates as dictated + ! by their plant functional type and some simple scaling rules for + ! nitrogen limitation baesd on canopy position (not prognostic). + ! These rates are the specific rates used in the actual photosynthesis + ! calculations that take localized environmental effects (temperature) + ! into consideration. + + call LeafLayerBiophysicalRates(par_per_sunla, & ! in + ft, & ! in + currentCohort%vcmax25top, & ! in + currentCohort%jmax25top, & ! in + currentCohort%kp25top, & ! in + nscaler, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + currentPatch%tveg_lpa%GetMean(), & ! in + currentPatch%tveg_longterm%GetMean(),& ! in + btran_eff, & ! in + vcmax_z, & ! out + jmax_z, & ! out + kp_z ) ! out + + ! Part IX: This call calculates the actual photosynthesis for the + ! leaf layer, as well as the stomatal resistance and the net assimilated carbon. + + call LeafLayerPhotosynthesis(fsun, & ! in + par_per_sunla, & ! in + par_per_shala, & ! in + elai_layer, & ! in + ft, & ! in + vcmax_z, & ! in + jmax_z, & ! in + kp_z, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + bc_in(s)%esat_tv_pa(ifp), & ! in + bc_in(s)%forc_pbot, & ! in + bc_in(s)%cair_pa(ifp), & ! in + bc_in(s)%oair_pa(ifp), & ! in + btran_eff, & ! in + stomatal_intercept_btran, & ! in + cf, & ! in + gb_mol, & ! in + ceair, & ! in + mm_kco2, & ! in + mm_ko2, & ! in + co2_cpoint, & ! in + lmr_z(iv,ft,cl), & ! in + leaf_psi, & ! in + bc_in(s)%rb_pa(ifp), & ! in + currentPatch%psn_z(cl,ft,iv), & ! out + rs_z(iv,ft,cl), & ! out + anet_av_z(iv,ft,cl), & ! out + c13disc_z(cl,ft,iv)) ! out + + rate_mask_z(iv,ft,cl) = .true. + + end if rate_mask_if + end do leaf_layer_loop + + ! Zero cohort flux accumulators. + currentCohort%npp_tstep = 0.0_r8 + currentCohort%resp_tstep = 0.0_r8 + currentCohort%gpp_tstep = 0.0_r8 + currentCohort%rdark = 0.0_r8 + currentCohort%resp_m = 0.0_r8 + currentCohort%ts_net_uptake = 0.0_r8 + currentCohort%c13disc_clm = 0.0_r8 + + ! --------------------------------------------------------------- + ! Part VII: Transfer leaf flux rates (like maintenance respiration, + ! carbon assimilation and conductance) that are defined by the + ! leaf layer (which is area independent, ie /m2) onto each cohort + ! (where the rates become per cohort, ie /individual). Most likely + ! a sum over layers. + ! --------------------------------------------------------------- + nv = currentCohort%nv + + ! Temporary bypass to preserve B4B behavior + if(radiation_model.eq.norman_solver) then + + call ScaleLeafLayerFluxToCohort(nv, & !in + currentPatch%psn_z(cl,ft,1:nv), & !in + lmr_z(1:nv,ft,cl), & !in + rs_z(1:nv,ft,cl), & !in + currentPatch%elai_profile(cl,ft,1:nv), & !in + c13disc_z(cl, ft, 1:nv), & !in + currentCohort%c_area, & !in + currentCohort%n, & !in + bc_in(s)%rb_pa(ifp), & !in + maintresp_reduction_factor, & !in + currentCohort%g_sb_laweight, & !out + currentCohort%gpp_tstep, & !out + currentCohort%rdark, & !out + currentCohort%c13disc_clm, & !out + cohort_eleaf_area) !out + + else + + call ScaleLeafLayerFluxToCohort(nv, & !in + currentPatch%psn_z(cl,ft,1:nv), & !in + lmr_z(1:nv,ft,cl), & !in + rs_z(1:nv,ft,cl), & !in + cohort_layer_elai(1:nv), & !in + c13disc_z(cl, ft, 1:nv), & !in + currentCohort%c_area, & !in + currentCohort%n, & !in + bc_in(s)%rb_pa(ifp), & !in + maintresp_reduction_factor, & !in + currentCohort%g_sb_laweight, & !out + currentCohort%gpp_tstep, & !out + currentCohort%rdark, & !out + currentCohort%c13disc_clm, & !out + cohort_eleaf_area) !out + end if + + + ! Net Uptake does not need to be scaled, just transfer directly + currentCohort%ts_net_uptake(1:nv) = anet_av_z(1:nv,ft,cl) * umolC_to_kgC + + else + + ! In this case, the cohort had no leaves, + ! so no productivity,conductance, transpiration uptake + ! or dark respiration + cohort_eleaf_area = 0.0_r8 + currentCohort%gpp_tstep = 0.0_r8 + currentCohort%rdark = 0.0_r8 + currentCohort%g_sb_laweight = 0.0_r8 + currentCohort%ts_net_uptake(:) = 0.0_r8 + + end if canopy_mask_if + + + ! ------------------------------------------------------------------ + ! Part VIII: Calculate maintenance respiration in the sapwood and + ! fine root pools. + ! ------------------------------------------------------------------ + + ! Calculate the amount of nitrogen in the above and below ground + ! stem and root pools, used for maint resp + ! We are using the fine-root C:N ratio as an approximation for + ! the sapwood pools. + ! Units are in (kgN/plant) + ! ------------------------------------------------------------------ + + sapw_c = currentCohort%prt%GetState(sapw_organ, carbon12_element) + fnrt_c = currentCohort%prt%GetState(fnrt_organ, carbon12_element) + + if (hlm_use_tree_damage .eq. itrue) then - do j = 1,bc_in(s)%nlevsoil - tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) + ! Crown damage currenly only reduces the aboveground portion of + ! sapwood. Therefore we calculate the aboveground and the belowground portion + ! sapwood for use in stem respiration. + call GetCrownReduction(currentCohort%crowndamage, crown_reduction) - fnrt_mr_layer = fnrt_n * maintresp_nonleaf_baserate * tcsoi * rootfr_ft(ft,j) * maintresp_reduction_factor + else + crown_reduction = 0.0_r8 + end if - ! calculate the cost of carbon for N fixation in each soil layer and calculate N fixation rate based on that [kgC / kgN] + ! If crown reduction is zero, undamaged sapwood target will equal sapwood carbon + agb_frac = prt_params%allom_agb_frac(currentCohort%pft) + branch_frac = param_derived%branch_frac(currentCohort%pft) + sapw_c_undamaged = sapw_c / (1.0_r8 - (agb_frac * branch_frac * crown_reduction)) - call RootLayerNFixation(bc_in(s)%t_soisno_sl(j),ft,dtime,fnrt_mr_layer,fnrt_mr_nfix_layer,nfix_layer) + ! Undamaged below ground portion + sapw_c_bgw = sapw_c_undamaged * (1.0_r8 - agb_frac) - currentCohort%froot_mr = currentCohort%froot_mr + fnrt_mr_nfix_layer + fnrt_mr_layer + ! Damaged aboveground portion + sapw_c_agw = sapw_c - sapw_c_bgw - currentCohort%sym_nfix_tstep = currentCohort%sym_nfix_tstep + nfix_layer + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp) - enddo + live_stem_n = sapw_c_agw * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) - ! Coarse Root MR (kgC/plant/s) (below ground sapwood) - ! ------------------------------------------------------------------ - if ( int(woody(ft)) == itrue) then - currentCohort%livecroot_mr = 0._r8 - do j = 1,bc_in(s)%nlevsoil - ! Soil temperature used to adjust base rate of MR - tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) - currentCohort%livecroot_mr = currentCohort%livecroot_mr + & - live_croot_n * maintresp_nonleaf_baserate * tcsoi * & - rootfr_ft(ft,j) * maintresp_reduction_factor - enddo - else - currentCohort%livecroot_mr = 0._r8 - end if + live_croot_n = sapw_c_bgw * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) + fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(fnrt_organ)) - ! ------------------------------------------------------------------ - ! Part IX: Perform some unit conversions (rate to integrated) and - ! calcualate some fluxes that are sums and nets of the base fluxes - ! ------------------------------------------------------------------ + case(prt_cnp_flex_allom_hyp) - if ( debug ) write(fates_log(),*) 'EDPhoto 904 ', currentCohort%resp_m - if ( debug ) write(fates_log(),*) 'EDPhoto 905 ', currentCohort%rdark - if ( debug ) write(fates_log(),*) 'EDPhoto 906 ', currentCohort%livestem_mr - if ( debug ) write(fates_log(),*) 'EDPhoto 907 ', currentCohort%livecroot_mr - if ( debug ) write(fates_log(),*) 'EDPhoto 908 ', currentCohort%froot_mr + live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & + currentCohort%prt%GetState(sapw_organ, nitrogen_element) + live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & + currentCohort%prt%GetState(sapw_organ, nitrogen_element) - ! add on whole plant respiration values in kgC/indiv/s-1 - currentCohort%resp_m = currentCohort%livestem_mr + & - currentCohort%livecroot_mr + & - currentCohort%froot_mr + fnrt_n = currentCohort%prt%GetState(fnrt_organ, nitrogen_element) - ! no drought response right now.. something like: - ! resp_m = resp_m * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft) * & - ! EDPftvarcon_inst%resp_drought_response(ft)) + if (hlm_use_tree_damage .eq. itrue) then - currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark + sapw_n = currentCohort%prt%GetState(sapw_organ, nitrogen_element) - ! save as a diagnostic the un-throttled maintenance respiration to be able to know how strong this is - currentCohort%resp_m_unreduced = currentCohort%resp_m / maintresp_reduction_factor + sapw_n_undamaged = sapw_n / & + (1.0_r8 - (agb_frac * branch_frac * crown_reduction)) - ! convert from kgC/indiv/s to kgC/indiv/timestep - currentCohort%resp_m = currentCohort%resp_m * dtime - currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime - currentCohort%ts_net_uptake = currentCohort%ts_net_uptake * dtime + sapw_n_bgw = sapw_n_undamaged * (1.0_r8 - agb_frac) + sapw_n_agw = sapw_n - sapw_n_bgw - if ( debug ) write(fates_log(),*) 'EDPhoto 911 ', currentCohort%gpp_tstep - if ( debug ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep - if ( debug ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m + live_croot_n = sapw_n_bgw + live_stem_n = sapw_n_agw - currentCohort%resp_g_tstep = prt_params%grperc(ft) * & - (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) + end if + ! If one wants to break coupling with dynamic N conentrations, + ! use the stoichiometry parameter + ! + ! live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & + ! sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) + ! live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & + ! sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) + ! fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(fnrt_organ)) - currentCohort%resp_tstep = currentCohort%resp_m + & - currentCohort%resp_g_tstep ! kgC/indiv/ts - currentCohort%npp_tstep = currentCohort%gpp_tstep - & - currentCohort%resp_tstep ! kgC/indiv/ts - ! Accumulate the combined conductance (stomatal+leaf boundary layer) - ! Note that currentCohort%g_sb_laweight is weighted by the leaf area - ! of each cohort and has units of [m/s] * [m2 leaf] + case default - g_sb_leaves = g_sb_leaves + currentCohort%g_sb_laweight - ! Accumulate the total effective leaf area from all cohorts - ! in this patch. Normalize by canopy area outside the loop - patch_la = patch_la + cohort_eleaf_area + end select - currentCohort => currentCohort%shorter - enddo do_cohort_drive + !------------------------------------------------------------------------------ + ! Calculate Whole Plant Respiration + ! (this doesn't really need to be in this iteration at all, surely?) + ! Response: (RGK 12-2016): I think the positioning of these calls is + ! appropriate as of now. Maintenance calculations in sapwood and roots + ! vary by cohort and with changing temperature at the minimum, and there are + ! no sub-pools chopping up those pools any finer that need to be dealt with. + !------------------------------------------------------------------------------ - end if + ! Live stem MR (kgC/plant/s) (above ground sapwood) + ! ------------------------------------------------------------------ + if ( int(woody(ft)) == itrue) then + tcwood = q10_mr**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) + ! kgC/s = kgN * kgC/kgN/s + currentCohort%livestem_mr = live_stem_n * maintresp_nonleaf_baserate * tcwood * maintresp_reduction_factor + else + currentCohort%livestem_mr = 0._r8 + end if - ! Normalize canopy total conductance by the effective LAI - ! The value here was integrated over each cohort x leaf layer - ! and was weighted by m2 of effective leaf area for each layer - - if_preserve_b4b: if(preserve_b4b) then - - patch_la = patch_la / currentPatch%total_canopy_area - - if_zerolai1: if(patch_la>tiny(patch_la)) then - - elai = calc_areaindex(currentPatch,'elai') - g_sb_leaves = g_sb_leaves / (elai*currentPatch%total_canopy_area) - - if( g_sb_leaves > (1._r8/rsmax0) ) then - - ! Combined mean leaf resistance is the inverse of mean leaf conductance - r_sb_leaves = 1.0_r8/g_sb_leaves - - if (r_sb_leavesnearzero) then - - ! Normalize the leaf-area weighted canopy conductance - ! The denominator is the total effective leaf area in the canopy, - ! units of [m/s]*[m2] / [m2] = [m/s] - - g_sb_leaves = g_sb_leaves / max(0.1_r8*currentPatch%total_canopy_area,patch_la) - - if( g_sb_leaves > (1._r8/rsmax0) ) then - - ! Combined mean leaf resistance is the inverse of mean leaf conductance - r_sb_leaves = 1.0_r8/g_sb_leaves - - if (r_sb_leaves currentPatch%younger - end do - - deallocate(rootfr_ft) - - end do !site loop - - end associate -end subroutine FatesPlantRespPhotosynthDrive - -! =========================================================================================== - - -subroutine RootLayerNFixation(t_soil,ft,dtime,fnrt_mr_layer,fnrt_mr_nfix_layer,nfix_layer) - - - ! ------------------------------------------------------------------------------- - ! Symbiotic N Fixation is handled via Houlton et al 2008 and Fisher et al. 2010 - ! - ! A unifying framework for dinitrogen fixation in the terrestrial biosphere - ! Benjamin Z. Houlton, Ying-Ping Wang, Peter M. Vitousek & Christopher B. Field - ! Nature volume 454, pages327–330 (2008) https://doi.org/10.1038/nature07028 - ! - ! Carbon cost of plant nitrogen acquisition: A mechanistic, globally applicable model - ! of plant nitrogen uptake, retranslocation, and fixation. J. B. Fisher,S. Sitch,Y. - ! Malhi,R. A. Fisher,C. Huntingford,S.-Y. Tan. Global Biogeochemical Cycles. March - ! 2010 https://doi.org/10.1029/2009GB003621 - ! - ! ------------------------------------------------------------------------------ - - - real(r8),intent(in) :: t_soil ! Temperature of the current soil layer [degC] - integer,intent(in) :: ft ! Functional type index - real(r8),intent(in) :: dtime ! Time step length [s] - real(r8),intent(in) :: fnrt_mr_layer ! Amount of maintenance respiration in the fine-roots - ! for all non-fixation related processes [kgC/s] - - real(r8),intent(out) :: fnrt_mr_nfix_layer ! The added maintenance respiration due to nfixation - ! to be added as a surcharge to non-fixation MR [kgC] - real(r8),intent(out) :: nfix_layer ! The amount of N fixed in this layer through - ! symbiotic activity [kgN] - - real(r8) :: c_cost_nfix ! carbon cost of N fixation [kgC/kgN] - real(r8) :: c_spent_nfix ! carbon spent on N fixation, per layer [kgC/plant/timestep] - - ! N fixation parameters from Houlton et al (2008) and Fisher et al (2010) - real(r8), parameter :: s_fix = -6.25_r8 ! s parameter from FUN model (fisher et al 2010) - real(r8), parameter :: a_fix = -3.62_r8 ! a parameter from Houlton et al. 2010 (a = -3.62 +/- 0.52) - real(r8), parameter :: b_fix = 0.27_r8 ! b parameter from Houlton et al. 2010 (b = 0.27 +/-0.04) - real(r8), parameter :: c_fix = 25.15_r8 ! c parameter from Houlton et al. 2010 (c = 25.15 +/- 0.66) - - ! Amount of C spent (as part of MR respiration) on symbiotic fixation [kgC/s] - fnrt_mr_nfix_layer = fnrt_mr_layer * prt_params%nfix_mresp_scfrac(ft) - - ! This is the unit carbon cost for nitrogen fixation. It is temperature dependant [kgC/kgN] - c_cost_nfix = s_fix * (exp(a_fix + b_fix * (t_soil-tfrz) & - * (1._r8 - 0.5_r8 * (t_soil-tfrz) / c_fix)) - 2._r8) - - ! Time integrated amount of carbon spent on fixation (in this layer) [kgC/plant/layer/tstep] - c_spent_nfix = fnrt_mr_nfix_layer * dtime - - ! Amount of nitrogen fixed in this layer [kgC/plant/layer/tstep]/[kgC/kgN] = [kgN/plant/layer/tstep] - nfix_layer = c_spent_nfix / c_cost_nfix - - return -end subroutine RootLayerNFixation - - -! ======================================================================================= - -subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in - parsun_lsl, & ! in - parsha_lsl, & ! in - elai_lsl, & ! in - ft, & ! in - vcmax, & ! in - jmax, & ! in - co2_rcurve_islope, & ! in - veg_tempk, & ! in - veg_esat, & ! in - can_press, & ! in - can_co2_ppress, & ! in - can_o2_ppress, & ! in - btran, & ! in - stomatal_intercept_btran, & ! in - cf, & ! in - gb_mol, & ! in - ceair, & ! in - mm_kco2, & ! in - mm_ko2, & ! in - co2_cpoint, & ! in - lmr, & ! in - leaf_psi, & ! in - rb, & ! in - psn_out, & ! out - rstoma_out, & ! out - anet_av_out, & ! out - c13disc_z) ! out + ! Fine Root MR (kgC/plant/s) + ! and calculate the N fixation rate as a function of the fixation-specific root respiration + ! for now use dev_arbitrary_pft as scaling term between 0 and 1 as additional increment of root respiration used for N fixation + ! ------------------------------------------------------------------ + currentCohort%froot_mr = 0._r8 + currentCohort%sym_nfix_tstep = 0._r8 - ! ------------------------------------------------------------------------------------ - ! This subroutine calculates photosynthesis and stomatal conductance within each leaf - ! sublayer. - ! A note on naming conventions: As this subroutine is called for every - ! leaf-sublayer, many of the arguments are specific to that "leaf sub layer" - ! (LSL), those variables are given a dimension tag "_lsl" - ! Other arguments or variables may be indicative of scales broader than the LSL. - ! ------------------------------------------------------------------------------------ + ! n_fixation is integrated over the course of the day + ! this variable is zeroed at the end of the FATES dynamics sequence - use EDParamsMod , only : theta_cj_c3, theta_cj_c4 + do j = 1,bc_in(s)%nlevsoil + tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) + fnrt_mr_layer = fnrt_n * maintresp_nonleaf_baserate * tcsoi * rootfr_ft(ft,j) * maintresp_reduction_factor - ! Arguments - ! ------------------------------------------------------------------------------------ - real(r8), intent(in) :: f_sun_lsl ! - real(r8), intent(in) :: parsun_lsl ! Absorbed PAR in sunlist leaves per sunlit leaf area [W/m2 leaf] - real(r8), intent(in) :: parsha_lsl ! Absorved PAR in shaded leaves per shaded leaf area [W/m2 leaf] - real(r8), intent(in) :: elai_lsl ! ELAI of this layer [m2/m2] - integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8), intent(in) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) - real(r8), intent(in) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) - real(r8), intent(in) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) - real(r8), intent(in) :: veg_tempk ! vegetation temperature - real(r8), intent(in) :: veg_esat ! saturation vapor pressure at veg_tempk (Pa) - - ! Important Note on the following gas pressures. This photosynthesis scheme will iteratively - ! solve for the co2 partial pressure at the leaf surface (ie in the stomata). The reference - ! point for these input values are NOT within that boundary layer that separates the stomata from - ! the canopy air space. The reference point for these is on the outside of that boundary - ! layer. This routine, which operates at the leaf scale, makes no assumptions about what the - ! scale of the refernce is, it could be lower atmosphere, it could be within the canopy - ! but most likely it is the closest value one can get to the edge of the leaf's boundary - ! layer. We use the convention "can_" because a reference point of within the canopy - ! ia a best reasonable scenario of where we can get that information from. - - real(r8), intent(in) :: can_press ! Air pressure NEAR the surface of the leaf (Pa) - real(r8), intent(in) :: can_co2_ppress ! Partial pressure of CO2 NEAR the leaf surface (Pa) - real(r8), intent(in) :: can_o2_ppress ! Partial pressure of O2 NEAR the leaf surface (Pa) - real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) - real(r8), intent(in) :: stomatal_intercept_btran !water-stressed minimum stomatal conductance (umol H2O/m**2/s) - real(r8), intent(in) :: cf ! s m**2/umol -> s/m (ideal gas conversion) [umol/m3] - real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol /m**2/s) - real(r8), intent(in) :: ceair ! vapor pressure of air, constrained (Pa) - real(r8), intent(in) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) - real(r8), intent(in) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) - real(r8), intent(in) :: co2_cpoint ! CO2 compensation point (Pa) - real(r8), intent(in) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) - real(r8), intent(in) :: leaf_psi ! Leaf water potential [MPa] - real(r8), intent(in) :: rb ! Boundary Layer resistance of leaf [s/m] - - real(r8), intent(out) :: psn_out ! carbon assimilated in this leaf layer umolC/m2/s - real(r8), intent(out) :: rstoma_out ! stomatal resistance (1/gs_lsl) (s/m) - real(r8), intent(out) :: anet_av_out ! net leaf photosynthesis (umol CO2/m**2/s) - ! averaged over sun and shade leaves. - real(r8), intent(out) :: c13disc_z ! carbon 13 in newly assimilated carbon - - - - - ! Locals - ! ------------------------------------------------------------------------ - integer :: c3c4_path_index ! Index for which photosynthetic pathway - ! is active. C4 = 0, C3 = 1 - integer :: sunsha ! Index for differentiating sun and shade - real(r8) :: gstoma ! Stomatal Conductance of this leaf layer (m/s) - real(r8) :: agross ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) - real(r8) :: anet ! net leaf photosynthesis (umol CO2/m**2/s) - real(r8) :: a_gs ! The assimilation (a) for calculating conductance (gs) - ! is either = to anet or agross - real(r8) :: je ! electron transport rate (umol electrons/m**2/s) - real(r8) :: qabs ! PAR absorbed by PS II (umol photons/m**2/s) - real(r8) :: aquad,bquad,cquad ! terms for quadratic equations - real(r8) :: r1,r2 ! roots of quadratic equation - real(r8) :: co2_inter_c ! intercellular leaf CO2 (Pa) - real(r8) :: co2_inter_c_old ! intercellular leaf CO2 (Pa) (previous iteration) - logical :: loop_continue ! Loop control variable - integer :: niter ! iteration loop index - real(r8) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) - real(r8) :: gs ! leaf stomatal conductance (m/s) - real(r8) :: hs ! fractional humidity at leaf surface (dimensionless) - real(r8) :: gs_mol_err ! gs_mol for error check - real(r8) :: ac ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) - real(r8) :: aj ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) - real(r8) :: ap ! product-limited (C3) or CO2-limited - ! (C4) gross photosynthesis (umol CO2/m**2/s) - real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) - real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) - real(r8) :: init_co2_inter_c ! First guess intercellular co2 specific to C path - real(r8) :: term ! intermediate variable in Medlyn stomatal conductance model - real(r8) :: vpd ! water vapor deficit in Medlyn stomatal model (KPa) - - - ! Parameters - ! ------------------------------------------------------------------------ - ! Fraction of light absorbed by non-photosynthetic pigments - real(r8),parameter :: fnps = 0.15_r8 - - ! For plants with no leaves, a miniscule amount of conductance - ! can happen through the stems, at a partial rate of cuticular conductance - real(r8),parameter :: stem_cuticle_loss_frac = 0.1_r8 - - ! empirical curvature parameter for electron transport rate - real(r8),parameter :: theta_psii = 0.7_r8 - - ! First guess on ratio between intercellular co2 and the atmosphere - ! an iterator converges on actual - real(r8),parameter :: init_a2l_co2_c3 = 0.7_r8 - real(r8),parameter :: init_a2l_co2_c4 = 0.4_r8 - - ! quantum efficiency, used only for C4 (mol CO2 / mol photons) (index 0) - real(r8),parameter,dimension(0:1) :: quant_eff = [0.05_r8,0.0_r8] - - ! empirical curvature parameter for ap photosynthesis co-limitation - real(r8),parameter :: theta_ip = 0.999_r8 - - associate( bb_slope => EDPftvarcon_inst%bb_slope ,& ! slope of BB relationship, unitless - medlyn_slope=> EDPftvarcon_inst%medlyn_slope , & ! Slope for Medlyn stomatal conductance model method, the unit is KPa^0.5 - stomatal_intercept=> EDPftvarcon_inst%stomatal_intercept ) !Unstressed minimum stomatal conductance, the unit is umol/m**2/s - - ! photosynthetic pathway: 0. = c4, 1. = c3 - c3c4_path_index = nint(EDPftvarcon_inst%c3psn(ft)) - - if (c3c4_path_index == c3_path_index) then - init_co2_inter_c = init_a2l_co2_c3 * can_co2_ppress - else - init_co2_inter_c = init_a2l_co2_c4 * can_co2_ppress - end if - - ! Part III: Photosynthesis and Conductance - ! ---------------------------------------------------------------------------------- - - if_daytime: if ( parsun_lsl <= 0._r8 ) then ! night time - - anet_av_out = -lmr - psn_out = 0._r8 - - ! The cuticular conductance already factored in maximum resistance as a bound - ! no need to re-bound it - - rstoma_out = cf/stomatal_intercept_btran - - c13disc_z = 0.0_r8 !carbon 13 discrimination in night time carbon flux, note value of 1.0 is used in CLM - - else ! day time (a little bit more complicated ...) - - ! Is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) - - if_leafarea: if (elai_lsl > 0._r8 ) then - - !Loop aroun shaded and unshaded leaves - psn_out = 0._r8 ! psn is accumulated across sun and shaded leaves. - rstoma_out = 0._r8 ! 1/rs is accumulated across sun and shaded leaves. - anet_av_out = 0._r8 - gstoma = 0._r8 - - do sunsha = 1,2 - - ! Electron transport rate for C3 plants. - ! Convert par from W/m2 to umol photons/m**2/s using the factor 4.6 - ! Convert from units of par absorbed per unit ground area to par - ! absorbed per unit leaf area. - ! The 0.5 term here accounts for half of the light going to photosystem - ! 2, as mentioned in Biochemical models of leaf photosynthesis - ! (von Caemmerer) and Farquhar 1980 - - if(sunsha == 1)then !sunlit - qabs = parsun_lsl * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 - else - qabs = parsha_lsl * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 - end if - - !convert the absorbed par into absorbed par per m2 of leaf, - ! so it is consistant with the vcmax and lmr numbers. - aquad = theta_psii - bquad = -(qabs + jmax) - cquad = qabs * jmax - call quadratic_f (aquad, bquad, cquad, r1, r2) - je = min(r1,r2) - - ! Initialize intercellular co2 - co2_inter_c = init_co2_inter_c - - niter = 0 - loop_continue = .true. - iter_loop: do while(loop_continue) - ! Increment iteration counter. Stop if too many iterations - niter = niter + 1 - - ! Save old co2_inter_c - co2_inter_c_old = co2_inter_c - - ! Photosynthesis limitation rate calculations - if (c3c4_path_index == c3_path_index)then - - ! C3: Rubisco-limited photosynthesis - ac = vcmax * max(co2_inter_c-co2_cpoint, 0._r8) / & - (co2_inter_c+mm_kco2 * (1._r8+can_o2_ppress / mm_ko2 )) - - ! C3: RuBP-limited photosynthesis - aj = je * max(co2_inter_c-co2_cpoint, 0._r8) / & - (4._r8*co2_inter_c+8._r8*co2_cpoint) - - ! Gross photosynthesis smoothing calculations. Co-limit ac and aj. - aquad = theta_cj_c3 - bquad = -(ac + aj) - cquad = ac * aj - call quadratic_f (aquad, bquad, cquad, r1, r2) - agross = min(r1,r2) - - else - - ! C4: Rubisco-limited photosynthesis - ac = vcmax - - ! C4: RuBP-limited photosynthesis - if(sunsha == 1)then !sunlit - aj = quant_eff(c3c4_path_index) * parsun_lsl * 4.6_r8 - else - aj = quant_eff(c3c4_path_index) * parsha_lsl * 4.6_r8 - end if - - ! C4: PEP carboxylase-limited (CO2-limited) - ap = co2_rcurve_islope * max(co2_inter_c, 0._r8) / can_press - - ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap - - aquad = theta_cj_c4 - bquad = -(ac + aj) - cquad = ac * aj - call quadratic_f (aquad, bquad, cquad, r1, r2) - ai = min(r1,r2) - - aquad = theta_ip - bquad = -(ai + ap) - cquad = ai * ap - call quadratic_f (aquad, bquad, cquad, r1, r2) - agross = min(r1,r2) - - end if - - ! Calculate anet, only exit iteration with negative anet when - ! using anet in calculating gs this is version B - anet = agross - lmr - - if ( stomatal_assim_model == gross_assim_model ) then - if ( stomatal_model == medlyn_model ) then - write (fates_log(),*) 'Gross Assimilation conductance is incompatible with the Medlyn model' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - a_gs = agross - else - if (anet < 0._r8) then - loop_continue = .false. - end if - a_gs = anet - end if - - ! With an <= 0, then gs_mol = stomatal_intercept_btran - leaf_co2_ppress = can_co2_ppress- h2o_co2_bl_diffuse_ratio/gb_mol * a_gs * can_press - leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) - - if ( stomatal_model == medlyn_model ) then - !stomatal conductance calculated from Medlyn et al. (2011), the numerical & - !implementation was adapted from the equations in CLM5.0 - vpd = max((veg_esat - ceair), 50._r8) * 0.001_r8 !addapted from CLM5. Put some constraint on VPD - !when Medlyn stomatal conductance is being used, the unit is KPa. Ignoring the constraint will cause errors when model runs. - term = h2o_co2_stoma_diffuse_ratio * anet / (leaf_co2_ppress / can_press) - aquad = 1.0_r8 - bquad = -(2.0 * (stomatal_intercept_btran+ term) + (medlyn_slope(ft) * term)**2 / & - (gb_mol * vpd )) - cquad = stomatal_intercept_btran*stomatal_intercept_btran + & - (2.0*stomatal_intercept_btran + term * & - (1.0 - medlyn_slope(ft)* medlyn_slope(ft) / vpd)) * term - - call quadratic_f (aquad, bquad, cquad, r1, r2) - gs_mol = max(r1,r2) - - else if ( stomatal_model == ballberry_model ) then !stomatal conductance calculated from Ball et al. (1987) - aquad = leaf_co2_ppress - bquad = leaf_co2_ppress*(gb_mol - stomatal_intercept_btran) - bb_slope(ft) * a_gs * can_press - cquad = -gb_mol*(leaf_co2_ppress*stomatal_intercept_btran + & - bb_slope(ft)*anet*can_press * ceair/ veg_esat ) - - call quadratic_f (aquad, bquad, cquad, r1, r2) - gs_mol = max(r1,r2) - end if - - ! Derive new estimate for co2_inter_c - co2_inter_c = can_co2_ppress - anet * can_press * & - (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - - ! Check for co2_inter_c convergence. Delta co2_inter_c/pair = mol/mol. - ! Multiply by 10**6 to convert to umol/mol (ppm). Exit iteration if - ! convergence criteria of +/- 1 x 10**-6 ppm is met OR if at least ten - ! iterations (niter=10) are completed - - if ((abs(co2_inter_c-co2_inter_c_old)/can_press*1.e06_r8 <= 2.e-06_r8) & - .or. niter == 5) then - loop_continue = .false. - end if - end do iter_loop - - ! End of co2_inter_c iteration. Check for an < 0, in which case gs_mol = bbb - ! And Final estimates for leaf_co2_ppress and co2_inter_c - ! (needed for early exit of co2_inter_c iteration when an < 0) - if (anet < 0._r8) then - gs_mol = stomatal_intercept_btran - end if - - ! Final estimates for leaf_co2_ppress and co2_inter_c - leaf_co2_ppress = can_co2_ppress - h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press - leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) - co2_inter_c = can_co2_ppress - anet * can_press * & - (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - - ! Convert gs_mol (umol /m**2/s) to gs (m/s) and then to rs (s/m) - gs = gs_mol / cf - - ! estimate carbon 13 discrimination in leaf level carbon - ! flux Liang WEI and Hang ZHOU 2018, based on - ! Ubierna and Farquhar, 2014 doi:10.1111/pce.12346, using the simplified model: - ! $\Delta ^{13} C = \alpha_s + (b - \alpha_s) \cdot \frac{C_i}{C_a}$ - ! just hard code b and \alpha_s for now, might move to parameter set in future - ! b = 27.0 alpha_s = 4.4 - ! TODO, not considering C4 or CAM right now, may need to address this - ! note co2_inter_c is intracelluar CO2, not intercelluar - c13disc_z = 4.4_r8 + (27.0_r8 - 4.4_r8) * & - min (can_co2_ppress, max (co2_inter_c, 0._r8)) / can_co2_ppress - - ! Accumulate total photosynthesis umol/m2 ground/s-1. - ! weight per unit sun and sha leaves. - if(sunsha == 1)then !sunlit - psn_out = psn_out + agross * f_sun_lsl - anet_av_out = anet_av_out + anet * f_sun_lsl - gstoma = gstoma + 1._r8/(min(1._r8/gs, rsmax0)) * f_sun_lsl - else - psn_out = psn_out + agross * (1.0_r8-f_sun_lsl) - anet_av_out = anet_av_out + anet * (1.0_r8-f_sun_lsl) - gstoma = gstoma + & - 1._r8/(min(1._r8/gs, rsmax0)) * (1.0_r8-f_sun_lsl) - end if - - ! Make sure iterative solution is correct - if (gs_mol < 0._r8) then - write (fates_log(),*)'Negative stomatal conductance:' - write (fates_log(),*)'gs_mol= ',gs_mol - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Compare with Medlyn model: gs_mol = 1.6*(1+m/sqrt(vpd)) * an/leaf_co2_ppress*p + b - if ( stomatal_model == 2 ) then - gs_mol_err = h2o_co2_stoma_diffuse_ratio*(1 + medlyn_slope(ft)/sqrt(vpd))*max(anet,0._r8)/leaf_co2_ppress*can_press + stomatal_intercept_btran - ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress*p + b - else if ( stomatal_model == 1 ) then - hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) - gs_mol_err = bb_slope(ft)*max(anet, 0._r8)*hs/leaf_co2_ppress*can_press + stomatal_intercept_btran - end if - - if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then - warn_msg = 'Stomatal conductance error check - weak convergence: '//trim(N2S(gs_mol))//' '//trim(N2S(gs_mol_err)) - call FatesWarn(warn_msg,index=1) - end if - - enddo !sunsha loop - - ! Stomatal resistance of the leaf-layer - if ( (hlm_use_planthydro.eq.itrue .and. EDPftvarcon_inst%hydr_k_lwp(ft)>nearzero) ) then - rstoma_out = LeafHumidityStomaResis(leaf_psi, veg_tempk, ceair, can_press, veg_esat, & - rb, gstoma, ft) - else - rstoma_out = 1._r8/gstoma - end if - - - else - - ! No leaf area. This layer is present only because of stems. - ! Net assimilation is zero, not negative because there are - ! no leaves to even respire - ! (leaves are off, or have reduced to 0) - - psn_out = 0._r8 - anet_av_out = 0._r8 - - rstoma_out = min(rsmax0,cf/(stem_cuticle_loss_frac*stomatal_intercept(ft))) - c13disc_z = 0.0_r8 - - end if if_leafarea !is there leaf area? - - - end if if_daytime ! night or day - - - end associate - return -end subroutine LeafLayerPhotosynthesis - -! ======================================================================================= - -function LeafHumidityStomaResis(leaf_psi, veg_tempk, ceair, can_press, veg_esat, & - rb, gstoma, ft) result(rstoma_out) - - ! ------------------------------------------------------------------------------------- - ! This calculates inner leaf humidity as a function of mesophyll water potential - ! Adopted from Vesala et al., 2017 https://www.frontiersin.org/articles/10.3389/fpls.2017.00054/full - ! - ! Equation 1 in Vesala et al: - ! lwp_star = wi/w0 = exp( k_lwp*leaf_psi*molar_mass_water/(rgas_J_k_mol * veg_tempk) ) - ! - ! Terms: - ! leaf_psi: leaf water potential [MPa] - ! k_lwp: inner leaf humidity scaling coefficient [-] - ! rgas_J_K_mol: universal gas constant, [J/K/mol], 8.3144598 - ! molar_mass_water, molar mass of water, [g/mol]: 18.0 - ! - ! Unit conversions: - ! 1 Pa = 1 N/m2 = 1 J/m3 - ! density of liquid water [kg/m3] = 1000 - ! - ! units of equation 1: exp( [MPa]*[g/mol]/( [J/K/mol] * [K] ) ) - ! [MJ/m3]*[g/mol]*[m3/kg]*[kg/g]*[J/MJ] / ([J/mol]) - ! dimensionless: [J/g]*[g/mol]/([J/mol]) - ! - ! Note: unit conversions drop out b/c [m3/kg]*[kg/g]*[J/MJ] = 1e-3*1.e-3*1e6 = 1.0 - ! - ! Junyan Ding 2021 - ! ------------------------------------------------------------------------------------- - - ! Arguments - real(r8) :: leaf_psi ! Leaf water potential [MPa] - real(r8) :: veg_tempk ! Leaf temperature [K] - real(r8) :: ceair ! vapor pressure of air, constrained [Pa] - real(r8) :: can_press ! Atmospheric pressure of canopy [Pa] - real(r8) :: veg_esat ! Saturated vapor pressure at veg surf [Pa] - real(r8) :: rb ! Leaf Boundary layer resistance [s/m] - real(r8) :: gstoma ! Stomatal Conductance of this leaf layer [m/s] - integer :: ft ! Plant Functional Type - real(r8) :: rstoma_out ! Total Stomatal resistance (stoma and BL) [s/m] - - ! Locals - real(r8) :: k_lwp ! Scaling coefficient for the ratio of leaf xylem - ! water potential to mesophyll water potential - real(r8) :: qs ! Specific humidity [g/kg] - real(r8) :: qsat ! Saturation specific humidity [g/kg] - real(r8) :: qsat_adj ! Adjusted saturation specific humidity [g/kg] - real(r8) :: lwp_star ! leaf water potential scaling coefficient - ! for inner leaf humidity, 0 means total dehydroted - ! leaf, 1 means total saturated leaf - - ! Note: to disable this control, set k_lwp to zero, LWP_star will be 1 - k_lwp = EDPftvarcon_inst%hydr_k_lwp(ft) - if (leaf_psi<0._r8) then - lwp_star = exp(k_lwp*leaf_psi*molar_mass_water/(rgas_J_K_mol *veg_tempk)) - else - lwp_star = 1._r8 - end if - - ! compute specific humidity from vapor pressure - ! q = molar_mass_ratio_vapdry*e/(can_press - (1-molar_mass_ratio_vapdry)*e) - ! source https://cran.r-project.org/web/packages/humidity/vignettes/humidity-measures.html - ! now adjust inner leaf humidity by LWP_star - - qs = molar_mass_ratio_vapdry * ceair / (can_press - (1._r8-molar_mass_ratio_vapdry) * ceair) - qsat = molar_mass_ratio_vapdry * veg_esat / (can_press - (1._r8-molar_mass_ratio_vapdry) * veg_esat) - qsat_adj = qsat*lwp_star - - ! Adjusting gs (compute a virtual gs) that will be passed to host model - - if ( qsat_adj < qs ) then - - ! if inner leaf vapor pressure is less then or equal to that at leaf surface - ! then set stomata resistance to be very large to stop the transpiration or back flow of vapor - rstoma_out = rsmax0 - - else - - rstoma_out = (qsat-qs)*( 1/gstoma + rb)/(qsat_adj - qs)-rb - - end if - - if (rstoma_out < nearzero ) then - write (fates_log(),*) 'qsat:', qsat, 'qs:', qs - write (fates_log(),*) 'LWP :', leaf_psi - write (fates_log(),*) 'ceair:', ceair, 'veg_esat:', veg_esat - write (fates_log(),*) 'rstoma_out:', rstoma_out, 'rb:', rb - write (fates_log(),*) 'LWP_star', lwp_star - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - -end function LeafHumidityStomaResis - - -! ===================================================================================== - -subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv - psn_llz, & ! in %psn_z(1:currentCohort%nv,ft,cl) - lmr_llz, & ! in lmr_z(1:currentCohort%nv,ft,cl) - rs_llz, & ! in rs_z(1:currentCohort%nv,ft,cl) - elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) - c13disc_llz, & ! in c13disc_z(cl, ft, 1:currentCohort%nv) - c_area, & ! in currentCohort%c_area - nplant, & ! in currentCohort%n - rb, & ! in bc_in(s)%rb_pa(ifp) - maintresp_reduction_factor, & ! in - g_sb_laweight, & ! out currentCohort%g_sb_laweight [m/s] [m2-leaf] - gpp, & ! out currentCohort%gpp_tstep - rdark, & ! out currentCohort%rdark - c13disc_clm, & ! out currentCohort%c13disc_clm - cohort_eleaf_area ) ! out [m2] + ! calculate the cost of carbon for N fixation in each soil layer and calculate N fixation rate based on that [kgC / kgN] - ! ------------------------------------------------------------------------------------ - ! This subroutine effectively integrates leaf carbon fluxes over the - ! leaf layers to give cohort totals. - ! Some arguments have the suffix "_llz". This indicates that the vector - ! is stratefied in the leaf-layer (ll) dimension, and is a portion of the calling - ! array which has the "_z" tag, thus "llz". - ! ------------------------------------------------------------------------------------ + call RootLayerNFixation(bc_in(s)%t_soisno_sl(j),ft,dtime,fnrt_mr_layer,fnrt_mr_nfix_layer,nfix_layer) - use FatesConstantsMod, only : umolC_to_kgC - - ! Arguments - integer, intent(in) :: nv ! number of active leaf layers - real(r8), intent(in) :: psn_llz(nv) ! layer photosynthesis rate (GPP) [umolC/m2leaf/s] - real(r8), intent(in) :: lmr_llz(nv) ! layer dark respiration rate [umolC/m2leaf/s] - real(r8), intent(in) :: rs_llz(nv) ! leaf layer stomatal resistance [s/m] - real(r8), intent(in) :: elai_llz(nv) ! exposed LAI per layer [m2 leaf/ m2 pft footprint] - real(r8), intent(in) :: c13disc_llz(nv) ! leaf layer c13 discrimination, weighted mean - real(r8), intent(in) :: c_area ! crown area m2/m2 - real(r8), intent(in) :: nplant ! indiv/m2 - real(r8), intent(in) :: rb ! leaf boundary layer resistance (s/m) - real(r8), intent(in) :: maintresp_reduction_factor ! factor by which to reduce maintenance respiration - real(r8), intent(out) :: g_sb_laweight ! Combined conductance (stomatal + boundary layer) for the cohort - ! weighted by leaf area [m/s]*[m2] - real(r8), intent(out) :: gpp ! GPP (kgC/indiv/s) - real(r8), intent(out) :: rdark ! Dark Leaf Respiration (kgC/indiv/s) - real(r8), intent(out) :: cohort_eleaf_area ! Effective leaf area of the cohort [m2] - real(r8), intent(out) :: c13disc_clm ! unpacked Cohort level c13 discrimination - real(r8) :: sum_weight ! sum of weight for unpacking d13c flux (c13disc_z) from - ! (canopy_layer, pft, leaf_layer) matrix to cohort (c13disc_clm) - - ! GPP IN THIS SUBROUTINE IS A RATE. THE CALLING ARGUMENT IS GPP_TSTEP. AFTER THIS - ! CALL THE RATE WILL BE MULTIPLIED BY THE INTERVAL TO GIVE THE INTEGRATED QUANT. - - ! Locals - integer :: il ! leaf layer index - real(r8) :: cohort_layer_eleaf_area ! the effective leaf area of the cohort's current layer [m2] - - cohort_eleaf_area = 0.0_r8 - g_sb_laweight = 0.0_r8 - gpp = 0.0_r8 - rdark = 0.0_r8 - - do il = 1, nv ! Loop over the leaf layers this cohort participates in - - - ! Cohort's total effective leaf area in this layer [m2] - ! leaf area index of the layer [m2/m2 ground] * [m2 ground] - ! elai_llz is the LAI for the whole PFT. Multiplying this by the ground - ! area this cohort contributes, give the cohort's portion of the leaf - ! area in this layer - cohort_layer_eleaf_area = elai_llz(il) * c_area - - ! Increment the cohort's total effective leaf area [m2] - cohort_eleaf_area = cohort_eleaf_area + cohort_layer_eleaf_area - - ! Leaf conductance (stomatal and boundary layer) - ! This should be the weighted average over the leaf surfaces. - ! Since this is relevant to the stomata, its weighting should be based - ! on total leaf area, and not really footprint area - ! [m/s] * [m2 cohort's leaf layer] - g_sb_laweight = g_sb_laweight + 1.0_r8/(rs_llz(il)+rb) * cohort_layer_eleaf_area - - ! GPP [umolC/m2leaf/s] * [m2 leaf ] -> [umolC/s] - gpp = gpp + psn_llz(il) * cohort_layer_eleaf_area - - ! Dark respiration - ! [umolC/m2leaf/s] * [m2 leaf] - rdark = rdark + lmr_llz(il) * cohort_layer_eleaf_area - - end do - - - - if (nv > 1) then - ! cohort%c13disc_clm as weighted mean of d13c flux at all related leave layers - sum_weight = sum(psn_llz(1:nv-1) * elai_llz(1:nv-1)) - if (sum_weight .eq. 0.0_r8) then - c13disc_clm = 0.0 - else - c13disc_clm = sum(c13disc_llz(1:nv-1) * psn_llz(1:nv-1) * elai_llz(1:nv-1)) / sum_weight - end if + currentCohort%froot_mr = currentCohort%froot_mr + fnrt_mr_nfix_layer + fnrt_mr_layer - end if + currentCohort%sym_nfix_tstep = currentCohort%sym_nfix_tstep + nfix_layer - ! ----------------------------------------------------------------------------------- - ! We DO NOT normalize g_sb_laweight. - ! The units that we are passing back are [m/s] * [m2 effective leaf] - ! We will add these up over the whole patch, and then normalized - ! by the patch's total leaf area in the calling routine - ! ----------------------------------------------------------------------------------- + enddo - ! ----------------------------------------------------------------------------------- - ! Convert dark respiration and GPP from [umol/s] to [kgC/plant/s] - ! Also, apply the maintenance respiration reduction factor - ! ----------------------------------------------------------------------------------- + ! Coarse Root MR (kgC/plant/s) (below ground sapwood) + ! ------------------------------------------------------------------ + if ( int(woody(ft)) == itrue) then + currentCohort%livecroot_mr = 0._r8 + do j = 1,bc_in(s)%nlevsoil + ! Soil temperature used to adjust base rate of MR + tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) + currentCohort%livecroot_mr = currentCohort%livecroot_mr + & + live_croot_n * maintresp_nonleaf_baserate * tcsoi * & + rootfr_ft(ft,j) * maintresp_reduction_factor + enddo + else + currentCohort%livecroot_mr = 0._r8 + end if - rdark = rdark * umolC_to_kgC * maintresp_reduction_factor / nplant - gpp = gpp * umolC_to_kgC / nplant - if ( debug ) then - write(fates_log(),*) 'EDPhoto 816 ', gpp - write(fates_log(),*) 'EDPhoto 817 ', psn_llz(1:nv) - write(fates_log(),*) 'EDPhoto 820 ', nv - write(fates_log(),*) 'EDPhoto 821 ', elai_llz(1:nv) - write(fates_log(),*) 'EDPhoto 843 ', rdark - write(fates_log(),*) 'EDPhoto 873 ', nv - write(fates_log(),*) 'EDPhoto 874 ', cohort_eleaf_area - endif + ! ------------------------------------------------------------------ + ! Part IX: Perform some unit conversions (rate to integrated) and + ! calcualate some fluxes that are sums and nets of the base fluxes + ! ------------------------------------------------------------------ - return -end subroutine ScaleLeafLayerFluxToCohort + if ( debug ) write(fates_log(),*) 'EDPhoto 904 ', currentCohort%resp_m + if ( debug ) write(fates_log(),*) 'EDPhoto 905 ', currentCohort%rdark + if ( debug ) write(fates_log(),*) 'EDPhoto 906 ', currentCohort%livestem_mr + if ( debug ) write(fates_log(),*) 'EDPhoto 907 ', currentCohort%livecroot_mr + if ( debug ) write(fates_log(),*) 'EDPhoto 908 ', currentCohort%froot_mr -! ===================================================================================== -function ft1_f(tl, ha) result(ans) - ! - !!DESCRIPTION: - ! photosynthesis temperature response - ! - ! !REVISION HISTORY - ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - !!USES - use FatesConstantsMod, only : rgas => rgas_J_K_kmol - - ! - ! !ARGUMENTS: - real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) - real(r8), intent(in) :: ha ! activation energy in photosynthesis temperature function (J/mol) - ! - ! !LOCAL VARIABLES: - real(r8) :: ans - !------------------------------------------------------------------------------- - - ans = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) - - return -end function ft1_f - -! ===================================================================================== - -function fth_f(tl,hd,se,scaleFactor) result(ans) - ! - !!DESCRIPTION: - !photosynthesis temperature inhibition - ! - ! !REVISION HISTORY - ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - use FatesConstantsMod, only : rgas => rgas_J_K_kmol - ! - ! !ARGUMENTS: - real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temp function (K) - real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) - real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) - real(r8), intent(in) :: scaleFactor ! scaling factor for high temp inhibition (25 C = 1.0) - ! - ! !LOCAL VARIABLES: - real(r8) :: ans - !------------------------------------------------------------------------------- + ! add on whole plant respiration values in kgC/indiv/s-1 + currentCohort%resp_m = currentCohort%livestem_mr + & + currentCohort%livecroot_mr + & + currentCohort%froot_mr - ans = scaleFactor / ( 1._r8 + exp( (-hd+se*tl) / (rgas*1.e-3_r8*tl) ) ) + ! no drought response right now.. something like: + ! resp_m = resp_m * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft) * & + ! EDPftvarcon_inst%resp_drought_response(ft)) - return -end function fth_f + currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark -! ===================================================================================== + ! save as a diagnostic the un-throttled maintenance respiration to be able to know how strong this is + currentCohort%resp_m_unreduced = currentCohort%resp_m / maintresp_reduction_factor -function fth25_f(hd,se)result(ans) - ! - !!DESCRIPTION: - ! scaling factor for photosynthesis temperature inhibition - ! - ! !REVISION HISTORY: - ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - !!USES + ! convert from kgC/indiv/s to kgC/indiv/timestep + currentCohort%resp_m = currentCohort%resp_m * dtime + currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime + currentCohort%ts_net_uptake = currentCohort%ts_net_uptake * dtime - use FatesConstantsMod, only : rgas => rgas_J_K_kmol + if ( debug ) write(fates_log(),*) 'EDPhoto 911 ', currentCohort%gpp_tstep + if ( debug ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep + if ( debug ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m - ! - ! !ARGUMENTS: - real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) - real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) - ! - ! !LOCAL VARIABLES: - real(r8) :: ans - !------------------------------------------------------------------------------- - ans = 1._r8 + exp( (-hd+se*(tfrz+25._r8)) / (rgas*1.e-3_r8*(tfrz+25._r8)) ) + currentCohort%resp_g_tstep = prt_params%grperc(ft) * & + (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) - return -end function fth25_f -! ===================================================================================== + currentCohort%resp_tstep = currentCohort%resp_m + & + currentCohort%resp_g_tstep ! kgC/indiv/ts + currentCohort%npp_tstep = currentCohort%gpp_tstep - & + currentCohort%resp_tstep ! kgC/indiv/ts + + ! Accumulate the combined conductance (stomatal+leaf boundary layer) + ! Note that currentCohort%g_sb_laweight is weighted by the leaf area + ! of each cohort and has units of [m/s] * [m2 leaf] + + g_sb_leaves = g_sb_leaves + currentCohort%g_sb_laweight + + ! Accumulate the total effective leaf area from all cohorts + ! in this patch. Normalize by canopy area outside the loop + patch_la = patch_la + cohort_eleaf_area + + currentCohort => currentCohort%shorter + enddo do_cohort_drive + + end if if_any_cohorts + + ! Normalize canopy total conductance by the effective LAI + ! The value here was integrated over each cohort x leaf layer + ! and was weighted by m2 of effective leaf area for each layer + + if(preserve_b4b) then + patch_la = patch_la/ currentPatch%total_canopy_area + end if + + ! Normalize canopy total conductance by the effective LAI + ! The value here was integrated over each cohort x leaf layer + ! and was weighted by m2 of effective leaf area for each layer + + if_any_lai: if(patch_la>tiny(patch_la)) then + + ! Normalize the leaf-area weighted canopy conductance + ! The denominator is the total effective leaf area in the canopy, + ! units of [m/s]*[m2] / [m2] = [m/s] + + if_preserve_b4b3: if(preserve_b4b) then + elai = calc_areaindex(currentPatch,'elai') + g_sb_leaves = g_sb_leaves / (elai*currentPatch%total_canopy_area) + else + g_sb_leaves = g_sb_leaves / max(0.1_r8*currentPatch%total_canopy_area,patch_la) + end if if_preserve_b4b3 + + + if_above_mincond: if( g_sb_leaves > (1._r8/rsmax0) ) then + + ! Combined mean leaf resistance is the inverse of mean leaf conductance + r_sb_leaves = 1.0_r8/g_sb_leaves + + if (r_sb_leaves currentPatch%younger + end do + + deallocate(rootfr_ft) + + end do !site loop + + end associate + end subroutine FatesPlantRespPhotosynthDrive + + ! =========================================================================================== + + + subroutine RootLayerNFixation(t_soil,ft,dtime,fnrt_mr_layer,fnrt_mr_nfix_layer,nfix_layer) + + + ! ------------------------------------------------------------------------------- + ! Symbiotic N Fixation is handled via Houlton et al 2008 and Fisher et al. 2010 + ! + ! A unifying framework for dinitrogen fixation in the terrestrial biosphere + ! Benjamin Z. Houlton, Ying-Ping Wang, Peter M. Vitousek & Christopher B. Field + ! Nature volume 454, pages327–330 (2008) https://doi.org/10.1038/nature07028 + ! + ! Carbon cost of plant nitrogen acquisition: A mechanistic, globally applicable model + ! of plant nitrogen uptake, retranslocation, and fixation. J. B. Fisher,S. Sitch,Y. + ! Malhi,R. A. Fisher,C. Huntingford,S.-Y. Tan. Global Biogeochemical Cycles. March + ! 2010 https://doi.org/10.1029/2009GB003621 + ! + ! ------------------------------------------------------------------------------ + + + real(r8),intent(in) :: t_soil ! Temperature of the current soil layer [degC] + integer,intent(in) :: ft ! Functional type index + real(r8),intent(in) :: dtime ! Time step length [s] + real(r8),intent(in) :: fnrt_mr_layer ! Amount of maintenance respiration in the fine-roots + ! for all non-fixation related processes [kgC/s] + + real(r8),intent(out) :: fnrt_mr_nfix_layer ! The added maintenance respiration due to nfixation + ! to be added as a surcharge to non-fixation MR [kgC] + real(r8),intent(out) :: nfix_layer ! The amount of N fixed in this layer through + ! symbiotic activity [kgN] + + real(r8) :: c_cost_nfix ! carbon cost of N fixation [kgC/kgN] + real(r8) :: c_spent_nfix ! carbon spent on N fixation, per layer [kgC/plant/timestep] + + ! N fixation parameters from Houlton et al (2008) and Fisher et al (2010) + real(r8), parameter :: s_fix = -6.25_r8 ! s parameter from FUN model (fisher et al 2010) + real(r8), parameter :: a_fix = -3.62_r8 ! a parameter from Houlton et al. 2010 (a = -3.62 +/- 0.52) + real(r8), parameter :: b_fix = 0.27_r8 ! b parameter from Houlton et al. 2010 (b = 0.27 +/-0.04) + real(r8), parameter :: c_fix = 25.15_r8 ! c parameter from Houlton et al. 2010 (c = 25.15 +/- 0.66) + + ! Amount of C spent (as part of MR respiration) on symbiotic fixation [kgC/s] + fnrt_mr_nfix_layer = fnrt_mr_layer * prt_params%nfix_mresp_scfrac(ft) + + ! This is the unit carbon cost for nitrogen fixation. It is temperature dependant [kgC/kgN] + c_cost_nfix = s_fix * (exp(a_fix + b_fix * (t_soil-tfrz) & + * (1._r8 - 0.5_r8 * (t_soil-tfrz) / c_fix)) - 2._r8) + + ! Time integrated amount of carbon spent on fixation (in this layer) [kgC/plant/layer/tstep] + c_spent_nfix = fnrt_mr_nfix_layer * dtime + + ! Amount of nitrogen fixed in this layer [kgC/plant/layer/tstep]/[kgC/kgN] = [kgN/plant/layer/tstep] + nfix_layer = c_spent_nfix / c_cost_nfix + + return + end subroutine RootLayerNFixation + + + ! ======================================================================================= + + subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in + parsun_lsl, & ! in + parsha_lsl, & ! in + elai_lsl, & ! in + ft, & ! in + vcmax, & ! in + jmax, & ! in + co2_rcurve_islope, & ! in + veg_tempk, & ! in + veg_esat, & ! in + can_press, & ! in + can_co2_ppress, & ! in + can_o2_ppress, & ! in + btran, & ! in + stomatal_intercept_btran, & ! in + cf, & ! in + gb_mol, & ! in + ceair, & ! in + mm_kco2, & ! in + mm_ko2, & ! in + co2_cpoint, & ! in + lmr, & ! in + leaf_psi, & ! in + rb, & ! in + psn_out, & ! out + rstoma_out, & ! out + anet_av_out, & ! out + c13disc_z) ! out + + + ! ------------------------------------------------------------------------------------ + ! This subroutine calculates photosynthesis and stomatal conductance within each leaf + ! sublayer. + ! A note on naming conventions: As this subroutine is called for every + ! leaf-sublayer, many of the arguments are specific to that "leaf sub layer" + ! (LSL), those variables are given a dimension tag "_lsl" + ! Other arguments or variables may be indicative of scales broader than the LSL. + ! ------------------------------------------------------------------------------------ + + use EDParamsMod , only : theta_cj_c3, theta_cj_c4 + + + ! Arguments + ! ------------------------------------------------------------------------------------ + real(r8), intent(in) :: f_sun_lsl ! + real(r8), intent(in) :: parsun_lsl ! Absorbed PAR in sunlist leaves per sunlit leaf area [W/m2 leaf] + real(r8), intent(in) :: parsha_lsl ! Absorved PAR in shaded leaves per shaded leaf area [W/m2 leaf] + real(r8), intent(in) :: elai_lsl ! ELAI of this layer [m2/m2] + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) + real(r8), intent(in) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) + real(r8), intent(in) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) + real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8), intent(in) :: veg_esat ! saturation vapor pressure at veg_tempk (Pa) + + ! Important Note on the following gas pressures. This photosynthesis scheme will iteratively + ! solve for the co2 partial pressure at the leaf surface (ie in the stomata). The reference + ! point for these input values are NOT within that boundary layer that separates the stomata from + ! the canopy air space. The reference point for these is on the outside of that boundary + ! layer. This routine, which operates at the leaf scale, makes no assumptions about what the + ! scale of the refernce is, it could be lower atmosphere, it could be within the canopy + ! but most likely it is the closest value one can get to the edge of the leaf's boundary + ! layer. We use the convention "can_" because a reference point of within the canopy + ! ia a best reasonable scenario of where we can get that information from. + + real(r8), intent(in) :: can_press ! Air pressure NEAR the surface of the leaf (Pa) + real(r8), intent(in) :: can_co2_ppress ! Partial pressure of CO2 NEAR the leaf surface (Pa) + real(r8), intent(in) :: can_o2_ppress ! Partial pressure of O2 NEAR the leaf surface (Pa) + real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) + real(r8), intent(in) :: stomatal_intercept_btran !water-stressed minimum stomatal conductance (umol H2O/m**2/s) + real(r8), intent(in) :: cf ! s m**2/umol -> s/m (ideal gas conversion) [umol/m3] + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol /m**2/s) + real(r8), intent(in) :: ceair ! vapor pressure of air, constrained (Pa) + real(r8), intent(in) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) + real(r8), intent(in) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) + real(r8), intent(in) :: co2_cpoint ! CO2 compensation point (Pa) + real(r8), intent(in) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) + real(r8), intent(in) :: leaf_psi ! Leaf water potential [MPa] + real(r8), intent(in) :: rb ! Boundary Layer resistance of leaf [s/m] + + real(r8), intent(out) :: psn_out ! carbon assimilated in this leaf layer umolC/m2/s + real(r8), intent(out) :: rstoma_out ! stomatal resistance (1/gs_lsl) (s/m) + real(r8), intent(out) :: anet_av_out ! net leaf photosynthesis (umol CO2/m**2/s) + ! averaged over sun and shade leaves. + real(r8), intent(out) :: c13disc_z ! carbon 13 in newly assimilated carbon + + + + + ! Locals + ! ------------------------------------------------------------------------ + integer :: c3c4_path_index ! Index for which photosynthetic pathway + ! is active. C4 = 0, C3 = 1 + integer :: sunsha ! Index for differentiating sun and shade + real(r8) :: gstoma ! Stomatal Conductance of this leaf layer (m/s) + real(r8) :: agross ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: anet ! net leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: a_gs ! The assimilation (a) for calculating conductance (gs) + ! is either = to anet or agross + real(r8) :: je ! electron transport rate (umol electrons/m**2/s) + real(r8) :: qabs ! PAR absorbed by PS II (umol photons/m**2/s) + real(r8) :: aquad,bquad,cquad ! terms for quadratic equations + real(r8) :: r1,r2 ! roots of quadratic equation + real(r8) :: co2_inter_c ! intercellular leaf CO2 (Pa) + real(r8) :: co2_inter_c_old ! intercellular leaf CO2 (Pa) (previous iteration) + logical :: loop_continue ! Loop control variable + integer :: niter ! iteration loop index + real(r8) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) + real(r8) :: gs ! leaf stomatal conductance (m/s) + real(r8) :: hs ! fractional humidity at leaf surface (dimensionless) + real(r8) :: gs_mol_err ! gs_mol for error check + real(r8) :: ac ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) + real(r8) :: aj ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) + real(r8) :: ap ! product-limited (C3) or CO2-limited + ! (C4) gross photosynthesis (umol CO2/m**2/s) + real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) + real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) + real(r8) :: init_co2_inter_c ! First guess intercellular co2 specific to C path + real(r8) :: term ! intermediate variable in Medlyn stomatal conductance model + real(r8) :: vpd ! water vapor deficit in Medlyn stomatal model (KPa) + + + ! Parameters + ! ------------------------------------------------------------------------ + ! Fraction of light absorbed by non-photosynthetic pigments + real(r8),parameter :: fnps = 0.15_r8 + + ! For plants with no leaves, a miniscule amount of conductance + ! can happen through the stems, at a partial rate of cuticular conductance + real(r8),parameter :: stem_cuticle_loss_frac = 0.1_r8 + + ! empirical curvature parameter for electron transport rate + real(r8),parameter :: theta_psii = 0.7_r8 + + ! First guess on ratio between intercellular co2 and the atmosphere + ! an iterator converges on actual + real(r8),parameter :: init_a2l_co2_c3 = 0.7_r8 + real(r8),parameter :: init_a2l_co2_c4 = 0.4_r8 + + ! quantum efficiency, used only for C4 (mol CO2 / mol photons) (index 0) + real(r8),parameter,dimension(0:1) :: quant_eff = [0.05_r8,0.0_r8] + + ! empirical curvature parameter for ap photosynthesis co-limitation + real(r8),parameter :: theta_ip = 0.999_r8 + + associate( bb_slope => EDPftvarcon_inst%bb_slope ,& ! slope of BB relationship, unitless + medlyn_slope=> EDPftvarcon_inst%medlyn_slope , & ! Slope for Medlyn stomatal conductance model method, the unit is KPa^0.5 + stomatal_intercept=> EDPftvarcon_inst%stomatal_intercept ) !Unstressed minimum stomatal conductance, the unit is umol/m**2/s -subroutine quadratic_f (a, b, c, r1, r2) - ! - ! !DESCRIPTION: - !==============================================================================! - !----------------- Solve quadratic equation for its two roots -----------------! - !==============================================================================! - ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific - ! Computing (Cambridge University Press, Cambridge), pp. 145. - ! - ! !REVISION HISTORY: - ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - ! !USES: - ! - ! !ARGUMENTS: - real(r8), intent(in) :: a,b,c ! Terms for quadratic equation - real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation - ! - ! !LOCAL VARIABLES: - real(r8) :: q ! Temporary term for quadratic solution - !------------------------------------------------------------------------------ - - if (a == 0._r8) then - write (fates_log(),*) 'Quadratic solution error: a = ',a - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - if (b >= 0._r8) then - q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) - else - q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) - end if - - r1 = q / a - if (q /= 0._r8) then - r2 = c / q - else - r2 = 1.e36_r8 - end if - -end subroutine quadratic_f - -! ==================================================================================== - -subroutine quadratic_fast (a, b, c, r1, r2) - ! - ! !DESCRIPTION: - !==============================================================================! - !----------------- Solve quadratic equation for its two roots -----------------! - ! THIS METHOD SIMPLY REMOVES THE DIV0 CHECK AND ERROR REPORTING ! - !==============================================================================! - ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific - ! Computing (Cambridge University Press, Cambridge), pp. 145. - ! - ! !REVISION HISTORY: - ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - ! !USES: - ! - ! !ARGUMENTS: - real(r8), intent(in) :: a,b,c ! Terms for quadratic equation - real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation - ! - ! !LOCAL VARIABLES: - real(r8) :: q ! Temporary term for quadratic solution - !------------------------------------------------------------------------------ - - ! if (a == 0._r8) then - ! write (fates_log(),*) 'Quadratic solution error: a = ',a - ! call endrun(msg=errMsg(sourcefile, __LINE__)) - ! end if - - if (b >= 0._r8) then - q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) - else - q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) - end if - - r1 = q / a - ! if (q /= 0._r8) then - r2 = c / q - ! else - ! r2 = 1.e36_r8 - ! end if - -end subroutine quadratic_fast - - -! ==================================================================================== - -subroutine UpdateCanopyNCanNRadPresent(currentPatch) - - ! --------------------------------------------------------------------------------- - ! This subroutine calculates two patch level quanities: - ! currentPatch%ncan and - ! currentPatch%canopy_mask - ! - ! currentPatch%ncan(:,:) is a two dimensional array that indicates - ! the total number of leaf layers (including those that are not exposed to light) - ! in each canopy layer and for each functional type. - ! - ! currentPatch%nrad(:,:) is a two dimensional array that indicates - ! the total number of EXPOSED leaf layers, but for all intents and purposes - ! in the photosynthesis routine, this appears to be the same as %ncan... - ! - ! currentPatch%canopy_mask(:,:) has the same dimensions, is binary, and - ! indicates whether or not leaf layers are present (by evaluating the canopy area - ! profile). - ! --------------------------------------------------------------------------------- - - ! Arguments - type(fates_patch_type), target :: currentPatch - type(fates_cohort_type), pointer :: currentCohort - - ! Locals - integer :: cl ! Canopy Layer Index - integer :: ft ! Function Type Index - integer :: iv ! index of the exposed leaf layer for each canopy layer and pft - - ! Loop through the cohorts in this patch, associate each cohort with a layer and PFT - ! and use the cohort's memory of how many layer's it takes up to assign the maximum - ! of the layer/pft index it is in - ! --------------------------------------------------------------------------------- - - currentPatch%ncan(:,:) = 0 - ! redo the canopy structure algorithm to get round a - ! bug that is happening for site 125, FT13. - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) - - currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft) = & - max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft), & - currentCohort%NV) - - currentCohort => currentCohort%shorter - - enddo !cohort - - ! NRAD = NCAN ... - currentPatch%nrad = currentPatch%ncan - - ! Now loop through and identify which layer and pft combo has scattering elements - do cl = 1,nclmax - do ft = 1,numpft - currentPatch%canopy_mask(cl,ft) = 0 - do iv = 1, currentPatch%nrad(cl,ft); - if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then - currentPatch%canopy_mask(cl,ft) = 1 - end if - end do !iv - enddo !ft - enddo !cl - - return -end subroutine UpdateCanopyNCanNRadPresent - -! ==================================================================================== - -subroutine GetCanopyGasParameters(can_press, & - can_o2_partialpress, & - veg_tempk, & - air_tempk, & - air_vpress, & - veg_esat, & - rb, & - mm_kco2, & - mm_ko2, & - co2_cpoint, & - cf, & - gb_mol, & - ceair) - - ! --------------------------------------------------------------------------------- - ! This subroutine calculates the specific Michaelis Menten Parameters (pa) for CO2 - ! and O2, as well as the CO2 compentation point. - ! --------------------------------------------------------------------------------- - - use FatesConstantsMod, only: umol_per_mol - use FatesConstantsMod, only: mmol_per_mol - use FatesConstantsMod, only: umol_per_kmol - use FatesConstantsMod, only : rgas => rgas_J_K_kmol - - ! Arguments - real(r8), intent(in) :: can_press ! Air pressure within the canopy (Pa) - real(r8), intent(in) :: can_o2_partialpress ! Partial press of o2 in the canopy (Pa) - real(r8), intent(in) :: veg_tempk ! The temperature of the vegetation (K) - real(r8), intent(in) :: air_tempk ! Temperature of canopy air (K) - real(r8), intent(in) :: air_vpress ! Vapor pressure of canopy air (Pa) - real(r8), intent(in) :: veg_esat ! Saturated vapor pressure at veg surf (Pa) - real(r8), intent(in) :: rb ! Leaf Boundary layer resistance (s/m) - - real(r8), intent(out) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) - real(r8), intent(out) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) - real(r8), intent(out) :: co2_cpoint ! CO2 compensation point (Pa) - real(r8), intent(out) :: cf ! conversion factor between molar form and velocity form - ! of conductance and resistance: [umol/m3] - real(r8), intent(out) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) - real(r8), intent(out) :: ceair ! vapor pressure of air, constrained (Pa) - - ! Locals - real(r8) :: kc25 ! Michaelis-Menten constant for CO2 at 25C (Pa) - real(r8) :: ko25 ! Michaelis-Menten constant for O2 at 25C (Pa) - real(r8) :: sco ! relative specificity of rubisco - real(r8) :: cp25 ! CO2 compensation point at 25C (Pa) - - ! --------------------------------------------------------------------------------- - ! Intensive values (per mol of air) - ! kc, ko, currentPatch, from: Bernacchi et al (2001) - ! Plant, Cell and Environment 24:253-259 - ! --------------------------------------------------------------------------------- - - real(r8), parameter :: mm_kc25_umol_per_mol = 404.9_r8 - real(r8), parameter :: mm_ko25_mmol_per_mol = 278.4_r8 - real(r8), parameter :: co2_cpoint_umol_per_mol = 42.75_r8 - - ! Activation energy, from: - ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 - ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 - - real(r8), parameter :: kcha = 79430._r8 ! activation energy for kc (J/mol) - real(r8), parameter :: koha = 36380._r8 ! activation energy for ko (J/mol) - real(r8), parameter :: cpha = 37830._r8 ! activation energy for cp (J/mol) - - - ! Derive sco from currentPatch and O2 using present-day O2 (0.209 mol/mol) and re-calculate - ! currentPatch to account for variation in O2 using currentPatch = 0.5 O2 / sco - - ! FIXME (RGK 11-30-2016 THere are more constants here, but I don't have enough information - ! about what they are or do, so I can't give them more descriptive names. Someone please - ! fill this in when possible) - - kc25 = ( mm_kc25_umol_per_mol / umol_per_mol ) * can_press - ko25 = ( mm_ko25_mmol_per_mol / mmol_per_mol ) * can_press - sco = 0.5_r8 * 0.209_r8 / (co2_cpoint_umol_per_mol / umol_per_mol ) - cp25 = 0.5_r8 * can_o2_partialpress / sco - - if( veg_tempk.gt.150_r8 .and. veg_tempk.lt.350_r8 )then - mm_kco2 = kc25 * ft1_f(veg_tempk, kcha) - mm_ko2 = ko25 * ft1_f(veg_tempk, koha) - co2_cpoint = cp25 * ft1_f(veg_tempk, cpha) - else - mm_kco2 = 1.0_r8 - mm_ko2 = 1.0_r8 - co2_cpoint = 1.0_r8 - end if - - ! --------------------------------------------------------------------------------- - ! - ! cf is the conversion factor between molar form and velocity form - ! of conductance and resistance: [umol/m3] - ! - ! i.e. - ! [m/s] * [umol/m3] -> [umol/m2/s] - ! - ! Breakdown of the conversion factor: [ umol / m3 ] - ! - ! Rgas [J /K /kmol] - ! Air Potential Temperature [ K ] - ! Canopy Pressure [ Pa ] - ! conversion: umol/kmol = 1e9 - ! - ! [ Pa * K * kmol umol/kmol / J K ] = [ Pa * umol / J ] - ! since: 1 Pa = 1 N / m2 - ! [ Pa * umol / J ] = [ N * umol / J m2 ] - ! since: 1 J = 1 N * m - ! [ N * umol / J m2 ] = [ N * umol / N m3 ] - ! [ umol / m3 ] - ! - ! -------------------------------------------------------------------------------- - - cf = can_press/(rgas * air_tempk )*umol_per_kmol - gb_mol = (1._r8/ rb) * cf - - ! Constrain eair >= 0.05*esat_tv so that solution does not blow up. This ensures - ! that hs does not go to zero. Also eair <= veg_esat so that hs <= 1 - ceair = min( max(air_vpress, 0.05_r8*veg_esat ),veg_esat ) - - - - return -end subroutine GetCanopyGasParameters - -! ==================================================================================== - -subroutine LeafLayerMaintenanceRespiration_Ryan_1991(lnc_top, & - nscaler, & - ft, & - veg_tempk, & - lmr) - - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - use FatesConstantsMod, only : umolC_to_kgC - use FatesConstantsMod, only : g_per_kg - use EDPftvarcon , only : EDPftvarcon_inst - - ! ----------------------------------------------------------------------- - ! Base maintenance respiration rate for plant tissues maintresp_leaf_ryan1991_baserate - ! M. Ryan, 1991. Effects of climate change on plant respiration. - ! Ecological Applications, 1(2), 157-167. - ! Original expression is br = 0.0106 molC/(molN h) - ! Conversion by molecular weights of C and N gives 2.525e-6 gC/(gN s) - ! Which is the default value of maintresp_nonleaf_baserate - - ! Arguments - real(r8), intent(in) :: lnc_top ! Leaf nitrogen content per unit area at canopy top [gN/m2] - real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile - integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8) :: veg_tempk ! vegetation temperature - real(r8), intent(out) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) - - ! Locals - real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) - real(r8) :: lmr25top ! canopy top leaf maint resp rate at 25C for this pft (umol CO2/m**2/s) - integer :: c3c4_path_index ! Index for which photosynthetic pathway - - ! Parameter - real(r8), parameter :: lmrha = 46390._r8 ! activation energy for lmr (J/mol) - real(r8), parameter :: lmrhd = 150650._r8 ! deactivation energy for lmr (J/mol) - real(r8), parameter :: lmrse = 490._r8 ! entropy term for lmr (J/mol/K) - real(r8), parameter :: lmrc = 1.15912391_r8 ! scaling factor for high - ! temperature inhibition (25 C = 1.0) - - !veg_tempk = 27._r8+271._r8 - - lmr25top = EDPftvarcon_inst%maintresp_leaf_ryan1991_baserate(ft) * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) - lmr25top = lmr25top * lnc_top / (umolC_to_kgC * g_per_kg) - - - ! Part I: Leaf Maintenance respiration: umol CO2 / m**2 [leaf] / s - ! ---------------------------------------------------------------------------------- - lmr25 = lmr25top * nscaler - - ! photosynthetic pathway: 0. = c4, 1. = c3 - c3c4_path_index = nint(EDPftvarcon_inst%c3psn(ft)) - - if (c3c4_path_index == c3_path_index) then - ! temperature sensitivity of C3 plants - lmr = lmr25 * ft1_f(veg_tempk, lmrha) * & - fth_f(veg_tempk, lmrhd, lmrse, lmrc) - else - ! temperature sensitivity of C4 plants - lmr = lmr25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) - lmr = lmr / (1._r8 + exp( 1.3_r8*(veg_tempk-(tfrz+55._r8)) )) - endif - - ! Any hydrodynamic limitations could go here, currently none - ! lmr = lmr * (nothing) - -end subroutine LeafLayerMaintenanceRespiration_Ryan_1991 - -! ==================================================================================== - -subroutine LeafLayerMaintenanceRespiration_Atkin_etal_2017(lnc_top, & - nscaler, & - ft, & - veg_tempk, & - tgrowth, & - lmr) - - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - use FatesConstantsMod, only : umolC_to_kgC - use FatesConstantsMod, only : g_per_kg - use FatesConstantsMod, only : lmr_b - use FatesConstantsMod, only : lmr_c - use FatesConstantsMod, only : lmr_TrefC - use FatesConstantsMod, only : lmr_r_1 - use FatesConstantsMod, only : lmr_r_2 - use EDPftvarcon , only : EDPftvarcon_inst - - ! Arguments - real(r8), intent(in) :: lnc_top ! Leaf nitrogen content per unit area at canopy top [gN/m2] - integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile - real(r8), intent(in) :: veg_tempk ! vegetation temperature (degrees K) - real(r8), intent(in) :: tgrowth ! lagged vegetation temperature averaged over acclimation timescale (degrees K) - real(r8), intent(out) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) - - ! Locals - real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) - real(r8) :: r_0 ! base respiration rate, PFT-dependent (umol CO2/m**2/s) - real(r8) :: r_t_ref ! acclimated ref respiration rate (umol CO2/m**2/s) - real(r8) :: lmr25top ! canopy top leaf maint resp rate at 25C for this pft (umol CO2/m**2/s) - - ! parameter values of r_0 as listed in Atkin et al 2017: (umol CO2/m**2/s) - ! Broad-leaved trees 1.7560 - ! Needle-leaf trees 1.4995 - ! Shrubs 2.0749 - ! C3 herbs/grasses 2.1956 - ! In the absence of better information, we use the same value for C4 grasses as C3 grasses. - - ! note that this code uses the relationship between leaf N and respiration from Atkin et al - ! for the top of the canopy, but then assumes proportionality with N through the canopy. - - ! r_0 currently put into the EDPftvarcon_inst%dev_arbitrary_pft - ! all figs in Atkin et al 2017 stop at zero Celsius so we will assume acclimation is fixed below that - r_0 = EDPftvarcon_inst%maintresp_leaf_atkin2017_baserate(ft) - r_t_ref = max( 0._r8, nscaler * (r_0 + lmr_r_1 * lnc_top + lmr_r_2 * max(0._r8, (tgrowth - tfrz) )) ) - - if (r_t_ref .eq. 0._r8) then - warn_msg = 'Rdark is negative at this temperature and is capped at 0. tgrowth (C): '//trim(N2S(tgrowth-tfrz))//' pft: '//trim(I2S(ft)) - call FatesWarn(warn_msg,index=4) - end if - - lmr = r_t_ref * exp(lmr_b * (veg_tempk - tfrz - lmr_TrefC) + lmr_c * & - ((veg_tempk-tfrz)**2 - lmr_TrefC**2)) - -end subroutine LeafLayerMaintenanceRespiration_Atkin_etal_2017 - -! ==================================================================================== - -subroutine LeafLayerBiophysicalRates( parsun_per_la, & - ft, & - vcmax25top_ft, & - jmax25top_ft, & - co2_rcurve_islope25top_ft, & - nscaler, & - veg_tempk, & - t_growth, & - t_home, & - btran, & - vcmax, & - jmax, & - co2_rcurve_islope ) - - ! --------------------------------------------------------------------------------- - ! This subroutine calculates the localized rates of several key photosynthesis - ! rates. By localized, we mean specific to the plant type and leaf layer, - ! which factors in leaf physiology, as well as environmental effects. - ! This procedure should be called prior to iterative solvers, and should - ! have pre-calculated the reference rates for the pfts before this. - ! - ! The output biophysical rates are: - ! vcmax: maximum rate of carboxilation, - ! jmax: maximum electron transport rate, - ! co2_rcurve_islope: initial slope of CO2 response curve (C4 plants) - ! --------------------------------------------------------------------------------- - - use EDPftvarcon , only : EDPftvarcon_inst - - ! Arguments - ! ------------------------------------------------------------------------------ - - real(r8), intent(in) :: parsun_per_la ! PAR absorbed per sunlit leaves for this layer - integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile - real(r8), intent(in) :: vcmax25top_ft ! canopy top maximum rate of carboxylation at 25C - ! for this pft (umol CO2/m**2/s) - real(r8), intent(in) :: jmax25top_ft ! canopy top maximum electron transport rate at 25C - ! for this pft (umol electrons/m**2/s) - real(r8), intent(in) :: co2_rcurve_islope25top_ft ! initial slope of CO2 response curve - ! (C4 plants) at 25C, canopy top, this pft - real(r8), intent(in) :: veg_tempk ! vegetation temperature - real(r8), intent(in) :: t_growth ! T_growth (short-term running mean temperature) (K) - real(r8), intent(in) :: t_home ! T_home (long-term running mean temperature) (K) - real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) - - real(r8), intent(out) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) - real(r8), intent(out) :: jmax ! maximum electron transport rate - ! (umol electrons/m**2/s) - real(r8), intent(out) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) - - ! Locals - ! ------------------------------------------------------------------------------- - real(r8) :: vcmax25 ! leaf layer: maximum rate of carboxylation at 25C - ! (umol CO2/m**2/s) - real(r8) :: jmax25 ! leaf layer: maximum electron transport rate at 25C - ! (umol electrons/m**2/s) - real(r8) :: co2_rcurve_islope25 ! leaf layer: Initial slope of CO2 response curve - ! (C4 plants) at 25C - integer :: c3c4_path_index ! Index for which photosynthetic pathway - - ! Parameters - ! --------------------------------------------------------------------------------- - real(r8) :: vcmaxha ! activation energy for vcmax (J/mol) - real(r8) :: jmaxha ! activation energy for jmax (J/mol) - real(r8) :: vcmaxhd ! deactivation energy for vcmax (J/mol) - real(r8) :: jmaxhd ! deactivation energy for jmax (J/mol) - real(r8) :: vcmaxse ! entropy term for vcmax (J/mol/K) - real(r8) :: jmaxse ! entropy term for jmax (J/mol/K) - real(r8) :: t_growth_celsius ! average growing temperature - real(r8) :: t_home_celsius ! average home temperature - real(r8) :: jvr ! ratio of Jmax25 / Vcmax25 - real(r8) :: vcmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) - real(r8) :: jmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) - - select case(photo_tempsens_model) - case (photosynth_acclim_model_none) !No temperature acclimation - vcmaxha = EDPftvarcon_inst%vcmaxha(FT) - jmaxha = EDPftvarcon_inst%jmaxha(FT) - vcmaxhd = EDPftvarcon_inst%vcmaxhd(FT) - jmaxhd = EDPftvarcon_inst%jmaxhd(FT) - vcmaxse = EDPftvarcon_inst%vcmaxse(FT) - jmaxse = EDPftvarcon_inst%jmaxse(FT) - case (photosynth_acclim_model_kumarathunge_etal_2019) !Kumarathunge et al. temperature acclimation, Thome=30-year running mean - t_growth_celsius = t_growth-tfrz - t_home_celsius = t_home-tfrz - vcmaxha = (42.6_r8 + (1.14_r8*t_growth_celsius))*1e3_r8 !J/mol - jmaxha = 40.71_r8*1e3_r8 !J/mol - vcmaxhd = 200._r8*1e3_r8 !J/mol - jmaxhd = 200._r8*1e3_r8 !J/mol - vcmaxse = (645.13_r8 - (0.38_r8*t_growth_celsius)) - jmaxse = 658.77_r8 - (0.84_r8*t_home_celsius) - 0.52_r8*(t_growth_celsius-t_home_celsius) - jvr = 2.56_r8 - (0.0375_r8*t_home_celsius)-(0.0202_r8*(t_growth_celsius-t_home_celsius)) - case default - write (fates_log(),*)'error, incorrect leaf photosynthesis temperature acclimation model specified' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - vcmaxc = fth25_f(vcmaxhd, vcmaxse) - jmaxc = fth25_f(jmaxhd, jmaxse) - - if ( parsun_per_la <= nearzero) then ! night time - vcmax = 0._r8 - jmax = 0._r8 - co2_rcurve_islope = 0._r8 - else ! day time - - ! Vcmax25top was already calculated to derive the nscaler function - vcmax25 = vcmax25top_ft * nscaler - select case(photo_tempsens_model) - case (photosynth_acclim_model_none) - jmax25 = jmax25top_ft * nscaler - case (photosynth_acclim_model_kumarathunge_etal_2019) - jmax25 = vcmax25*jvr - case default - write (fates_log(),*)'error, incorrect leaf photosynthesis temperature acclimation model specified' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - co2_rcurve_islope25 = co2_rcurve_islope25top_ft * nscaler - - ! Adjust for temperature ! photosynthetic pathway: 0. = c4, 1. = c3 c3c4_path_index = nint(EDPftvarcon_inst%c3psn(ft)) if (c3c4_path_index == c3_path_index) then - vcmax = vcmax25 * ft1_f(veg_tempk, vcmaxha) * fth_f(veg_tempk, vcmaxhd, vcmaxse, vcmaxc) + init_co2_inter_c = init_a2l_co2_c3 * can_co2_ppress else - vcmax = vcmax25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) - vcmax = vcmax / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-veg_tempk ) )) - vcmax = vcmax / (1._r8 + exp( 0.3_r8*(veg_tempk-(tfrz+40._r8)) )) + init_co2_inter_c = init_a2l_co2_c4 * can_co2_ppress end if - jmax = jmax25 * ft1_f(veg_tempk, jmaxha) * fth_f(veg_tempk, jmaxhd, jmaxse, jmaxc) - - !q10 response of product limited psn. - co2_rcurve_islope = co2_rcurve_islope25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) - end if - - ! Adjust for water limitations - vcmax = vcmax * btran - - return - - end subroutine LeafLayerBiophysicalRates - -subroutine lowstorage_maintresp_reduction(frac, pft, maintresp_reduction_factor) - - ! This subroutine reduces maintenance respiration rates when storage pool is low. The premise - ! of this is that mortality of plants increases when storage is low because they are not able - ! to repair tissues, generate defense compounds, etc. This reduction is reflected in a reduced - ! maintenance demand. The output of this function takes the form of a curve between 0 and 1, - ! and the curvature of the function is determined by a parameter. - - ! Uses - use EDPftvarcon , only : EDPftvarcon_inst - - ! Arguments - ! ------------------------------------------------------------------------------ - real(r8), intent(in) :: frac ! ratio of storage to target leaf biomass - integer, intent(in) :: pft ! what pft is this cohort? - real(r8), intent(out) :: maintresp_reduction_factor ! the factor by which to reduce maintenance respiration - - ! -------------------------------------------------------------------------------- - ! Parameters are at the PFT level: - ! fates_maintresp_reduction_curvature controls the curvature of this. - ! If this parameter is zero, then there is no reduction until the plant dies at storage = 0. - ! If this parameter is one, then there is a linear reduction in respiration below the storage point. - ! Intermediate values will give some (concave-downwards) curvature. - ! - ! maintresp_reduction_intercept controls the maximum amount of throttling. - ! zero means no throttling at any point, so it turns this mechanism off completely and so - ! allows an entire cohort to die via negative carbon-induced termination mortality. - ! one means complete throttling, so no maintenance respiration at all, when out of carbon. - ! --------------------------------------------------------------------------------- - - if( frac .lt. 1._r8 )then - if ( abs(EDPftvarcon_inst%maintresp_reduction_curvature(pft)-1._r8) > nearzero ) then - maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & - EDPftvarcon_inst%maintresp_reduction_intercept(pft) * & - (1._r8 - EDPftvarcon_inst%maintresp_reduction_curvature(pft)**frac) & - / (1._r8-EDPftvarcon_inst%maintresp_reduction_curvature(pft)) - else ! avoid nan answer for linear case - maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & - EDPftvarcon_inst%maintresp_reduction_intercept(pft) * frac - endif - - else - maintresp_reduction_factor = 1._r8 - endif - - -end subroutine lowstorage_maintresp_reduction + ! Part III: Photosynthesis and Conductance + ! ---------------------------------------------------------------------------------- + + if_daytime: if ( parsun_lsl <= 0._r8 ) then ! night time + + anet_av_out = -lmr + psn_out = 0._r8 + + ! The cuticular conductance already factored in maximum resistance as a bound + ! no need to re-bound it + + rstoma_out = cf/stomatal_intercept_btran + + c13disc_z = 0.0_r8 !carbon 13 discrimination in night time carbon flux, note value of 1.0 is used in CLM + + else ! day time (a little bit more complicated ...) + + ! Is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) + + if_leafarea: if (elai_lsl > 0._r8 ) then + + !Loop aroun shaded and unshaded leaves + psn_out = 0._r8 ! psn is accumulated across sun and shaded leaves. + rstoma_out = 0._r8 ! 1/rs is accumulated across sun and shaded leaves. + anet_av_out = 0._r8 + gstoma = 0._r8 + + do sunsha = 1,2 + + ! Electron transport rate for C3 plants. + ! Convert par from W/m2 to umol photons/m**2/s using the factor 4.6 + ! Convert from units of par absorbed per unit ground area to par + ! absorbed per unit leaf area. + ! The 0.5 term here accounts for half of the light going to photosystem + ! 2, as mentioned in Biochemical models of leaf photosynthesis + ! (von Caemmerer) and Farquhar 1980 + + if(sunsha == 1)then !sunlit + qabs = parsun_lsl * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 + else + qabs = parsha_lsl * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 + end if + + !convert the absorbed par into absorbed par per m2 of leaf, + ! so it is consistant with the vcmax and lmr numbers. + aquad = theta_psii + bquad = -(qabs + jmax) + cquad = qabs * jmax + call quadratic_f (aquad, bquad, cquad, r1, r2) + je = min(r1,r2) + + ! Initialize intercellular co2 + co2_inter_c = init_co2_inter_c + + niter = 0 + loop_continue = .true. + iter_loop: do while(loop_continue) + ! Increment iteration counter. Stop if too many iterations + niter = niter + 1 + + ! Save old co2_inter_c + co2_inter_c_old = co2_inter_c + + ! Photosynthesis limitation rate calculations + if (c3c4_path_index == c3_path_index)then + + ! C3: Rubisco-limited photosynthesis + ac = vcmax * max(co2_inter_c-co2_cpoint, 0._r8) / & + (co2_inter_c+mm_kco2 * (1._r8+can_o2_ppress / mm_ko2 )) + + ! C3: RuBP-limited photosynthesis + aj = je * max(co2_inter_c-co2_cpoint, 0._r8) / & + (4._r8*co2_inter_c+8._r8*co2_cpoint) + + ! Gross photosynthesis smoothing calculations. Co-limit ac and aj. + aquad = theta_cj_c3 + bquad = -(ac + aj) + cquad = ac * aj + call quadratic_f (aquad, bquad, cquad, r1, r2) + agross = min(r1,r2) + + else + + ! C4: Rubisco-limited photosynthesis + ac = vcmax + + ! C4: RuBP-limited photosynthesis + if(sunsha == 1)then !sunlit + aj = quant_eff(c3c4_path_index) * parsun_lsl * 4.6_r8 + else + aj = quant_eff(c3c4_path_index) * parsha_lsl * 4.6_r8 + end if + + ! C4: PEP carboxylase-limited (CO2-limited) + ap = co2_rcurve_islope * max(co2_inter_c, 0._r8) / can_press + + ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap + + aquad = theta_cj_c4 + bquad = -(ac + aj) + cquad = ac * aj + call quadratic_f (aquad, bquad, cquad, r1, r2) + ai = min(r1,r2) + + aquad = theta_ip + bquad = -(ai + ap) + cquad = ai * ap + call quadratic_f (aquad, bquad, cquad, r1, r2) + agross = min(r1,r2) + + end if + + ! Calculate anet, only exit iteration with negative anet when + ! using anet in calculating gs this is version B + anet = agross - lmr + + if ( stomatal_assim_model == gross_assim_model ) then + if ( stomatal_model == medlyn_model ) then + write (fates_log(),*) 'Gross Assimilation conductance is incompatible with the Medlyn model' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + a_gs = agross + else + if (anet < 0._r8) then + loop_continue = .false. + end if + a_gs = anet + end if + + ! With an <= 0, then gs_mol = stomatal_intercept_btran + leaf_co2_ppress = can_co2_ppress- h2o_co2_bl_diffuse_ratio/gb_mol * a_gs * can_press + leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + + if ( stomatal_model == medlyn_model ) then + !stomatal conductance calculated from Medlyn et al. (2011), the numerical & + !implementation was adapted from the equations in CLM5.0 + vpd = max((veg_esat - ceair), 50._r8) * 0.001_r8 !addapted from CLM5. Put some constraint on VPD + !when Medlyn stomatal conductance is being used, the unit is KPa. Ignoring the constraint will cause errors when model runs. + term = h2o_co2_stoma_diffuse_ratio * anet / (leaf_co2_ppress / can_press) + aquad = 1.0_r8 + bquad = -(2.0 * (stomatal_intercept_btran+ term) + (medlyn_slope(ft) * term)**2 / & + (gb_mol * vpd )) + cquad = stomatal_intercept_btran*stomatal_intercept_btran + & + (2.0*stomatal_intercept_btran + term * & + (1.0 - medlyn_slope(ft)* medlyn_slope(ft) / vpd)) * term + + call quadratic_f (aquad, bquad, cquad, r1, r2) + gs_mol = max(r1,r2) + + else if ( stomatal_model == ballberry_model ) then !stomatal conductance calculated from Ball et al. (1987) + aquad = leaf_co2_ppress + bquad = leaf_co2_ppress*(gb_mol - stomatal_intercept_btran) - bb_slope(ft) * a_gs * can_press + cquad = -gb_mol*(leaf_co2_ppress*stomatal_intercept_btran + & + bb_slope(ft)*anet*can_press * ceair/ veg_esat ) + + call quadratic_f (aquad, bquad, cquad, r1, r2) + gs_mol = max(r1,r2) + end if + + ! Derive new estimate for co2_inter_c + co2_inter_c = can_co2_ppress - anet * can_press * & + (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) + + ! Check for co2_inter_c convergence. Delta co2_inter_c/pair = mol/mol. + ! Multiply by 10**6 to convert to umol/mol (ppm). Exit iteration if + ! convergence criteria of +/- 1 x 10**-6 ppm is met OR if at least ten + ! iterations (niter=10) are completed + + if ((abs(co2_inter_c-co2_inter_c_old)/can_press*1.e06_r8 <= 2.e-06_r8) & + .or. niter == 5) then + loop_continue = .false. + end if + end do iter_loop + + ! End of co2_inter_c iteration. Check for an < 0, in which case gs_mol = bbb + ! And Final estimates for leaf_co2_ppress and co2_inter_c + ! (needed for early exit of co2_inter_c iteration when an < 0) + if (anet < 0._r8) then + gs_mol = stomatal_intercept_btran + end if + + ! Final estimates for leaf_co2_ppress and co2_inter_c + leaf_co2_ppress = can_co2_ppress - h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press + leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + co2_inter_c = can_co2_ppress - anet * can_press * & + (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) + + ! Convert gs_mol (umol /m**2/s) to gs (m/s) and then to rs (s/m) + gs = gs_mol / cf + + ! estimate carbon 13 discrimination in leaf level carbon + ! flux Liang WEI and Hang ZHOU 2018, based on + ! Ubierna and Farquhar, 2014 doi:10.1111/pce.12346, using the simplified model: + ! $\Delta ^{13} C = \alpha_s + (b - \alpha_s) \cdot \frac{C_i}{C_a}$ + ! just hard code b and \alpha_s for now, might move to parameter set in future + ! b = 27.0 alpha_s = 4.4 + ! TODO, not considering C4 or CAM right now, may need to address this + ! note co2_inter_c is intracelluar CO2, not intercelluar + c13disc_z = 4.4_r8 + (27.0_r8 - 4.4_r8) * & + min (can_co2_ppress, max (co2_inter_c, 0._r8)) / can_co2_ppress + + ! Accumulate total photosynthesis umol/m2 ground/s-1. + ! weight per unit sun and sha leaves. + if(sunsha == 1)then !sunlit + psn_out = psn_out + agross * f_sun_lsl + anet_av_out = anet_av_out + anet * f_sun_lsl + gstoma = gstoma + 1._r8/(min(1._r8/gs, rsmax0)) * f_sun_lsl + else + psn_out = psn_out + agross * (1.0_r8-f_sun_lsl) + anet_av_out = anet_av_out + anet * (1.0_r8-f_sun_lsl) + gstoma = gstoma + & + 1._r8/(min(1._r8/gs, rsmax0)) * (1.0_r8-f_sun_lsl) + end if + + ! Make sure iterative solution is correct + if (gs_mol < 0._r8) then + write (fates_log(),*)'Negative stomatal conductance:' + write (fates_log(),*)'gs_mol= ',gs_mol + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Compare with Medlyn model: gs_mol = 1.6*(1+m/sqrt(vpd)) * an/leaf_co2_ppress*p + b + if ( stomatal_model == 2 ) then + gs_mol_err = h2o_co2_stoma_diffuse_ratio*(1 + medlyn_slope(ft)/sqrt(vpd))*max(anet,0._r8)/leaf_co2_ppress*can_press + stomatal_intercept_btran + ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress*p + b + else if ( stomatal_model == 1 ) then + hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) + gs_mol_err = bb_slope(ft)*max(anet, 0._r8)*hs/leaf_co2_ppress*can_press + stomatal_intercept_btran + end if + + if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then + warn_msg = 'Stomatal conductance error check - weak convergence: '//trim(N2S(gs_mol))//' '//trim(N2S(gs_mol_err)) + call FatesWarn(warn_msg,index=1) + end if + + enddo !sunsha loop + + ! Stomatal resistance of the leaf-layer + if ( (hlm_use_planthydro.eq.itrue .and. EDPftvarcon_inst%hydr_k_lwp(ft)>nearzero) ) then + rstoma_out = LeafHumidityStomaResis(leaf_psi, veg_tempk, ceair, can_press, veg_esat, & + rb, gstoma, ft) + else + rstoma_out = 1._r8/gstoma + end if + + + else + + ! No leaf area. This layer is present only because of stems. + ! Net assimilation is zero, not negative because there are + ! no leaves to even respire + ! (leaves are off, or have reduced to 0) + + psn_out = 0._r8 + anet_av_out = 0._r8 + + rstoma_out = min(rsmax0,cf/(stem_cuticle_loss_frac*stomatal_intercept(ft))) + c13disc_z = 0.0_r8 + + end if if_leafarea !is there leaf area? + + + end if if_daytime ! night or day + + + end associate + return + end subroutine LeafLayerPhotosynthesis + + ! ======================================================================================= + + function LeafHumidityStomaResis(leaf_psi, veg_tempk, ceair, can_press, veg_esat, & + rb, gstoma, ft) result(rstoma_out) + + ! ------------------------------------------------------------------------------------- + ! This calculates inner leaf humidity as a function of mesophyll water potential + ! Adopted from Vesala et al., 2017 https://www.frontiersin.org/articles/10.3389/fpls.2017.00054/full + ! + ! Equation 1 in Vesala et al: + ! lwp_star = wi/w0 = exp( k_lwp*leaf_psi*molar_mass_water/(rgas_J_k_mol * veg_tempk) ) + ! + ! Terms: + ! leaf_psi: leaf water potential [MPa] + ! k_lwp: inner leaf humidity scaling coefficient [-] + ! rgas_J_K_mol: universal gas constant, [J/K/mol], 8.3144598 + ! molar_mass_water, molar mass of water, [g/mol]: 18.0 + ! + ! Unit conversions: + ! 1 Pa = 1 N/m2 = 1 J/m3 + ! density of liquid water [kg/m3] = 1000 + ! + ! units of equation 1: exp( [MPa]*[g/mol]/( [J/K/mol] * [K] ) ) + ! [MJ/m3]*[g/mol]*[m3/kg]*[kg/g]*[J/MJ] / ([J/mol]) + ! dimensionless: [J/g]*[g/mol]/([J/mol]) + ! + ! Note: unit conversions drop out b/c [m3/kg]*[kg/g]*[J/MJ] = 1e-3*1.e-3*1e6 = 1.0 + ! + ! Junyan Ding 2021 + ! ------------------------------------------------------------------------------------- + + ! Arguments + real(r8) :: leaf_psi ! Leaf water potential [MPa] + real(r8) :: veg_tempk ! Leaf temperature [K] + real(r8) :: ceair ! vapor pressure of air, constrained [Pa] + real(r8) :: can_press ! Atmospheric pressure of canopy [Pa] + real(r8) :: veg_esat ! Saturated vapor pressure at veg surf [Pa] + real(r8) :: rb ! Leaf Boundary layer resistance [s/m] + real(r8) :: gstoma ! Stomatal Conductance of this leaf layer [m/s] + integer :: ft ! Plant Functional Type + real(r8) :: rstoma_out ! Total Stomatal resistance (stoma and BL) [s/m] + + ! Locals + real(r8) :: k_lwp ! Scaling coefficient for the ratio of leaf xylem + ! water potential to mesophyll water potential + real(r8) :: qs ! Specific humidity [g/kg] + real(r8) :: qsat ! Saturation specific humidity [g/kg] + real(r8) :: qsat_adj ! Adjusted saturation specific humidity [g/kg] + real(r8) :: lwp_star ! leaf water potential scaling coefficient + ! for inner leaf humidity, 0 means total dehydroted + ! leaf, 1 means total saturated leaf + + ! Note: to disable this control, set k_lwp to zero, LWP_star will be 1 + k_lwp = EDPftvarcon_inst%hydr_k_lwp(ft) + if (leaf_psi<0._r8) then + lwp_star = exp(k_lwp*leaf_psi*molar_mass_water/(rgas_J_K_mol *veg_tempk)) + else + lwp_star = 1._r8 + end if + + ! compute specific humidity from vapor pressure + ! q = molar_mass_ratio_vapdry*e/(can_press - (1-molar_mass_ratio_vapdry)*e) + ! source https://cran.r-project.org/web/packages/humidity/vignettes/humidity-measures.html + ! now adjust inner leaf humidity by LWP_star + + qs = molar_mass_ratio_vapdry * ceair / (can_press - (1._r8-molar_mass_ratio_vapdry) * ceair) + qsat = molar_mass_ratio_vapdry * veg_esat / (can_press - (1._r8-molar_mass_ratio_vapdry) * veg_esat) + qsat_adj = qsat*lwp_star + + ! Adjusting gs (compute a virtual gs) that will be passed to host model + + if ( qsat_adj < qs ) then + + ! if inner leaf vapor pressure is less then or equal to that at leaf surface + ! then set stomata resistance to be very large to stop the transpiration or back flow of vapor + rstoma_out = rsmax0 + + else + + rstoma_out = (qsat-qs)*( 1/gstoma + rb)/(qsat_adj - qs)-rb + + end if + + if (rstoma_out < nearzero ) then + write (fates_log(),*) 'qsat:', qsat, 'qs:', qs + write (fates_log(),*) 'LWP :', leaf_psi + write (fates_log(),*) 'ceair:', ceair, 'veg_esat:', veg_esat + write (fates_log(),*) 'rstoma_out:', rstoma_out, 'rb:', rb + write (fates_log(),*) 'LWP_star', lwp_star + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end function LeafHumidityStomaResis + + + ! ===================================================================================== + + subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv + psn_llz, & ! in %psn_z(1:currentCohort%nv,ft,cl) + lmr_llz, & ! in lmr_z(1:currentCohort%nv,ft,cl) + rs_llz, & ! in rs_z(1:currentCohort%nv,ft,cl) + elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) + c13disc_llz, & ! in c13disc_z(cl, ft, 1:currentCohort%nv) + c_area, & ! in currentCohort%c_area + nplant, & ! in currentCohort%n + rb, & ! in bc_in(s)%rb_pa(ifp) + maintresp_reduction_factor, & ! in + g_sb_laweight, & ! out currentCohort%g_sb_laweight [m/s] [m2-leaf] + gpp, & ! out currentCohort%gpp_tstep + rdark, & ! out currentCohort%rdark + c13disc_clm, & ! out currentCohort%c13disc_clm + cohort_eleaf_area ) ! out [m2] + + ! ------------------------------------------------------------------------------------ + ! This subroutine effectively integrates leaf carbon fluxes over the + ! leaf layers to give cohort totals. + ! Some arguments have the suffix "_llz". This indicates that the vector + ! is stratefied in the leaf-layer (ll) dimension, and is a portion of the calling + ! array which has the "_z" tag, thus "llz". + ! ------------------------------------------------------------------------------------ + + use FatesConstantsMod, only : umolC_to_kgC + + ! Arguments + integer, intent(in) :: nv ! number of active leaf layers + real(r8), intent(in) :: psn_llz(nv) ! layer photosynthesis rate (GPP) [umolC/m2leaf/s] + real(r8), intent(in) :: lmr_llz(nv) ! layer dark respiration rate [umolC/m2leaf/s] + real(r8), intent(in) :: rs_llz(nv) ! leaf layer stomatal resistance [s/m] + real(r8), intent(in) :: elai_llz(nv) ! exposed LAI per layer [m2 leaf/ m2 pft footprint] + real(r8), intent(in) :: c13disc_llz(nv) ! leaf layer c13 discrimination, weighted mean + real(r8), intent(in) :: c_area ! crown area m2/m2 + real(r8), intent(in) :: nplant ! indiv/m2 + real(r8), intent(in) :: rb ! leaf boundary layer resistance (s/m) + real(r8), intent(in) :: maintresp_reduction_factor ! factor by which to reduce maintenance respiration + real(r8), intent(out) :: g_sb_laweight ! Combined conductance (stomatal + boundary layer) for the cohort + ! weighted by leaf area [m/s]*[m2] + real(r8), intent(out) :: gpp ! GPP (kgC/indiv/s) + real(r8), intent(out) :: rdark ! Dark Leaf Respiration (kgC/indiv/s) + real(r8), intent(out) :: cohort_eleaf_area ! Effective leaf area of the cohort [m2] + real(r8), intent(out) :: c13disc_clm ! unpacked Cohort level c13 discrimination + real(r8) :: sum_weight ! sum of weight for unpacking d13c flux (c13disc_z) from + ! (canopy_layer, pft, leaf_layer) matrix to cohort (c13disc_clm) + + ! GPP IN THIS SUBROUTINE IS A RATE. THE CALLING ARGUMENT IS GPP_TSTEP. AFTER THIS + ! CALL THE RATE WILL BE MULTIPLIED BY THE INTERVAL TO GIVE THE INTEGRATED QUANT. + + ! Locals + integer :: il ! leaf layer index + real(r8) :: cohort_layer_eleaf_area ! the effective leaf area of the cohort's current layer [m2] + + cohort_eleaf_area = 0.0_r8 + g_sb_laweight = 0.0_r8 + gpp = 0.0_r8 + rdark = 0.0_r8 + + do il = 1, nv ! Loop over the leaf layers this cohort participates in + + + ! Cohort's total effective leaf area in this layer [m2] + ! leaf area index of the layer [m2/m2 ground] * [m2 ground] + ! elai_llz is the LAI for the whole PFT. Multiplying this by the ground + ! area this cohort contributes, give the cohort's portion of the leaf + ! area in this layer + cohort_layer_eleaf_area = elai_llz(il) * c_area + + ! Increment the cohort's total effective leaf area [m2] + cohort_eleaf_area = cohort_eleaf_area + cohort_layer_eleaf_area + + ! Leaf conductance (stomatal and boundary layer) + ! This should be the weighted average over the leaf surfaces. + ! Since this is relevant to the stomata, its weighting should be based + ! on total leaf area, and not really footprint area + ! [m/s] * [m2 cohort's leaf layer] + g_sb_laweight = g_sb_laweight + 1.0_r8/(rs_llz(il)+rb) * cohort_layer_eleaf_area + + ! GPP [umolC/m2leaf/s] * [m2 leaf ] -> [umolC/s] + gpp = gpp + psn_llz(il) * cohort_layer_eleaf_area + + ! Dark respiration + ! [umolC/m2leaf/s] * [m2 leaf] + rdark = rdark + lmr_llz(il) * cohort_layer_eleaf_area + + end do + + + + if (nv > 1) then + ! cohort%c13disc_clm as weighted mean of d13c flux at all related leave layers + sum_weight = sum(psn_llz(1:nv-1) * elai_llz(1:nv-1)) + if (sum_weight .eq. 0.0_r8) then + c13disc_clm = 0.0 + else + c13disc_clm = sum(c13disc_llz(1:nv-1) * psn_llz(1:nv-1) * elai_llz(1:nv-1)) / sum_weight + end if + + end if + + + ! ----------------------------------------------------------------------------------- + ! We DO NOT normalize g_sb_laweight. + ! The units that we are passing back are [m/s] * [m2 effective leaf] + ! We will add these up over the whole patch, and then normalized + ! by the patch's total leaf area in the calling routine + ! ----------------------------------------------------------------------------------- + + ! ----------------------------------------------------------------------------------- + ! Convert dark respiration and GPP from [umol/s] to [kgC/plant/s] + ! Also, apply the maintenance respiration reduction factor + ! ----------------------------------------------------------------------------------- + + rdark = rdark * umolC_to_kgC * maintresp_reduction_factor / nplant + gpp = gpp * umolC_to_kgC / nplant + + if ( debug ) then + write(fates_log(),*) 'EDPhoto 816 ', gpp + write(fates_log(),*) 'EDPhoto 817 ', psn_llz(1:nv) + write(fates_log(),*) 'EDPhoto 820 ', nv + write(fates_log(),*) 'EDPhoto 821 ', elai_llz(1:nv) + write(fates_log(),*) 'EDPhoto 843 ', rdark + write(fates_log(),*) 'EDPhoto 873 ', nv + write(fates_log(),*) 'EDPhoto 874 ', cohort_eleaf_area + endif + + return + end subroutine ScaleLeafLayerFluxToCohort + + ! ===================================================================================== + + function ft1_f(tl, ha) result(ans) + ! + !!DESCRIPTION: + ! photosynthesis temperature response + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + !!USES + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + + ! + ! !ARGUMENTS: + real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) + real(r8), intent(in) :: ha ! activation energy in photosynthesis temperature function (J/mol) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- + + ans = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) + + return + end function ft1_f + + ! ===================================================================================== + + function fth_f(tl,hd,se,scaleFactor) result(ans) + ! + !!DESCRIPTION: + !photosynthesis temperature inhibition + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + + ! + ! !ARGUMENTS: + real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temp function (K) + real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) + real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) + real(r8), intent(in) :: scaleFactor ! scaling factor for high temp inhibition (25 C = 1.0) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- + + ans = scaleFactor / ( 1._r8 + exp( (-hd+se*tl) / (rgas*1.e-3_r8*tl) ) ) + + return + end function fth_f + + ! ===================================================================================== + + function fth25_f(hd,se)result(ans) + ! + !!DESCRIPTION: + ! scaling factor for photosynthesis temperature inhibition + ! + ! !REVISION HISTORY: + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + !!USES + + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + + ! + ! !ARGUMENTS: + real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) + real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- + + ans = 1._r8 + exp( (-hd+se*(tfrz+25._r8)) / (rgas*1.e-3_r8*(tfrz+25._r8)) ) + + return + end function fth25_f + + ! ===================================================================================== + + subroutine quadratic_f (a, b, c, r1, r2) + ! + ! !DESCRIPTION: + !==============================================================================! + !----------------- Solve quadratic equation for its two roots -----------------! + !==============================================================================! + ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific + ! Computing (Cambridge University Press, Cambridge), pp. 145. + ! + ! !REVISION HISTORY: + ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), intent(in) :: a,b,c ! Terms for quadratic equation + real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation + ! + ! !LOCAL VARIABLES: + real(r8) :: q ! Temporary term for quadratic solution + !------------------------------------------------------------------------------ + + if (a == 0._r8) then + write (fates_log(),*) 'Quadratic solution error: a = ',a + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if (b >= 0._r8) then + q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) + else + q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) + end if + + r1 = q / a + if (q /= 0._r8) then + r2 = c / q + else + r2 = 1.e36_r8 + end if + + end subroutine quadratic_f + + ! ==================================================================================== + + subroutine quadratic_fast (a, b, c, r1, r2) + ! + ! !DESCRIPTION: + !==============================================================================! + !----------------- Solve quadratic equation for its two roots -----------------! + ! THIS METHOD SIMPLY REMOVES THE DIV0 CHECK AND ERROR REPORTING ! + !==============================================================================! + ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific + ! Computing (Cambridge University Press, Cambridge), pp. 145. + ! + ! !REVISION HISTORY: + ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), intent(in) :: a,b,c ! Terms for quadratic equation + real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation + ! + ! !LOCAL VARIABLES: + real(r8) :: q ! Temporary term for quadratic solution + !------------------------------------------------------------------------------ + + ! if (a == 0._r8) then + ! write (fates_log(),*) 'Quadratic solution error: a = ',a + ! call endrun(msg=errMsg(sourcefile, __LINE__)) + ! end if + + if (b >= 0._r8) then + q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) + else + q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) + end if + + r1 = q / a + ! if (q /= 0._r8) then + r2 = c / q + ! else + ! r2 = 1.e36_r8 + ! end if + + end subroutine quadratic_fast + + + ! ==================================================================================== + + subroutine UpdateCanopyNCanNRadPresent(currentPatch) + + ! --------------------------------------------------------------------------------- + ! This subroutine calculates two patch level quanities: + ! currentPatch%ncan and + ! currentPatch%canopy_mask + ! + ! currentPatch%ncan(:,:) is a two dimensional array that indicates + ! the total number of leaf layers (including those that are not exposed to light) + ! in each canopy layer and for each functional type. + ! + ! currentPatch%nrad(:,:) is a two dimensional array that indicates + ! the total number of EXPOSED leaf layers, but for all intents and purposes + ! in the photosynthesis routine, this appears to be the same as %ncan... + ! + ! currentPatch%canopy_mask(:,:) has the same dimensions, is binary, and + ! indicates whether or not leaf layers are present (by evaluating the canopy area + ! profile). + ! --------------------------------------------------------------------------------- + + ! Arguments + type(fates_patch_type), target :: currentPatch + type(fates_cohort_type), pointer :: currentCohort + + ! Locals + integer :: cl ! Canopy Layer Index + integer :: ft ! Function Type Index + integer :: iv ! index of the exposed leaf layer for each canopy layer and pft + + ! Loop through the cohorts in this patch, associate each cohort with a layer and PFT + ! and use the cohort's memory of how many layer's it takes up to assign the maximum + ! of the layer/pft index it is in + ! --------------------------------------------------------------------------------- + + currentPatch%ncan(:,:) = 0 + ! redo the canopy structure algorithm to get round a + ! bug that is happening for site 125, FT13. + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + + currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft) = & + max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft), & + currentCohort%NV) + + currentCohort => currentCohort%shorter + + enddo !cohort + + ! NRAD = NCAN ... + currentPatch%nrad = currentPatch%ncan + + ! Now loop through and identify which layer and pft combo has scattering elements + do cl = 1,nclmax + do ft = 1,numpft + currentPatch%canopy_mask(cl,ft) = 0 + do iv = 1, currentPatch%nrad(cl,ft); + if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then + currentPatch%canopy_mask(cl,ft) = 1 + end if + end do !iv + enddo !ft + enddo !cl + + return + end subroutine UpdateCanopyNCanNRadPresent + + ! ==================================================================================== + + subroutine GetCanopyGasParameters(can_press, & + can_o2_partialpress, & + veg_tempk, & + air_tempk, & + air_vpress, & + veg_esat, & + rb, & + mm_kco2, & + mm_ko2, & + co2_cpoint, & + cf, & + gb_mol, & + ceair) + + ! --------------------------------------------------------------------------------- + ! This subroutine calculates the specific Michaelis Menten Parameters (pa) for CO2 + ! and O2, as well as the CO2 compentation point. + ! --------------------------------------------------------------------------------- + + use FatesConstantsMod, only: umol_per_mol + use FatesConstantsMod, only: mmol_per_mol + use FatesConstantsMod, only: umol_per_kmol + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + + ! Arguments + real(r8), intent(in) :: can_press ! Air pressure within the canopy (Pa) + real(r8), intent(in) :: can_o2_partialpress ! Partial press of o2 in the canopy (Pa) + real(r8), intent(in) :: veg_tempk ! The temperature of the vegetation (K) + real(r8), intent(in) :: air_tempk ! Temperature of canopy air (K) + real(r8), intent(in) :: air_vpress ! Vapor pressure of canopy air (Pa) + real(r8), intent(in) :: veg_esat ! Saturated vapor pressure at veg surf (Pa) + real(r8), intent(in) :: rb ! Leaf Boundary layer resistance (s/m) + + real(r8), intent(out) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) + real(r8), intent(out) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) + real(r8), intent(out) :: co2_cpoint ! CO2 compensation point (Pa) + real(r8), intent(out) :: cf ! conversion factor between molar form and velocity form + ! of conductance and resistance: [umol/m3] + real(r8), intent(out) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), intent(out) :: ceair ! vapor pressure of air, constrained (Pa) + + ! Locals + real(r8) :: kc25 ! Michaelis-Menten constant for CO2 at 25C (Pa) + real(r8) :: ko25 ! Michaelis-Menten constant for O2 at 25C (Pa) + real(r8) :: sco ! relative specificity of rubisco + real(r8) :: cp25 ! CO2 compensation point at 25C (Pa) + + ! --------------------------------------------------------------------------------- + ! Intensive values (per mol of air) + ! kc, ko, currentPatch, from: Bernacchi et al (2001) + ! Plant, Cell and Environment 24:253-259 + ! --------------------------------------------------------------------------------- + + real(r8), parameter :: mm_kc25_umol_per_mol = 404.9_r8 + real(r8), parameter :: mm_ko25_mmol_per_mol = 278.4_r8 + real(r8), parameter :: co2_cpoint_umol_per_mol = 42.75_r8 + + ! Activation energy, from: + ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 + ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 + + real(r8), parameter :: kcha = 79430._r8 ! activation energy for kc (J/mol) + real(r8), parameter :: koha = 36380._r8 ! activation energy for ko (J/mol) + real(r8), parameter :: cpha = 37830._r8 ! activation energy for cp (J/mol) + + + ! Derive sco from currentPatch and O2 using present-day O2 (0.209 mol/mol) and re-calculate + ! currentPatch to account for variation in O2 using currentPatch = 0.5 O2 / sco + + ! FIXME (RGK 11-30-2016 THere are more constants here, but I don't have enough information + ! about what they are or do, so I can't give them more descriptive names. Someone please + ! fill this in when possible) + + kc25 = ( mm_kc25_umol_per_mol / umol_per_mol ) * can_press + ko25 = ( mm_ko25_mmol_per_mol / mmol_per_mol ) * can_press + sco = 0.5_r8 * 0.209_r8 / (co2_cpoint_umol_per_mol / umol_per_mol ) + cp25 = 0.5_r8 * can_o2_partialpress / sco + + if( veg_tempk.gt.150_r8 .and. veg_tempk.lt.350_r8 )then + mm_kco2 = kc25 * ft1_f(veg_tempk, kcha) + mm_ko2 = ko25 * ft1_f(veg_tempk, koha) + co2_cpoint = cp25 * ft1_f(veg_tempk, cpha) + else + mm_kco2 = 1.0_r8 + mm_ko2 = 1.0_r8 + co2_cpoint = 1.0_r8 + end if + + ! --------------------------------------------------------------------------------- + ! + ! cf is the conversion factor between molar form and velocity form + ! of conductance and resistance: [umol/m3] + ! + ! i.e. + ! [m/s] * [umol/m3] -> [umol/m2/s] + ! + ! Breakdown of the conversion factor: [ umol / m3 ] + ! + ! Rgas [J /K /kmol] + ! Air Potential Temperature [ K ] + ! Canopy Pressure [ Pa ] + ! conversion: umol/kmol = 1e9 + ! + ! [ Pa * K * kmol umol/kmol / J K ] = [ Pa * umol / J ] + ! since: 1 Pa = 1 N / m2 + ! [ Pa * umol / J ] = [ N * umol / J m2 ] + ! since: 1 J = 1 N * m + ! [ N * umol / J m2 ] = [ N * umol / N m3 ] + ! [ umol / m3 ] + ! + ! -------------------------------------------------------------------------------- + + cf = can_press/(rgas * air_tempk )*umol_per_kmol + gb_mol = (1._r8/ rb) * cf + + ! Constrain eair >= 0.05*esat_tv so that solution does not blow up. This ensures + ! that hs does not go to zero. Also eair <= veg_esat so that hs <= 1 + ceair = min( max(air_vpress, 0.05_r8*veg_esat ),veg_esat ) + + + + return + end subroutine GetCanopyGasParameters + + ! ==================================================================================== + + subroutine LeafLayerMaintenanceRespiration_Ryan_1991(lnc_top, & + nscaler, & + ft, & + veg_tempk, & + lmr) + + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + use FatesConstantsMod, only : umolC_to_kgC + use FatesConstantsMod, only : g_per_kg + use EDPftvarcon , only : EDPftvarcon_inst + + ! ----------------------------------------------------------------------- + ! Base maintenance respiration rate for plant tissues maintresp_leaf_ryan1991_baserate + ! M. Ryan, 1991. Effects of climate change on plant respiration. + ! Ecological Applications, 1(2), 157-167. + ! Original expression is br = 0.0106 molC/(molN h) + ! Conversion by molecular weights of C and N gives 2.525e-6 gC/(gN s) + ! Which is the default value of maintresp_nonleaf_baserate + + ! Arguments + real(r8), intent(in) :: lnc_top ! Leaf nitrogen content per unit area at canopy top [gN/m2] + real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8) :: veg_tempk ! vegetation temperature + real(r8), intent(out) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) + + ! Locals + real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + real(r8) :: lmr25top ! canopy top leaf maint resp rate at 25C for this pft (umol CO2/m**2/s) + integer :: c3c4_path_index ! Index for which photosynthetic pathway + + ! Parameter + real(r8), parameter :: lmrha = 46390._r8 ! activation energy for lmr (J/mol) + real(r8), parameter :: lmrhd = 150650._r8 ! deactivation energy for lmr (J/mol) + real(r8), parameter :: lmrse = 490._r8 ! entropy term for lmr (J/mol/K) + real(r8), parameter :: lmrc = 1.15912391_r8 ! scaling factor for high + ! temperature inhibition (25 C = 1.0) + + !veg_tempk = 27._r8+271._r8 + + lmr25top = EDPftvarcon_inst%maintresp_leaf_ryan1991_baserate(ft) * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) + lmr25top = lmr25top * lnc_top / (umolC_to_kgC * g_per_kg) + + + ! Part I: Leaf Maintenance respiration: umol CO2 / m**2 [leaf] / s + ! ---------------------------------------------------------------------------------- + lmr25 = lmr25top * nscaler + + ! photosynthetic pathway: 0. = c4, 1. = c3 + c3c4_path_index = nint(EDPftvarcon_inst%c3psn(ft)) + + if (c3c4_path_index == c3_path_index) then + ! temperature sensitivity of C3 plants + lmr = lmr25 * ft1_f(veg_tempk, lmrha) * & + fth_f(veg_tempk, lmrhd, lmrse, lmrc) + else + ! temperature sensitivity of C4 plants + lmr = lmr25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) + lmr = lmr / (1._r8 + exp( 1.3_r8*(veg_tempk-(tfrz+55._r8)) )) + endif + + ! Any hydrodynamic limitations could go here, currently none + ! lmr = lmr * (nothing) + + end subroutine LeafLayerMaintenanceRespiration_Ryan_1991 + + ! ==================================================================================== + + subroutine LeafLayerMaintenanceRespiration_Atkin_etal_2017(lnc_top, & + nscaler, & + ft, & + veg_tempk, & + tgrowth, & + lmr) + + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + use FatesConstantsMod, only : umolC_to_kgC + use FatesConstantsMod, only : g_per_kg + use FatesConstantsMod, only : lmr_b + use FatesConstantsMod, only : lmr_c + use FatesConstantsMod, only : lmr_TrefC + use FatesConstantsMod, only : lmr_r_1 + use FatesConstantsMod, only : lmr_r_2 + use EDPftvarcon , only : EDPftvarcon_inst + + ! Arguments + real(r8), intent(in) :: lnc_top ! Leaf nitrogen content per unit area at canopy top [gN/m2] + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile + real(r8), intent(in) :: veg_tempk ! vegetation temperature (degrees K) + real(r8), intent(in) :: tgrowth ! lagged vegetation temperature averaged over acclimation timescale (degrees K) + real(r8), intent(out) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) + + ! Locals + real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + real(r8) :: r_0 ! base respiration rate, PFT-dependent (umol CO2/m**2/s) + real(r8) :: r_t_ref ! acclimated ref respiration rate (umol CO2/m**2/s) + real(r8) :: lmr25top ! canopy top leaf maint resp rate at 25C for this pft (umol CO2/m**2/s) + + ! parameter values of r_0 as listed in Atkin et al 2017: (umol CO2/m**2/s) + ! Broad-leaved trees 1.7560 + ! Needle-leaf trees 1.4995 + ! Shrubs 2.0749 + ! C3 herbs/grasses 2.1956 + ! In the absence of better information, we use the same value for C4 grasses as C3 grasses. + + ! note that this code uses the relationship between leaf N and respiration from Atkin et al + ! for the top of the canopy, but then assumes proportionality with N through the canopy. + + ! r_0 currently put into the EDPftvarcon_inst%dev_arbitrary_pft + ! all figs in Atkin et al 2017 stop at zero Celsius so we will assume acclimation is fixed below that + r_0 = EDPftvarcon_inst%maintresp_leaf_atkin2017_baserate(ft) + r_t_ref = max( 0._r8, nscaler * (r_0 + lmr_r_1 * lnc_top + lmr_r_2 * max(0._r8, (tgrowth - tfrz) )) ) + + if (r_t_ref .eq. 0._r8) then + warn_msg = 'Rdark is negative at this temperature and is capped at 0. tgrowth (C): '//trim(N2S(tgrowth-tfrz))//' pft: '//trim(I2S(ft)) + call FatesWarn(warn_msg,index=4) + end if + + lmr = r_t_ref * exp(lmr_b * (veg_tempk - tfrz - lmr_TrefC) + lmr_c * & + ((veg_tempk-tfrz)**2 - lmr_TrefC**2)) + + end subroutine LeafLayerMaintenanceRespiration_Atkin_etal_2017 + + ! ==================================================================================== + + subroutine LeafLayerBiophysicalRates( parsun_per_la, & + ft, & + vcmax25top_ft, & + jmax25top_ft, & + co2_rcurve_islope25top_ft, & + nscaler, & + veg_tempk, & + t_growth, & + t_home, & + btran, & + vcmax, & + jmax, & + co2_rcurve_islope ) + + ! --------------------------------------------------------------------------------- + ! This subroutine calculates the localized rates of several key photosynthesis + ! rates. By localized, we mean specific to the plant type and leaf layer, + ! which factors in leaf physiology, as well as environmental effects. + ! This procedure should be called prior to iterative solvers, and should + ! have pre-calculated the reference rates for the pfts before this. + ! + ! The output biophysical rates are: + ! vcmax: maximum rate of carboxilation, + ! jmax: maximum electron transport rate, + ! co2_rcurve_islope: initial slope of CO2 response curve (C4 plants) + ! --------------------------------------------------------------------------------- + + use EDPftvarcon , only : EDPftvarcon_inst + + ! Arguments + ! ------------------------------------------------------------------------------ + + real(r8), intent(in) :: parsun_per_la ! PAR absorbed per sunlit leaves for this layer + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile + real(r8), intent(in) :: vcmax25top_ft ! canopy top maximum rate of carboxylation at 25C + ! for this pft (umol CO2/m**2/s) + real(r8), intent(in) :: jmax25top_ft ! canopy top maximum electron transport rate at 25C + ! for this pft (umol electrons/m**2/s) + real(r8), intent(in) :: co2_rcurve_islope25top_ft ! initial slope of CO2 response curve + ! (C4 plants) at 25C, canopy top, this pft + real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8), intent(in) :: t_growth ! T_growth (short-term running mean temperature) (K) + real(r8), intent(in) :: t_home ! T_home (long-term running mean temperature) (K) + real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) + + real(r8), intent(out) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) + real(r8), intent(out) :: jmax ! maximum electron transport rate + ! (umol electrons/m**2/s) + real(r8), intent(out) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) + + ! Locals + ! ------------------------------------------------------------------------------- + real(r8) :: vcmax25 ! leaf layer: maximum rate of carboxylation at 25C + ! (umol CO2/m**2/s) + real(r8) :: jmax25 ! leaf layer: maximum electron transport rate at 25C + ! (umol electrons/m**2/s) + real(r8) :: co2_rcurve_islope25 ! leaf layer: Initial slope of CO2 response curve + ! (C4 plants) at 25C + integer :: c3c4_path_index ! Index for which photosynthetic pathway + + ! Parameters + ! --------------------------------------------------------------------------------- + real(r8) :: vcmaxha ! activation energy for vcmax (J/mol) + real(r8) :: jmaxha ! activation energy for jmax (J/mol) + real(r8) :: vcmaxhd ! deactivation energy for vcmax (J/mol) + real(r8) :: jmaxhd ! deactivation energy for jmax (J/mol) + real(r8) :: vcmaxse ! entropy term for vcmax (J/mol/K) + real(r8) :: jmaxse ! entropy term for jmax (J/mol/K) + real(r8) :: t_growth_celsius ! average growing temperature + real(r8) :: t_home_celsius ! average home temperature + real(r8) :: jvr ! ratio of Jmax25 / Vcmax25 + real(r8) :: vcmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8) :: jmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) + + select case(photo_tempsens_model) + case (photosynth_acclim_model_none) !No temperature acclimation + vcmaxha = EDPftvarcon_inst%vcmaxha(FT) + jmaxha = EDPftvarcon_inst%jmaxha(FT) + vcmaxhd = EDPftvarcon_inst%vcmaxhd(FT) + jmaxhd = EDPftvarcon_inst%jmaxhd(FT) + vcmaxse = EDPftvarcon_inst%vcmaxse(FT) + jmaxse = EDPftvarcon_inst%jmaxse(FT) + case (photosynth_acclim_model_kumarathunge_etal_2019) !Kumarathunge et al. temperature acclimation, Thome=30-year running mean + t_growth_celsius = t_growth-tfrz + t_home_celsius = t_home-tfrz + vcmaxha = (42.6_r8 + (1.14_r8*t_growth_celsius))*1e3_r8 !J/mol + jmaxha = 40.71_r8*1e3_r8 !J/mol + vcmaxhd = 200._r8*1e3_r8 !J/mol + jmaxhd = 200._r8*1e3_r8 !J/mol + vcmaxse = (645.13_r8 - (0.38_r8*t_growth_celsius)) + jmaxse = 658.77_r8 - (0.84_r8*t_home_celsius) - 0.52_r8*(t_growth_celsius-t_home_celsius) + jvr = 2.56_r8 - (0.0375_r8*t_home_celsius)-(0.0202_r8*(t_growth_celsius-t_home_celsius)) + case default + write (fates_log(),*)'error, incorrect leaf photosynthesis temperature acclimation model specified' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + vcmaxc = fth25_f(vcmaxhd, vcmaxse) + jmaxc = fth25_f(jmaxhd, jmaxse) + + !!if ( parsun_per_la <= nearzero) then ! night time [preserve_b4b] + if(parsun_per_la <= 0._r8) then + vcmax = 0._r8 + jmax = 0._r8 + co2_rcurve_islope = 0._r8 + else ! day time + + ! Vcmax25top was already calculated to derive the nscaler function + vcmax25 = vcmax25top_ft * nscaler + select case(photo_tempsens_model) + case (photosynth_acclim_model_none) + jmax25 = jmax25top_ft * nscaler + case (photosynth_acclim_model_kumarathunge_etal_2019) + jmax25 = vcmax25*jvr + case default + write (fates_log(),*)'error, incorrect leaf photosynthesis temperature acclimation model specified' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + co2_rcurve_islope25 = co2_rcurve_islope25top_ft * nscaler + + ! Adjust for temperature + ! photosynthetic pathway: 0. = c4, 1. = c3 + c3c4_path_index = nint(EDPftvarcon_inst%c3psn(ft)) + + if (c3c4_path_index == c3_path_index) then + vcmax = vcmax25 * ft1_f(veg_tempk, vcmaxha) * fth_f(veg_tempk, vcmaxhd, vcmaxse, vcmaxc) + else + vcmax = vcmax25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) + vcmax = vcmax / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-veg_tempk ) )) + vcmax = vcmax / (1._r8 + exp( 0.3_r8*(veg_tempk-(tfrz+40._r8)) )) + end if + + jmax = jmax25 * ft1_f(veg_tempk, jmaxha) * fth_f(veg_tempk, jmaxhd, jmaxse, jmaxc) + + !q10 response of product limited psn. + co2_rcurve_islope = co2_rcurve_islope25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) + end if + + ! Adjust for water limitations + vcmax = vcmax * btran + + return + + end subroutine LeafLayerBiophysicalRates + + subroutine lowstorage_maintresp_reduction(frac, pft, maintresp_reduction_factor) + + ! This subroutine reduces maintenance respiration rates when storage pool is low. The premise + ! of this is that mortality of plants increases when storage is low because they are not able + ! to repair tissues, generate defense compounds, etc. This reduction is reflected in a reduced + ! maintenance demand. The output of this function takes the form of a curve between 0 and 1, + ! and the curvature of the function is determined by a parameter. + + ! Uses + use EDPftvarcon , only : EDPftvarcon_inst + + ! Arguments + ! ------------------------------------------------------------------------------ + real(r8), intent(in) :: frac ! ratio of storage to target leaf biomass + integer, intent(in) :: pft ! what pft is this cohort? + real(r8), intent(out) :: maintresp_reduction_factor ! the factor by which to reduce maintenance respiration + + ! -------------------------------------------------------------------------------- + ! Parameters are at the PFT level: + ! fates_maintresp_reduction_curvature controls the curvature of this. + ! If this parameter is zero, then there is no reduction until the plant dies at storage = 0. + ! If this parameter is one, then there is a linear reduction in respiration below the storage point. + ! Intermediate values will give some (concave-downwards) curvature. + ! + ! maintresp_reduction_intercept controls the maximum amount of throttling. + ! zero means no throttling at any point, so it turns this mechanism off completely and so + ! allows an entire cohort to die via negative carbon-induced termination mortality. + ! one means complete throttling, so no maintenance respiration at all, when out of carbon. + ! --------------------------------------------------------------------------------- + + if( frac .lt. 1._r8 )then + if ( abs(EDPftvarcon_inst%maintresp_reduction_curvature(pft)-1._r8) > nearzero ) then + maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & + EDPftvarcon_inst%maintresp_reduction_intercept(pft) * & + (1._r8 - EDPftvarcon_inst%maintresp_reduction_curvature(pft)**frac) & + / (1._r8-EDPftvarcon_inst%maintresp_reduction_curvature(pft)) + else ! avoid nan answer for linear case + maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & + EDPftvarcon_inst%maintresp_reduction_intercept(pft) * frac + endif + + else + maintresp_reduction_factor = 1._r8 + endif + + + end subroutine lowstorage_maintresp_reduction end module FATESPlantRespPhotosynthMod From a3754a1825fb6fe3f27475e03ede4806eabf9b6d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 13 Dec 2023 12:40:10 -0500 Subject: [PATCH 218/250] Reverted history code to be as similar to base as possible --- main/FatesHistoryInterfaceMod.F90 | 106 +++--------------------------- 1 file changed, 8 insertions(+), 98 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 95b7530ef3..9fb901d5c1 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -678,18 +678,12 @@ module FatesHistoryInterfaceMod ! indices to (site x [canopy layer x leaf layer]) variables integer :: ih_parsun_z_si_cnlf integer :: ih_parsha_z_si_cnlf - integer :: ih_laisun_z_si_cnlf - integer :: ih_laisha_z_si_cnlf integer :: ih_ts_net_uptake_si_cnlf integer :: ih_crownarea_si_cnlf - integer :: ih_parprof_dir_si_cnlf - integer :: ih_parprof_dif_si_cnlf ! indices to (site x [canopy layer x leaf layer x pft]) variables integer :: ih_parsun_z_si_cnlfpft integer :: ih_parsha_z_si_cnlfpft - integer :: ih_laisun_z_si_cnlfpft - integer :: ih_laisha_z_si_cnlfpft integer :: ih_parprof_dir_si_cnlfpft integer :: ih_parprof_dif_si_cnlfpft @@ -719,8 +713,6 @@ module FatesHistoryInterfaceMod ! indices to (site x canopy layer) variables integer :: ih_parsun_top_si_can integer :: ih_parsha_top_si_can - integer :: ih_laisun_top_si_can - integer :: ih_laisha_top_si_can integer :: ih_crownarea_si_can ! indices to (patch age x fuel size class) variables @@ -4375,7 +4367,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) return end subroutine update_history_dyn - subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,dt_tstep) + subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) ! ! Arguments class(fates_history_interface_type) :: this @@ -4383,6 +4375,7 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,dt_tstep) integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) type(bc_in_type) , intent(in) :: bc_in(nsites) + type(bc_out_type) , intent(in) :: bc_out(nsites) real(r8) , intent(in) :: dt_tstep ! This is just a dummy file for compatibility @@ -4391,7 +4384,7 @@ subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,dt_tstep) end subroutine update_history_hifrq_multi - subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,dt_tstep) + subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) ! --------------------------------------------------------------------------------- ! This is the call to update the history IO arrays that are expected to only change @@ -4406,6 +4399,7 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,dt_tstep) integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) type(bc_in_type) , intent(in) :: bc_in(nsites) + type(bc_out_type) , intent(in) :: bc_out(nsites) real(r8) , intent(in) :: dt_tstep ! Locals @@ -4428,7 +4422,8 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,dt_tstep) type(fates_patch_type),pointer :: cpatch type(fates_cohort_type),pointer :: ccohort real(r8) :: per_dt_tstep ! Time step in frequency units (/s) - + real(r8) :: clllpf_area + associate( hio_gpp_si => this%hvars(ih_gpp_si)%r81d, & hio_gpp_secondary_si => this%hvars(ih_gpp_secondary_si)%r81d, & hio_npp_si => this%hvars(ih_npp_si)%r81d, & @@ -4480,14 +4475,6 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,dt_tstep) hio_ts_net_uptake_si_cnlf => this%hvars(ih_ts_net_uptake_si_cnlf)%r82d, & hio_parsun_z_si_cnlfpft => this%hvars(ih_parsun_z_si_cnlfpft)%r82d, & hio_parsha_z_si_cnlfpft => this%hvars(ih_parsha_z_si_cnlfpft)%r82d, & - hio_laisun_z_si_cnlf => this%hvars(ih_laisun_z_si_cnlf)%r82d, & - hio_laisha_z_si_cnlf => this%hvars(ih_laisha_z_si_cnlf)%r82d, & - hio_laisun_z_si_cnlfpft => this%hvars(ih_laisun_z_si_cnlfpft)%r82d, & - hio_laisha_z_si_cnlfpft => this%hvars(ih_laisha_z_si_cnlfpft)%r82d, & - hio_laisun_top_si_can => this%hvars(ih_laisun_top_si_can)%r82d, & - hio_laisha_top_si_can => this%hvars(ih_laisha_top_si_can)%r82d, & - hio_parprof_dir_si_cnlf => this%hvars(ih_parprof_dir_si_cnlf)%r82d, & - hio_parprof_dif_si_cnlf => this%hvars(ih_parprof_dif_si_cnlf)%r82d, & hio_parprof_dir_si_cnlfpft => this%hvars(ih_parprof_dir_si_cnlfpft)%r82d, & hio_parprof_dif_si_cnlfpft => this%hvars(ih_parprof_dif_si_cnlfpft)%r82d, & hio_parsun_top_si_can => this%hvars(ih_parsun_top_si_can)%r82d, & @@ -4722,6 +4709,8 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,dt_tstep) ! calculate where we are on multiplexed dimensions cnlfpft_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax cnlf_indx = ileaf + (ican-1) * nlevleaf + + clllpf_area = cpatch%canopy_area_profile(ican,ipft,ileaf)*cpatch%total_canopy_area ! ! first do all the canopy x leaf x pft calculations hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) + & @@ -4729,12 +4718,6 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,dt_tstep) hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) + & cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV ! - hio_laisun_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_laisun_z_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_laisha_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_laisha_z_si_cnlfpft(io_si,cnlfpft_indx) + & - cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - - ! hio_parprof_dir_si_cnlfpft(io_si,cnlfpft_indx) = hio_parprof_dir_si_cnlfpft(io_si,cnlfpft_indx) + & cpatch%parprof_pft_dir_z(ican,ipft,ileaf) * cpatch%area * AREA_INV hio_parprof_dif_si_cnlfpft(io_si,cnlfpft_indx) = hio_parprof_dif_si_cnlfpft(io_si,cnlfpft_indx) + & @@ -4745,12 +4728,6 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,dt_tstep) cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV hio_parsha_z_si_cnlf(io_si,cnlf_indx) = hio_parsha_z_si_cnlf(io_si,cnlf_indx) + & cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - ! - hio_laisun_z_si_cnlf(io_si,cnlf_indx) = hio_laisun_z_si_cnlf(io_si,cnlf_indx) + & - cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - hio_laisha_z_si_cnlf(io_si,cnlf_indx) = hio_laisha_z_si_cnlf(io_si,cnlf_indx) + & - cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV - ! end do ! @@ -4759,28 +4736,9 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,dt_tstep) cpatch%ed_parsun_z(ican,ipft,1) * cpatch%area * AREA_INV hio_parsha_top_si_can(io_si,ican) = hio_parsha_top_si_can(io_si,ican) + & cpatch%ed_parsha_z(ican,ipft,1) * cpatch%area * AREA_INV - ! - hio_laisun_top_si_can(io_si,ican) = hio_laisun_top_si_can(io_si,ican) + & - cpatch%ed_laisun_z(ican,ipft,1) * cpatch%area * AREA_INV - hio_laisha_top_si_can(io_si,ican) = hio_laisha_top_si_can(io_si,ican) + & - cpatch%ed_laisha_z(ican,ipft,1) * cpatch%area * AREA_INV - ! - ! - end do - end do - - ! PFT-mean radiation profiles - do ican = 1, cpatch%ncl_p - do ileaf = 1, maxval(cpatch%nrad(ican,:)) - ! calculate where we are on multiplexed dimensions - cnlf_indx = ileaf + (ican-1) * nlevleaf ! - hio_parprof_dir_si_cnlf(io_si,cnlf_indx) = hio_parprof_dir_si_cnlf(io_si,cnlf_indx) + & - cpatch%parprof_dir_z(ican,ileaf) * cpatch%area * AREA_INV - hio_parprof_dif_si_cnlf(io_si,cnlf_indx) = hio_parprof_dif_si_cnlf(io_si,cnlf_indx) + & - cpatch%parprof_dif_z(ican,ileaf) * cpatch%area * AREA_INV end do end do @@ -6595,42 +6553,6 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_parsha_top_si_can) - call this%set_history_var(vname='FATES_LAISUN_Z_CLLL', units='m2 m-2', & - long='LAI in the sun by each canopy and leaf layer', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_laisun_z_si_cnlf) - - call this%set_history_var(vname='FATES_LAISHA_Z_CLLL', units='m2 m-2', & - long='LAI in the shade by each canopy and leaf layer', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_laisha_z_si_cnlf) - - call this%set_history_var(vname='FATES_LAISUN_Z_CLLLPF', units='m2 m-2', & - long='LAI in the sun by each canopy, leaf, and PFT', & - use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_laisun_z_si_cnlfpft) - - call this%set_history_var(vname='FATES_LAISHA_Z_CLLLPF', units='m2 m-2', & - long='LAI in the shade by each canopy, leaf, and PFT', & - use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_laisha_z_si_cnlfpft) - - call this%set_history_var(vname='FATES_LAISUN_TOP_CL', units='m2 m-2', & - long='LAI in the sun by the top leaf layer of each canopy layer', & - use_default='inactive', avgflag='A', vtype=site_can_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_laisun_top_si_can) - - call this%set_history_var(vname='FATES_LAISHA_TOP_CL', units='m2 m-2', & - long='LAI in the shade by the top leaf layer of each canopy layer', & - use_default='inactive', avgflag='A', vtype=site_can_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_laisha_top_si_can) - call this%set_history_var(vname='FATES_PARPROF_DIR_CLLLPF', units='W m-2', & long='radiative profile of direct PAR through each canopy, leaf, and PFT', & use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & @@ -6643,18 +6565,6 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_parprof_dif_si_cnlfpft) - call this%set_history_var(vname='FATES_PARPROF_DIR_CLLL', units='W m-2', & - long='radiative profile of direct PAR through each canopy and leaf layer (averaged across PFTs)', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_parprof_dir_si_cnlf) - - call this%set_history_var(vname='FATES_PARPROF_DIF_CLLL', units='W m-2', & - long='radiative profile of diffuse PAR through each canopy and leaf layer (averaged across PFTs)', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_parprof_dif_si_cnlf) - !!! canopy-resolved fluxes and structure call this%set_history_var(vname='FATES_NET_C_UPTAKE_CLLL', & From a972ff3f6803b8e8ef273861dcb75b6cec0d4bcb Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 14 Dec 2023 08:41:25 -0700 Subject: [PATCH 219/250] more two-stream b4b work --- biogeochem/EDCanopyStructureMod.F90 | 155 +++++++++++++++++++++++----- main/EDInitMod.F90 | 4 +- 2 files changed, 130 insertions(+), 29 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 46b219e583..0687b15af7 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -84,6 +84,7 @@ module EDCanopyStructureMod real(r8), parameter :: similar_height_tol = 1.0E-3_r8 ! I think trees that differ by 1mm ! can be roughly considered the same right? + logical, parameter :: preserve_b4b = .true. ! 10/30/09: Created by Rosie Fisher ! 2017/2018: Modifications and updates by Ryan Knox @@ -1532,6 +1533,7 @@ subroutine leaf_area_profile( currentSite ) real(r8) :: esai_layer,tsai_layer ! stem area per canopy area real(r8) :: vai_top,vai_bot ! integrated top down veg area index at boundary of layer + real(r8) :: layer_bottom_height,layer_top_height,lai,sai ! Can be removed later !---------------------------------------------------------------------- @@ -1579,35 +1581,134 @@ subroutine leaf_area_profile( currentSite ) do while(associated(currentCohort)) ft = currentCohort%pft cl = currentCohort%canopy_layer - - do iv = 1,currentCohort%NV - - call VegAreaLayer(currentCohort%treelai, & - currentCohort%treesai, & - currentCohort%height, & - iv,currentCohort%nv,currentCohort%pft, & - currentSite%snow_depth, & - vai_top,vai_bot, & - elai_layer,esai_layer,tlai_layer,tsai_layer) - - - currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) + & - tlai_layer * currentCohort%c_area/currentPatch%total_canopy_area - currentPatch%elai_profile(cl,ft,iv) = currentPatch%elai_profile(cl,ft,iv) + & - elai_layer * currentCohort%c_area/currentPatch%total_canopy_area - - currentPatch%tsai_profile(cl,ft,iv) = currentPatch%tsai_profile(cl,ft,iv) + & - tsai_layer * currentCohort%c_area/currentPatch%total_canopy_area + ! ---------------------------------------------------------------- + ! How much of each tree is stem area index? Assuming that there is + ! This may indeed be zero if there is a sensecent grass + ! ---------------------------------------------------------------- + if_preserve_b4b: if(preserve_b4b) then + lai = currentCohort%treelai * currentCohort%c_area/currentPatch%total_canopy_area + sai = currentCohort%treesai * currentCohort%c_area/currentPatch%total_canopy_area + if( (currentCohort%treelai+currentCohort%treesai) > nearzero)then + + ! See issue: https://github.com/NGEET/fates/issues/899 + ! fleaf = currentCohort%treelai / (currentCohort%treelai + currentCohort%treesai) + fleaf = lai / (lai+sai) + else + fleaf = 0._r8 + endif - currentPatch%esai_profile(cl,ft,iv) = currentPatch%esai_profile(cl,ft,iv) + & - esai_layer * currentCohort%c_area/currentPatch%total_canopy_area - - currentPatch%canopy_area_profile(cl,ft,iv) = currentPatch%canopy_area_profile(cl,ft,iv) + & - currentCohort%c_area/currentPatch%total_canopy_area - - end do - + currentPatch%nrad(cl,ft) = currentPatch%ncan(cl,ft) + + if (currentPatch%nrad(cl,ft) > nlevleaf ) then + write(fates_log(), *) 'Number of radiative leaf layers is larger' + write(fates_log(), *) ' than the maximum allowed.' + write(fates_log(), *) ' cl: ',cl + write(fates_log(), *) ' ft: ',ft + write(fates_log(), *) ' nlevleaf: ',nlevleaf + write(fates_log(), *) ' currentPatch%nrad(cl,ft): ', currentPatch%nrad(cl,ft) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! -------------------------------------------------------------------------- + ! Whole layers. Make a weighted average of the leaf area in each layer + ! before dividing it by the total area. Fill up layer for whole layers. + ! -------------------------------------------------------------------------- + + do iv = 1,currentCohort%NV + + ! This loop builds the arrays that define the effective (not snow covered) + ! and total (includes snow covered) area indices for leaves and stems + ! We calculate the absolute elevation of each layer to help determine if the layer + ! is obscured by snow. + + layer_top_height = currentCohort%height - & + ( real(iv-1,r8)/currentCohort%NV * currentCohort%height * & + prt_params%crown_depth_frac(currentCohort%pft) ) + + layer_bottom_height = currentCohort%height - & + ( real(iv,r8)/currentCohort%NV * currentCohort%height * & + prt_params%crown_depth_frac(currentCohort%pft) ) + + fraction_exposed = 1.0_r8 + if(currentSite%snow_depth > layer_top_height)then + fraction_exposed = 0._r8 + endif + if(currentSite%snow_depth < layer_bottom_height)then + fraction_exposed = 1._r8 + endif + if(currentSite%snow_depth >= layer_bottom_height .and. & + currentSite%snow_depth <= layer_top_height) then !only partly hidden... + fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(currentSite%snow_depth -layer_bottom_height)/ & + (layer_top_height-layer_bottom_height )))) + endif + + if(iv==currentCohort%NV) then + remainder = (currentCohort%treelai + currentCohort%treesai) - & + (dlower_vai(iv) - dinc_vai(iv)) + if(remainder > dinc_vai(iv) )then + write(fates_log(), *)'ED: issue with remainder', & + currentCohort%treelai,currentCohort%treesai,dinc_vai(iv), & + currentCohort%NV,remainder + + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + else + remainder = dinc_vai(iv) + end if + + currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) + & + remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area + + currentPatch%elai_profile(cl,ft,iv) = currentPatch%elai_profile(cl,ft,iv) + & + remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & + fraction_exposed + + currentPatch%tsai_profile(cl,ft,iv) = currentPatch%tsai_profile(cl,ft,iv) + & + remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area + + currentPatch%esai_profile(cl,ft,iv) = currentPatch%esai_profile(cl,ft,iv) + & + remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area * & + fraction_exposed + + currentPatch%canopy_area_profile(cl,ft,iv) = currentPatch%canopy_area_profile(cl,ft,iv) + & + currentCohort%c_area/currentPatch%total_canopy_area + + + end do + + else !if_preserve_b4b + + do iv = 1,currentCohort%NV + + call VegAreaLayer(currentCohort%treelai, & + currentCohort%treesai, & + currentCohort%height, & + iv,currentCohort%nv,currentCohort%pft, & + currentSite%snow_depth, & + vai_top,vai_bot, & + elai_layer,esai_layer,tlai_layer,tsai_layer) + + + currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) + & + tlai_layer * currentCohort%c_area/currentPatch%total_canopy_area + + currentPatch%elai_profile(cl,ft,iv) = currentPatch%elai_profile(cl,ft,iv) + & + elai_layer * currentCohort%c_area/currentPatch%total_canopy_area + + currentPatch%tsai_profile(cl,ft,iv) = currentPatch%tsai_profile(cl,ft,iv) + & + tsai_layer * currentCohort%c_area/currentPatch%total_canopy_area + + currentPatch%esai_profile(cl,ft,iv) = currentPatch%esai_profile(cl,ft,iv) + & + esai_layer * currentCohort%c_area/currentPatch%total_canopy_area + + currentPatch%canopy_area_profile(cl,ft,iv) = currentPatch%canopy_area_profile(cl,ft,iv) + & + currentCohort%c_area/currentPatch%total_canopy_area + + end do + + end if if_preserve_b4b + currentCohort => currentCohort%taller enddo !cohort diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 837f519270..6a88fe0033 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -95,7 +95,7 @@ module EDInitMod private logical :: debug = .false. - + logical, parameter :: preserve_b4b = .true. integer :: istat ! return status code character(len=255) :: smsg ! Message string for deallocation errors character(len=*), parameter, private :: sourcefile = & @@ -602,7 +602,7 @@ subroutine init_patches( nsites, sites, bc_in) call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & biomass_stock,litter_stock,seed_stock) end do - call set_patchno(sites(s)) + if(.not.preserve_b4b) call set_patchno(sites(s)) enddo else From c34773aff2e759eb5ee31ce440e4dd06c937a0dc Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 14 Dec 2023 14:33:20 -0700 Subject: [PATCH 220/250] reinstated ed_laisun_z and ed_laisha_z for b4b tests --- biogeochem/FatesPatchMod.F90 | 11 +++++++++-- biogeophys/FatesPlantRespPhotosynthMod.F90 | 11 ++++++++--- radiation/FatesRadiationDriveMod.F90 | 10 +++++++++- 3 files changed, 26 insertions(+), 6 deletions(-) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index c2c425e91a..ad6fd83876 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -138,7 +138,10 @@ module FatesPatchMod real(r8) :: ed_parsun_z(nclmax,maxpft,nlevleaf) ! PAR absorbed in the sun [W/m2] real(r8) :: ed_parsha_z(nclmax,maxpft,nlevleaf) ! PAR absorbed in the shade [W/m2] real(r8) :: f_sun(nclmax,maxpft,nlevleaf) ! fraction of leaves in the sun [0-1] + real(r8) :: ed_laisun_z(nclmax,maxpft,nlevleaf) + real(r8) :: ed_laisha_z(nclmax,maxpft,nlevleaf) + ! radiation profiles for comparison against observations real(r8) :: parprof_pft_dir_z(nclmax,maxpft,nlevleaf) ! direct-beam PAR profile through canopy, by canopy, PFT, leaf level [W/m2] real(r8) :: parprof_pft_dif_z(nclmax,maxpft,nlevleaf) ! diffuse PAR profile through canopy, by canopy, PFT, leaf level [W/m2] @@ -332,7 +335,9 @@ subroutine NanValues(this) this%fabd_sun_z(:,:,:) = nan this%fabd_sha_z(:,:,:) = nan this%fabi_sun_z(:,:,:) = nan - this%fabi_sha_z(:,:,:) = nan + this%fabi_sha_z(:,:,:) = nan + this%ed_laisun_z(:,:,:) = nan + this%ed_laisha_z(:,:,:) = nan this%ed_parsun_z(:,:,:) = nan this%ed_parsha_z(:,:,:) = nan this%f_sun(:,:,:) = nan @@ -417,7 +422,9 @@ subroutine ZeroValues(this) this%fabi_sun_z(:,:,:) = 0.0_r8 this%fabi_sha_z(:,:,:) = 0.0_r8 this%ed_parsun_z(:,:,:) = 0.0_r8 - this%ed_parsha_z(:,:,:) = 0.0_r8 + this%ed_parsha_z(:,:,:) = 0.0_r8 + this%ed_laisun_z(:,:,:) = 0._r8 + this%ed_laisha_z(:,:,:) = 0._r8 this%f_sun = 0.0_r8 this%tr_soil_dir_dif(:) = 0.0_r8 this%fab(:) = 0.0_r8 diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index db1ea5e367..97e90d5d3a 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -613,9 +613,14 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) if_radsolver: if(radiation_model.eq.norman_solver) then - laisun = currentPatch%elai_profile(cl,ft,iv)*currentPatch%f_sun(cl,ft,iv) - laisha = currentPatch%elai_profile(cl,ft,iv)*(1._r8-currentPatch%f_sun(cl,ft,iv)) - + if(preserve_b4b) then + laisun = currentPatch%ed_laisun_z(cl,ft,iv) + laisha = currentPatch%ed_laisha_z(cl,ft,iv) + else + laisun = currentPatch%elai_profile(cl,ft,iv)*currentPatch%f_sun(cl,ft,iv) + laisha = currentPatch%elai_profile(cl,ft,iv)*(1._r8-currentPatch%f_sun(cl,ft,iv)) + end if + if_nonnzero_lai: if((laisun+laisha)>0._r8) then if(((laisun*currentPatch%canopy_area_profile(cl,ft,iv)) >0.0000000001_r8)) then ! .and. & diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index 28d978ebac..8c20f6d526 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -297,7 +297,8 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) ! Initialize diagnostics cpatch%ed_parsun_z(:,:,:) = 0._r8 cpatch%ed_parsha_z(:,:,:) = 0._r8 - + cpatch%ed_laisun_z(:,:,:) = 0._r8 + cpatch%ed_laisha_z(:,:,:) = 0._r8 cpatch%parprof_pft_dir_z(:,:,:) = 0._r8 cpatch%parprof_pft_dif_z(:,:,:) = 0._r8 @@ -331,6 +332,13 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) cpatch%f_sun(cl,ft,iv) shalai = shalai + cpatch%elai_profile(cl,ft,iv) * & (1._r8 - cpatch%f_sun(cl,ft,iv)) + + cpatch%ed_laisun_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + cpatch%f_sun(CL,ft,iv) + + cpatch%ed_laisha_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + (1._r8 - cpatch%f_sun(CL,ft,iv)) + end do end if end do From 0c1e890e7d609cb04eb6f3470927ed3bc9d50679 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 14 Dec 2023 15:46:21 -0700 Subject: [PATCH 221/250] reverting canopy mask for b4b --- biogeochem/EDCanopyStructureMod.F90 | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 0687b15af7..31bab561ef 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1807,13 +1807,27 @@ subroutine leaf_area_profile( currentSite ) ! canopy_area_profile for these layers is not >0 for layers in ncan ... ! Leaving this for the time being. ! -------------------------------------------------------------------------- + currentPatch%canopy_mask(:,:) = 0 - do cl = 1,currentPatch%NCL_p - do ft = 1,numpft - if(currentPatch%canopy_area_profile(cl,ft,1) > 0._r8 ) currentPatch%canopy_mask(cl,ft) = 1 + if(preserve_b4b) then + do cl = 1,currentPatch%NCL_p + do ft = 1,numpft + do iv = 1, currentPatch%nrad(cl,ft) + if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then + currentPatch%canopy_mask(cl,ft) = 1 + endif + end do !iv + end do end do - end do + else + do cl = 1,currentPatch%NCL_p + do ft = 1,numpft + if(currentPatch%canopy_area_profile(cl,ft,1) > 0._r8 ) currentPatch%canopy_mask(cl,ft) = 1 + end do + end do + end if + end if if_any_canopy_area currentPatch => currentPatch%younger From 4966a986411e75b76fcc49088f01fc03359d59ec Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 14 Dec 2023 16:09:32 -0700 Subject: [PATCH 222/250] refactor to replace findloc intrinsic findloc is not available for the current supported compiler versions (e.g. < nag 7.0) --- biogeochem/FatesLandUseChangeMod.F90 | 17 +++++++------- main/FatesUtilsMod.F90 | 35 ++++++++++++++++++++++++++++ 2 files changed, 44 insertions(+), 8 deletions(-) diff --git a/biogeochem/FatesLandUseChangeMod.F90 b/biogeochem/FatesLandUseChangeMod.F90 index b7bf893b6d..1999cfabc7 100644 --- a/biogeochem/FatesLandUseChangeMod.F90 +++ b/biogeochem/FatesLandUseChangeMod.F90 @@ -15,7 +15,8 @@ module FatesLandUseChangeMod use FatesInterfaceTypesMod , only : hlm_use_luh use FatesInterfaceTypesMod , only : hlm_num_luh2_states use FatesInterfaceTypesMod , only : hlm_num_luh2_transitions - use EDTypesMod , only : area_site => area + use FatesUtilsMod , only : FindIndex + use EDTypesMod , only : area_site => area ! CIME globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -72,7 +73,7 @@ subroutine get_landuse_transition_rates(bc_in, landuse_transition_matrix) ! !LOCAL VARIABLES: type(luh2_fates_lutype_map) :: lumap - integer :: i_donor, i_receiver, i_luh2_transitions, i_luh2_states + integer :: i_donor, i_receiver, i_luh2_transitions, i_luh2_states, i_urban character(5) :: donor_name, receiver_name character(14) :: transition_name real(r8) :: urban_fraction @@ -88,7 +89,7 @@ subroutine get_landuse_transition_rates(bc_in, landuse_transition_matrix) call CheckLUHData(temp_vector,modified_flag) if (.not. modified_flag) then ! identify urban fraction so that it can be factored into the land use state output - urban_fraction = bc_in%hlm_luh_states(findloc(bc_in%hlm_luh_state_names,'urban',dim=1)) + urban_fraction = bc_in%hlm_luh_states(FindIndex(bc_in%hlm_luh_state_names,'urban')) end if !!TODO: may need some logic here to ask whether or not ot perform land use change on this timestep. current code occurs every day. @@ -122,19 +123,19 @@ function GetLUCategoryFromStateName(this, state_name) result(landuse_category) class(luh2_fates_lutype_map) :: this character(len=5), intent(in) :: state_name integer :: landuse_category - integer :: index + integer :: index_statename - index = findloc(this%state_names,state_name,dim=1) + index_statename = FindIndex(this%state_names,state_name) ! Check that the result from the landuse_categories is not zero, which indicates that no ! match was found. - if (index .eq. 0) then + if (index_statename .eq. 0) then write(fates_log(),*) 'The input state name from the HLM does not match the FATES landuse state name options' write(fates_log(),*) 'input state name: ', state_name write(fates_log(),*) 'state name options: ', this%state_names call endrun(msg=errMsg(sourcefile, __LINE__)) else - landuse_category = this%landuse_categories(index) + landuse_category = this%landuse_categories(index_statename) end if end function GetLUCategoryFromStateName @@ -253,7 +254,7 @@ subroutine get_luh_statedata(bc_in, state_vector) call CheckLUHData(temp_vector,modified_flag) if (.not. modified_flag) then ! identify urban fraction so that it can be factored into the land use state output - urban_fraction = bc_in%hlm_luh_states(findloc(bc_in%hlm_luh_state_names,'urban',dim=1)) + urban_fraction = bc_in%hlm_luh_states(FindIndex(bc_in%hlm_luh_state_names,'urban')) end if ! loop over all states and add up the ones that correspond to a given fates land use type diff --git a/main/FatesUtilsMod.F90 b/main/FatesUtilsMod.F90 index 3310b5d6a4..f94aa99c45 100644 --- a/main/FatesUtilsMod.F90 +++ b/main/FatesUtilsMod.F90 @@ -13,6 +13,7 @@ module FatesUtilsMod public :: check_hlm_list public :: check_var_real public :: GetNeighborDistance + public :: FindIndex contains @@ -144,5 +145,39 @@ function GetNeighborDistance(gi,gj,latc,lonc) result(gcd) end function GetNeighborDistance ! ====================================================================================== + + function FindIndex(input_string_array,string_to_match) result(array_index) + + ! --------------------------------------------------------------------------------- + ! This simple function is a standin for the intrinsic FINDLOC which is not available + ! with some compilers such as NAG prior to v7.0. As with FINDLOC, the + ! function will return zero if a match is not found. + ! + ! Limitations compared to FINDLOC: + ! - Only takes one dimensional arrays + ! - Only take arrays of characters + ! - Does not allow masking + ! --------------------------------------------------------------------------------- + + ! Input and output + character(len=*), intent(in) :: input_string_array(:) + character(len=*), intent(in) :: string_to_match + integer :: array_index + + ! Locals + integer :: i + ! Initialize return index as zero + array_index = 0 + + ! Loop throught the array and compare strings + do i = 1, len(input_string_array) + if (trim(input_string_array(i)) .eq. trim(string_to_match)) then + array_index = i + end if + end do + + end function FindIndex + + ! ====================================================================================== end module FatesUtilsMod From ece937ceed09dcf4e33faf9b182b096c7266f179 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 14 Dec 2023 17:57:40 -0700 Subject: [PATCH 223/250] fix array size call --- main/FatesUtilsMod.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/main/FatesUtilsMod.F90 b/main/FatesUtilsMod.F90 index f94aa99c45..4699a6aa60 100644 --- a/main/FatesUtilsMod.F90 +++ b/main/FatesUtilsMod.F90 @@ -136,8 +136,6 @@ function GetNeighborDistance(gi,gj,latc,lonc) result(gcd) integer, intent(in) :: gi,gj ! indices of gridcells real(r8), intent(in) :: latc(:),lonc(:) ! lat/lon of gridcells real(r8) :: gcd - - ! write(fates_log(),*)'neighborhood: size ldomain latc/lonc: ', size(ldomain%latc), size(ldomain%lonc) gcd = GreatCircleDist(lonc(gi),lonc(gj), & latc(gi),latc(gj)) @@ -171,7 +169,7 @@ function FindIndex(input_string_array,string_to_match) result(array_index) array_index = 0 ! Loop throught the array and compare strings - do i = 1, len(input_string_array) + do i = 1, size(input_string_array) if (trim(input_string_array(i)) .eq. trim(string_to_match)) then array_index = i end if From 89aecd18efd1d2bc173ae79eb52391ed6643fd7b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 14 Dec 2023 18:35:02 -0700 Subject: [PATCH 224/250] reworking towards b4b --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 102 ++++++++++++--------- 1 file changed, 57 insertions(+), 45 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 97e90d5d3a..4f5d3d12e3 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -609,6 +609,10 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! par_per_sunla = [W absorbed beam+diffuse radiation / m2 of sunlit leaves] ! par_per_shala = [W absorbed diffuse radiation / m2 of shaded leaves] ! fsun = [m2 of sunlit leaves / m2 of total leaves] + ! laisun: m2 of exposed leaf, per m2 of crown. If this is the lowest layer + ! for the pft/canopy group, than the m2 per crown is probably not + ! as large as the layer above. + ! elai_layer: the exposed lai of the layer per m2 of crown (should be laisun+laisha) ! ------------------------------------------------------------------ if_radsolver: if(radiation_model.eq.norman_solver) then @@ -616,47 +620,43 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) if(preserve_b4b) then laisun = currentPatch%ed_laisun_z(cl,ft,iv) laisha = currentPatch%ed_laisha_z(cl,ft,iv) + elai_layer = laisun + laisha else laisun = currentPatch%elai_profile(cl,ft,iv)*currentPatch%f_sun(cl,ft,iv) laisha = currentPatch%elai_profile(cl,ft,iv)*(1._r8-currentPatch%f_sun(cl,ft,iv)) + elai_layer = currentPatch%elai_profile(cl,ft,iv) end if - if_nonnzero_lai: if((laisun+laisha)>0._r8) then - - if(((laisun*currentPatch%canopy_area_profile(cl,ft,iv)) >0.0000000001_r8)) then ! .and. & - !(currentPatch%ed_parsun_z(cl,ft,iv)>nearzero)) then + if(currentPatch%ed_parsun_z(cl,ft,iv)<=0._r8) then - ! laisun: m2 of exposed leaf, per m2 of crown. If this is the lowest layer - ! for the pft/canopy group, than the m2 per crown is probably not - ! as large as the layer above. - ! ed_parsun_z: this is W/m2 ground times the canopy_area_profile, which is the - ! fraction of m2 of ground in the crown per m2 ground in the - ! total canopy area. This results in W/m2 of total canopy. + ! This is just a dummy, won't be used + par_per_sunla = currentPatch%ed_parsun_z(cl,ft,iv) + par_per_shala = currentPatch%ed_parsha_z(cl,ft,iv) + + else + ! laisun: m2 of exposed leaf, per m2 of crown. If this is the lowest layer + ! for the pft/canopy group, than the m2 per crown is probably not + ! as large as the layer above. + ! ed_parsun_z: this is W/m2 ground times the canopy_area_profile, which is the + ! fraction of m2 of ground in the crown per m2 ground in the + ! total canopy area. This results in W/m2 of total canopy. + !if(((laisun*currentPatch%canopy_area_profile(cl,ft,iv)) >0.0000000001_r8)) then par_per_sunla = currentPatch%ed_parsun_z(cl,ft,iv) / & (laisun*currentPatch%canopy_area_profile(cl,ft,iv)) - else - par_per_sunla = 0._r8 - end if - - !!if(((laisha*currentPatch%canopy_area_profile(cl,ft,iv)) >nearzero) .and. & - !! (currentPatch%ed_parsha_z(cl,ft,iv)>nearzero)) then - + !else + !par_per_sunla = 0._r8 + !end if + par_per_shala = currentPatch%ed_parsha_z(cl,ft,iv) / & (laisha*currentPatch%canopy_area_profile(cl,ft,iv)) - elai_layer = currentPatch%elai_profile(cl,ft,iv) - - else + - par_per_sunla = 0._r8 - par_per_shala = 0._r8 - elai_layer = 0._r8 - - end if if_nonnzero_lai + + end if fsun = currentPatch%f_sun(cl,ft,iv) - - + else ! Two-stream if(cohort_layer_elai(iv) > nearzero .and. currentPatch%solar_zenith_flag) then @@ -722,6 +722,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) call LeafLayerPhotosynthesis(fsun, & ! in par_per_sunla, & ! in par_per_shala, & ! in + laisun*currentPatch%canopy_area_profile(cl,ft,iv), & elai_layer, & ! in ft, & ! in vcmax_z, & ! in @@ -1191,6 +1192,7 @@ end subroutine RootLayerNFixation subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in parsun_lsl, & ! in parsha_lsl, & ! in + elaisun_lsl, & ! elai_lsl, & ! in ft, & ! in vcmax, & ! in @@ -1242,7 +1244,8 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in real(r8), intent(in) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) real(r8), intent(in) :: veg_tempk ! vegetation temperature real(r8), intent(in) :: veg_esat ! saturation vapor pressure at veg_tempk (Pa) - + real(r8), intent(in) :: elaisun_lsl + ! Important Note on the following gas pressures. This photosynthesis scheme will iteratively ! solve for the co2 partial pressure at the leaf surface (ie in the stomata). The reference ! point for these input values are NOT within that boundary layer that separates the stomata from @@ -1364,9 +1367,24 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in else ! day time (a little bit more complicated ...) ! Is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) + ! RGK: moved the trivial outcome to the top for clarity... + + if_leafarea: if (.not.(elai_lsl > 0._r8) ) then + + ! No leaf area. This layer is present only because of stems. + ! Net assimilation is zero, not negative because there are + ! no leaves to even respire + ! (leaves are off, or have reduced to 0) - if_leafarea: if (elai_lsl > 0._r8 ) then + psn_out = 0._r8 + anet_av_out = 0._r8 + + rstoma_out = min(rsmax0,cf/(stem_cuticle_loss_frac*stomatal_intercept(ft))) + c13disc_z = 0.0_r8 + + else + !Loop aroun shaded and unshaded leaves psn_out = 0._r8 ! psn is accumulated across sun and shaded leaves. rstoma_out = 0._r8 ! 1/rs is accumulated across sun and shaded leaves. @@ -1384,7 +1402,11 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! (von Caemmerer) and Farquhar 1980 if(sunsha == 1)then !sunlit - qabs = parsun_lsl * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 + if( elaisun_lsl >0.0000000001_r8) then + qabs = parsun_lsl * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 + else + qabs = 0._r8 + end if else qabs = parsha_lsl * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 end if @@ -1434,7 +1456,11 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! C4: RuBP-limited photosynthesis if(sunsha == 1)then !sunlit - aj = quant_eff(c3c4_path_index) * parsun_lsl * 4.6_r8 + if( elaisun_lsl >0.0000000001_r8) then + aj = quant_eff(c3c4_path_index) * parsun_lsl * 4.6_r8 + else + aj = 0._r8 + end if else aj = quant_eff(c3c4_path_index) * parsha_lsl * 4.6_r8 end if @@ -1591,20 +1617,6 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in rstoma_out = 1._r8/gstoma end if - - else - - ! No leaf area. This layer is present only because of stems. - ! Net assimilation is zero, not negative because there are - ! no leaves to even respire - ! (leaves are off, or have reduced to 0) - - psn_out = 0._r8 - anet_av_out = 0._r8 - - rstoma_out = min(rsmax0,cf/(stem_cuticle_loss_frac*stomatal_intercept(ft))) - c13disc_z = 0.0_r8 - end if if_leafarea !is there leaf area? From c6da2fef4fcb2b69bd8f244536324acd7ac74318 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 15 Dec 2023 15:11:35 -0500 Subject: [PATCH 225/250] b4b stuff --- biogeochem/EDCanopyStructureMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 31bab561ef..eba78af22a 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1569,7 +1569,7 @@ subroutine leaf_area_profile( currentSite ) call UpdatePatchLAI(currentPatch) - currentPatch%nrad(:,:) = currentPatch%ncan(:,:) + !currentPatch%nrad(:,:) = currentPatch%ncan(:,:) ! ----------------------------------------------------------------------------- ! Standard canopy layering model. From 56eec5655ed5120ac7d4d89c0529fc7ce0297f45 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 15 Dec 2023 15:01:04 -0700 Subject: [PATCH 226/250] Reduce the sum of fates_maxpatches_per_landuse to 16 as default The sum of the maxpatches is used to set the natpft value in the HLMs. Some of the companion default surface datasets (e.g. NEON) currently assume 16 pfts for fates and as such, having the default paramfile with more pfts would require rebuilding many other surface datasets. --- parameter_files/archive/api32.0.0_113023_luh2.xml | 2 +- parameter_files/fates_params_default.cdl | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/parameter_files/archive/api32.0.0_113023_luh2.xml b/parameter_files/archive/api32.0.0_113023_luh2.xml index a137b46b88..ab0e8f33db 100644 --- a/parameter_files/archive/api32.0.0_113023_luh2.xml +++ b/parameter_files/archive/api32.0.0_113023_luh2.xml @@ -41,7 +41,7 @@ fates_landuseclass count maximum number of patches per site on each land use type - 10, 4, 1, 1, 1 + 9, 4, 1, 1, 1 fates_landuseclass_name diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index f7ee94a1a9..e288664751 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -8,12 +8,12 @@ dimensions: fates_history_size_bins = 13 ; fates_hlm_pftno = 14 ; fates_hydr_organs = 4 ; - fates_landuseclass = 5 ; fates_leafage_class = 1 ; fates_litterclass = 6 ; fates_pft = 12 ; fates_plant_organs = 4 ; fates_string_length = 60 ; + fates_landuseclass = 5 ; variables: double fates_history_ageclass_bin_edges(fates_history_age_bins) ; fates_history_ageclass_bin_edges:units = "yr" ; @@ -1597,7 +1597,7 @@ data: fates_frag_cwd_frac = 0.045, 0.075, 0.21, 0.67 ; - fates_maxpatches_by_landuse = 10, 4, 1, 1, 1 ; + fates_maxpatches_by_landuse = 9, 4, 1, 1, 1 ; fates_canopy_closure_thresh = 0.8 ; From 7a7a8a32682d2bd0319e0381beff0bf812a1da7c Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 15 Dec 2023 15:13:42 -0700 Subject: [PATCH 227/250] rename the patch paramfile for api 32 I also reordered the datestamp for the filename to YYMMDD --- .../{api32.0.0_113023_luh2.xml => api32.0.0_231215_luh2.xml} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename parameter_files/archive/{api32.0.0_113023_luh2.xml => api32.0.0_231215_luh2.xml} (100%) diff --git a/parameter_files/archive/api32.0.0_113023_luh2.xml b/parameter_files/archive/api32.0.0_231215_luh2.xml similarity index 100% rename from parameter_files/archive/api32.0.0_113023_luh2.xml rename to parameter_files/archive/api32.0.0_231215_luh2.xml From f6b879e338927af7bc49d2402efda5b8a1615265 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 18 Dec 2023 10:57:56 -0700 Subject: [PATCH 228/250] b4b stuff for two-stream --- biogeochem/EDCanopyStructureMod.F90 | 2 +- biogeophys/FatesPlantRespPhotosynthMod.F90 | 931 ++++++++++----------- 2 files changed, 458 insertions(+), 475 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index eba78af22a..31bab561ef 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1569,7 +1569,7 @@ subroutine leaf_area_profile( currentSite ) call UpdatePatchLAI(currentPatch) - !currentPatch%nrad(:,:) = currentPatch%ncan(:,:) + currentPatch%nrad(:,:) = currentPatch%ncan(:,:) ! ----------------------------------------------------------------------------- ! Standard canopy layering model. diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 4f5d3d12e3..c396329e85 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -282,6 +282,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: cohort_esai real(r8) :: elai_layer real(r8) :: laisun,laisha + real(r8) :: canopy_area real(r8) :: elai ! ----------------------------------------------------------------------------------- ! Keeping these two definitions in case they need to be added later @@ -617,44 +618,11 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) if_radsolver: if(radiation_model.eq.norman_solver) then - if(preserve_b4b) then - laisun = currentPatch%ed_laisun_z(cl,ft,iv) - laisha = currentPatch%ed_laisha_z(cl,ft,iv) - elai_layer = laisun + laisha - else - laisun = currentPatch%elai_profile(cl,ft,iv)*currentPatch%f_sun(cl,ft,iv) - laisha = currentPatch%elai_profile(cl,ft,iv)*(1._r8-currentPatch%f_sun(cl,ft,iv)) - elai_layer = currentPatch%elai_profile(cl,ft,iv) - end if - - if(currentPatch%ed_parsun_z(cl,ft,iv)<=0._r8) then - - ! This is just a dummy, won't be used - par_per_sunla = currentPatch%ed_parsun_z(cl,ft,iv) - par_per_shala = currentPatch%ed_parsha_z(cl,ft,iv) - - else - - ! laisun: m2 of exposed leaf, per m2 of crown. If this is the lowest layer - ! for the pft/canopy group, than the m2 per crown is probably not - ! as large as the layer above. - ! ed_parsun_z: this is W/m2 ground times the canopy_area_profile, which is the - ! fraction of m2 of ground in the crown per m2 ground in the - ! total canopy area. This results in W/m2 of total canopy. - !if(((laisun*currentPatch%canopy_area_profile(cl,ft,iv)) >0.0000000001_r8)) then - par_per_sunla = currentPatch%ed_parsun_z(cl,ft,iv) / & - (laisun*currentPatch%canopy_area_profile(cl,ft,iv)) - !else - !par_per_sunla = 0._r8 - !end if - - par_per_shala = currentPatch%ed_parsha_z(cl,ft,iv) / & - (laisha*currentPatch%canopy_area_profile(cl,ft,iv)) - - - - end if - + laisun = currentPatch%ed_laisun_z(cl,ft,iv) + laisha = currentPatch%ed_laisha_z(cl,ft,iv) + par_per_sunla = currentPatch%ed_parsun_z(cl,ft,iv) + par_per_shala = currentPatch%ed_parsha_z(cl,ft,iv) + canopy_area = currentPatch%canopy_area_profile(cl,ft,iv) fsun = currentPatch%f_sun(cl,ft,iv) else ! Two-stream @@ -674,18 +642,25 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! cohort_layer_elai*fsun Leaf area in sunlight within this interval and ground footprint ! cohort_layer_elai*(1-fsun) Leaf area in shade within this interval and ground footprint + laisun = (fsun*cohort_layer_elai(iv)) + laisha = ((1._r8 - fsun)*cohort_layer_elai(iv)) if(fsun>nearzero) then - par_per_sunla = (rd_abs_leaf*fsun + rb_abs_leaf) / (fsun*cohort_layer_elai(iv)) + par_per_sunla = (rd_abs_leaf*fsun + rb_abs_leaf) / laisun else par_per_sunla = 0._r8 end if - par_per_shala = rd_abs_leaf*(1._r8-fsun) / ((1._r8 - fsun)*cohort_layer_elai(iv)) - + par_per_shala = rd_abs_leaf*(1._r8-fsun) / laisha + canopy_area = currentPatch%canopy_area_profile(cl,ft,iv) + else par_per_sunla = 0._r8 par_per_shala = 0._r8 + laisun = (fsun*cohort_layer_elai(iv)) + laisha = ((1._r8 - fsun)*cohort_layer_elai(iv)) + canopy_area = currentPatch%canopy_area_profile(cl,ft,iv) fsun = 0.5_r8 !avoid div0, should have no impact + end if elai_layer = cohort_layer_elai(iv) @@ -722,8 +697,9 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) call LeafLayerPhotosynthesis(fsun, & ! in par_per_sunla, & ! in par_per_shala, & ! in - laisun*currentPatch%canopy_area_profile(cl,ft,iv), & - elai_layer, & ! in + laisun, & ! in + laisha, & ! in + canopy_area, & ! in ft, & ! in vcmax_z, & ! in jmax_z, & ! in @@ -1189,442 +1165,449 @@ end subroutine RootLayerNFixation ! ======================================================================================= - subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in - parsun_lsl, & ! in - parsha_lsl, & ! in - elaisun_lsl, & ! - elai_lsl, & ! in - ft, & ! in - vcmax, & ! in - jmax, & ! in - co2_rcurve_islope, & ! in - veg_tempk, & ! in - veg_esat, & ! in - can_press, & ! in - can_co2_ppress, & ! in - can_o2_ppress, & ! in - btran, & ! in - stomatal_intercept_btran, & ! in - cf, & ! in - gb_mol, & ! in - ceair, & ! in - mm_kco2, & ! in - mm_ko2, & ! in - co2_cpoint, & ! in - lmr, & ! in - leaf_psi, & ! in - rb, & ! in - psn_out, & ! out - rstoma_out, & ! out - anet_av_out, & ! out - c13disc_z) ! out - - - ! ------------------------------------------------------------------------------------ - ! This subroutine calculates photosynthesis and stomatal conductance within each leaf - ! sublayer. - ! A note on naming conventions: As this subroutine is called for every - ! leaf-sublayer, many of the arguments are specific to that "leaf sub layer" - ! (LSL), those variables are given a dimension tag "_lsl" - ! Other arguments or variables may be indicative of scales broader than the LSL. - ! ------------------------------------------------------------------------------------ - - use EDParamsMod , only : theta_cj_c3, theta_cj_c4 - - - ! Arguments - ! ------------------------------------------------------------------------------------ - real(r8), intent(in) :: f_sun_lsl ! - real(r8), intent(in) :: parsun_lsl ! Absorbed PAR in sunlist leaves per sunlit leaf area [W/m2 leaf] - real(r8), intent(in) :: parsha_lsl ! Absorved PAR in shaded leaves per shaded leaf area [W/m2 leaf] - real(r8), intent(in) :: elai_lsl ! ELAI of this layer [m2/m2] - integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8), intent(in) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) - real(r8), intent(in) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) - real(r8), intent(in) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) - real(r8), intent(in) :: veg_tempk ! vegetation temperature - real(r8), intent(in) :: veg_esat ! saturation vapor pressure at veg_tempk (Pa) - real(r8), intent(in) :: elaisun_lsl - - ! Important Note on the following gas pressures. This photosynthesis scheme will iteratively - ! solve for the co2 partial pressure at the leaf surface (ie in the stomata). The reference - ! point for these input values are NOT within that boundary layer that separates the stomata from - ! the canopy air space. The reference point for these is on the outside of that boundary - ! layer. This routine, which operates at the leaf scale, makes no assumptions about what the - ! scale of the refernce is, it could be lower atmosphere, it could be within the canopy - ! but most likely it is the closest value one can get to the edge of the leaf's boundary - ! layer. We use the convention "can_" because a reference point of within the canopy - ! ia a best reasonable scenario of where we can get that information from. - - real(r8), intent(in) :: can_press ! Air pressure NEAR the surface of the leaf (Pa) - real(r8), intent(in) :: can_co2_ppress ! Partial pressure of CO2 NEAR the leaf surface (Pa) - real(r8), intent(in) :: can_o2_ppress ! Partial pressure of O2 NEAR the leaf surface (Pa) - real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) - real(r8), intent(in) :: stomatal_intercept_btran !water-stressed minimum stomatal conductance (umol H2O/m**2/s) - real(r8), intent(in) :: cf ! s m**2/umol -> s/m (ideal gas conversion) [umol/m3] - real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol /m**2/s) - real(r8), intent(in) :: ceair ! vapor pressure of air, constrained (Pa) - real(r8), intent(in) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) - real(r8), intent(in) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) - real(r8), intent(in) :: co2_cpoint ! CO2 compensation point (Pa) - real(r8), intent(in) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) - real(r8), intent(in) :: leaf_psi ! Leaf water potential [MPa] - real(r8), intent(in) :: rb ! Boundary Layer resistance of leaf [s/m] - - real(r8), intent(out) :: psn_out ! carbon assimilated in this leaf layer umolC/m2/s - real(r8), intent(out) :: rstoma_out ! stomatal resistance (1/gs_lsl) (s/m) - real(r8), intent(out) :: anet_av_out ! net leaf photosynthesis (umol CO2/m**2/s) - ! averaged over sun and shade leaves. - real(r8), intent(out) :: c13disc_z ! carbon 13 in newly assimilated carbon - - - - - ! Locals - ! ------------------------------------------------------------------------ - integer :: c3c4_path_index ! Index for which photosynthetic pathway - ! is active. C4 = 0, C3 = 1 - integer :: sunsha ! Index for differentiating sun and shade - real(r8) :: gstoma ! Stomatal Conductance of this leaf layer (m/s) - real(r8) :: agross ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) - real(r8) :: anet ! net leaf photosynthesis (umol CO2/m**2/s) - real(r8) :: a_gs ! The assimilation (a) for calculating conductance (gs) - ! is either = to anet or agross - real(r8) :: je ! electron transport rate (umol electrons/m**2/s) - real(r8) :: qabs ! PAR absorbed by PS II (umol photons/m**2/s) - real(r8) :: aquad,bquad,cquad ! terms for quadratic equations - real(r8) :: r1,r2 ! roots of quadratic equation - real(r8) :: co2_inter_c ! intercellular leaf CO2 (Pa) - real(r8) :: co2_inter_c_old ! intercellular leaf CO2 (Pa) (previous iteration) - logical :: loop_continue ! Loop control variable - integer :: niter ! iteration loop index - real(r8) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) - real(r8) :: gs ! leaf stomatal conductance (m/s) - real(r8) :: hs ! fractional humidity at leaf surface (dimensionless) - real(r8) :: gs_mol_err ! gs_mol for error check - real(r8) :: ac ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) - real(r8) :: aj ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) - real(r8) :: ap ! product-limited (C3) or CO2-limited - ! (C4) gross photosynthesis (umol CO2/m**2/s) - real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) - real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) - real(r8) :: init_co2_inter_c ! First guess intercellular co2 specific to C path - real(r8) :: term ! intermediate variable in Medlyn stomatal conductance model - real(r8) :: vpd ! water vapor deficit in Medlyn stomatal model (KPa) - - - ! Parameters - ! ------------------------------------------------------------------------ - ! Fraction of light absorbed by non-photosynthetic pigments - real(r8),parameter :: fnps = 0.15_r8 - - ! For plants with no leaves, a miniscule amount of conductance - ! can happen through the stems, at a partial rate of cuticular conductance - real(r8),parameter :: stem_cuticle_loss_frac = 0.1_r8 - - ! empirical curvature parameter for electron transport rate - real(r8),parameter :: theta_psii = 0.7_r8 - - ! First guess on ratio between intercellular co2 and the atmosphere - ! an iterator converges on actual - real(r8),parameter :: init_a2l_co2_c3 = 0.7_r8 - real(r8),parameter :: init_a2l_co2_c4 = 0.4_r8 +subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in + parsun_lsl, & ! in + parsha_lsl, & ! in + laisun_lsl, & ! in + laisha_lsl, & ! in + canopy_area_lsl, & ! in + ft, & ! in + vcmax, & ! in + jmax, & ! in + co2_rcurve_islope, & ! in + veg_tempk, & ! in + veg_esat, & ! in + can_press, & ! in + can_co2_ppress, & ! in + can_o2_ppress, & ! in + btran, & ! in + stomatal_intercept_btran, & ! in + cf, & ! in + gb_mol, & ! in + ceair, & ! in + mm_kco2, & ! in + mm_ko2, & ! in + co2_cpoint, & ! in + lmr, & ! in + leaf_psi, & ! in + rb, & ! in + psn_out, & ! out + rstoma_out, & ! out + anet_av_out, & ! out + c13disc_z) ! out - ! quantum efficiency, used only for C4 (mol CO2 / mol photons) (index 0) - real(r8),parameter,dimension(0:1) :: quant_eff = [0.05_r8,0.0_r8] - ! empirical curvature parameter for ap photosynthesis co-limitation - real(r8),parameter :: theta_ip = 0.999_r8 - - associate( bb_slope => EDPftvarcon_inst%bb_slope ,& ! slope of BB relationship, unitless - medlyn_slope=> EDPftvarcon_inst%medlyn_slope , & ! Slope for Medlyn stomatal conductance model method, the unit is KPa^0.5 - stomatal_intercept=> EDPftvarcon_inst%stomatal_intercept ) !Unstressed minimum stomatal conductance, the unit is umol/m**2/s - - ! photosynthetic pathway: 0. = c4, 1. = c3 - c3c4_path_index = nint(EDPftvarcon_inst%c3psn(ft)) - - if (c3c4_path_index == c3_path_index) then - init_co2_inter_c = init_a2l_co2_c3 * can_co2_ppress - else - init_co2_inter_c = init_a2l_co2_c4 * can_co2_ppress - end if - - ! Part III: Photosynthesis and Conductance - ! ---------------------------------------------------------------------------------- - - if_daytime: if ( parsun_lsl <= 0._r8 ) then ! night time - - anet_av_out = -lmr - psn_out = 0._r8 - - ! The cuticular conductance already factored in maximum resistance as a bound - ! no need to re-bound it - - rstoma_out = cf/stomatal_intercept_btran - - c13disc_z = 0.0_r8 !carbon 13 discrimination in night time carbon flux, note value of 1.0 is used in CLM - - else ! day time (a little bit more complicated ...) - - ! Is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) - ! RGK: moved the trivial outcome to the top for clarity... - - if_leafarea: if (.not.(elai_lsl > 0._r8) ) then - - ! No leaf area. This layer is present only because of stems. - ! Net assimilation is zero, not negative because there are - ! no leaves to even respire - ! (leaves are off, or have reduced to 0) - - psn_out = 0._r8 - anet_av_out = 0._r8 - - rstoma_out = min(rsmax0,cf/(stem_cuticle_loss_frac*stomatal_intercept(ft))) - c13disc_z = 0.0_r8 - - else - - - !Loop aroun shaded and unshaded leaves - psn_out = 0._r8 ! psn is accumulated across sun and shaded leaves. - rstoma_out = 0._r8 ! 1/rs is accumulated across sun and shaded leaves. - anet_av_out = 0._r8 - gstoma = 0._r8 - - do sunsha = 1,2 - - ! Electron transport rate for C3 plants. - ! Convert par from W/m2 to umol photons/m**2/s using the factor 4.6 - ! Convert from units of par absorbed per unit ground area to par - ! absorbed per unit leaf area. - ! The 0.5 term here accounts for half of the light going to photosystem - ! 2, as mentioned in Biochemical models of leaf photosynthesis - ! (von Caemmerer) and Farquhar 1980 - - if(sunsha == 1)then !sunlit - if( elaisun_lsl >0.0000000001_r8) then - qabs = parsun_lsl * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 - else - qabs = 0._r8 - end if - else - qabs = parsha_lsl * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 - end if - - !convert the absorbed par into absorbed par per m2 of leaf, - ! so it is consistant with the vcmax and lmr numbers. - aquad = theta_psii - bquad = -(qabs + jmax) - cquad = qabs * jmax - call quadratic_f (aquad, bquad, cquad, r1, r2) - je = min(r1,r2) - - ! Initialize intercellular co2 - co2_inter_c = init_co2_inter_c - - niter = 0 - loop_continue = .true. - iter_loop: do while(loop_continue) - ! Increment iteration counter. Stop if too many iterations - niter = niter + 1 - - ! Save old co2_inter_c - co2_inter_c_old = co2_inter_c - - ! Photosynthesis limitation rate calculations - if (c3c4_path_index == c3_path_index)then - - ! C3: Rubisco-limited photosynthesis - ac = vcmax * max(co2_inter_c-co2_cpoint, 0._r8) / & - (co2_inter_c+mm_kco2 * (1._r8+can_o2_ppress / mm_ko2 )) - - ! C3: RuBP-limited photosynthesis - aj = je * max(co2_inter_c-co2_cpoint, 0._r8) / & - (4._r8*co2_inter_c+8._r8*co2_cpoint) - - ! Gross photosynthesis smoothing calculations. Co-limit ac and aj. - aquad = theta_cj_c3 - bquad = -(ac + aj) - cquad = ac * aj - call quadratic_f (aquad, bquad, cquad, r1, r2) - agross = min(r1,r2) - - else - - ! C4: Rubisco-limited photosynthesis - ac = vcmax - - ! C4: RuBP-limited photosynthesis - if(sunsha == 1)then !sunlit - if( elaisun_lsl >0.0000000001_r8) then - aj = quant_eff(c3c4_path_index) * parsun_lsl * 4.6_r8 - else - aj = 0._r8 - end if - else - aj = quant_eff(c3c4_path_index) * parsha_lsl * 4.6_r8 - end if - - ! C4: PEP carboxylase-limited (CO2-limited) - ap = co2_rcurve_islope * max(co2_inter_c, 0._r8) / can_press - - ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap - - aquad = theta_cj_c4 - bquad = -(ac + aj) - cquad = ac * aj - call quadratic_f (aquad, bquad, cquad, r1, r2) - ai = min(r1,r2) - - aquad = theta_ip - bquad = -(ai + ap) - cquad = ai * ap - call quadratic_f (aquad, bquad, cquad, r1, r2) - agross = min(r1,r2) - - end if - - ! Calculate anet, only exit iteration with negative anet when - ! using anet in calculating gs this is version B - anet = agross - lmr - - if ( stomatal_assim_model == gross_assim_model ) then - if ( stomatal_model == medlyn_model ) then - write (fates_log(),*) 'Gross Assimilation conductance is incompatible with the Medlyn model' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - a_gs = agross - else - if (anet < 0._r8) then - loop_continue = .false. - end if - a_gs = anet - end if - - ! With an <= 0, then gs_mol = stomatal_intercept_btran - leaf_co2_ppress = can_co2_ppress- h2o_co2_bl_diffuse_ratio/gb_mol * a_gs * can_press - leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) - - if ( stomatal_model == medlyn_model ) then - !stomatal conductance calculated from Medlyn et al. (2011), the numerical & - !implementation was adapted from the equations in CLM5.0 - vpd = max((veg_esat - ceair), 50._r8) * 0.001_r8 !addapted from CLM5. Put some constraint on VPD - !when Medlyn stomatal conductance is being used, the unit is KPa. Ignoring the constraint will cause errors when model runs. - term = h2o_co2_stoma_diffuse_ratio * anet / (leaf_co2_ppress / can_press) - aquad = 1.0_r8 - bquad = -(2.0 * (stomatal_intercept_btran+ term) + (medlyn_slope(ft) * term)**2 / & - (gb_mol * vpd )) - cquad = stomatal_intercept_btran*stomatal_intercept_btran + & - (2.0*stomatal_intercept_btran + term * & - (1.0 - medlyn_slope(ft)* medlyn_slope(ft) / vpd)) * term - - call quadratic_f (aquad, bquad, cquad, r1, r2) - gs_mol = max(r1,r2) - - else if ( stomatal_model == ballberry_model ) then !stomatal conductance calculated from Ball et al. (1987) - aquad = leaf_co2_ppress - bquad = leaf_co2_ppress*(gb_mol - stomatal_intercept_btran) - bb_slope(ft) * a_gs * can_press - cquad = -gb_mol*(leaf_co2_ppress*stomatal_intercept_btran + & - bb_slope(ft)*anet*can_press * ceair/ veg_esat ) - - call quadratic_f (aquad, bquad, cquad, r1, r2) - gs_mol = max(r1,r2) - end if - - ! Derive new estimate for co2_inter_c - co2_inter_c = can_co2_ppress - anet * can_press * & - (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - - ! Check for co2_inter_c convergence. Delta co2_inter_c/pair = mol/mol. - ! Multiply by 10**6 to convert to umol/mol (ppm). Exit iteration if - ! convergence criteria of +/- 1 x 10**-6 ppm is met OR if at least ten - ! iterations (niter=10) are completed + ! ------------------------------------------------------------------------------------ + ! This subroutine calculates photosynthesis and stomatal conductance within each leaf + ! sublayer. + ! A note on naming conventions: As this subroutine is called for every + ! leaf-sublayer, many of the arguments are specific to that "leaf sub layer" + ! (LSL), those variables are given a dimension tag "_lsl" + ! Other arguments or variables may be indicative of scales broader than the LSL. + ! ------------------------------------------------------------------------------------ - if ((abs(co2_inter_c-co2_inter_c_old)/can_press*1.e06_r8 <= 2.e-06_r8) & - .or. niter == 5) then - loop_continue = .false. - end if - end do iter_loop - - ! End of co2_inter_c iteration. Check for an < 0, in which case gs_mol = bbb - ! And Final estimates for leaf_co2_ppress and co2_inter_c - ! (needed for early exit of co2_inter_c iteration when an < 0) - if (anet < 0._r8) then - gs_mol = stomatal_intercept_btran - end if - - ! Final estimates for leaf_co2_ppress and co2_inter_c - leaf_co2_ppress = can_co2_ppress - h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press - leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) - co2_inter_c = can_co2_ppress - anet * can_press * & - (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - - ! Convert gs_mol (umol /m**2/s) to gs (m/s) and then to rs (s/m) - gs = gs_mol / cf - - ! estimate carbon 13 discrimination in leaf level carbon - ! flux Liang WEI and Hang ZHOU 2018, based on - ! Ubierna and Farquhar, 2014 doi:10.1111/pce.12346, using the simplified model: - ! $\Delta ^{13} C = \alpha_s + (b - \alpha_s) \cdot \frac{C_i}{C_a}$ - ! just hard code b and \alpha_s for now, might move to parameter set in future - ! b = 27.0 alpha_s = 4.4 - ! TODO, not considering C4 or CAM right now, may need to address this - ! note co2_inter_c is intracelluar CO2, not intercelluar - c13disc_z = 4.4_r8 + (27.0_r8 - 4.4_r8) * & - min (can_co2_ppress, max (co2_inter_c, 0._r8)) / can_co2_ppress - - ! Accumulate total photosynthesis umol/m2 ground/s-1. - ! weight per unit sun and sha leaves. - if(sunsha == 1)then !sunlit - psn_out = psn_out + agross * f_sun_lsl - anet_av_out = anet_av_out + anet * f_sun_lsl - gstoma = gstoma + 1._r8/(min(1._r8/gs, rsmax0)) * f_sun_lsl - else - psn_out = psn_out + agross * (1.0_r8-f_sun_lsl) - anet_av_out = anet_av_out + anet * (1.0_r8-f_sun_lsl) - gstoma = gstoma + & - 1._r8/(min(1._r8/gs, rsmax0)) * (1.0_r8-f_sun_lsl) - end if - - ! Make sure iterative solution is correct - if (gs_mol < 0._r8) then - write (fates_log(),*)'Negative stomatal conductance:' - write (fates_log(),*)'gs_mol= ',gs_mol - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Compare with Medlyn model: gs_mol = 1.6*(1+m/sqrt(vpd)) * an/leaf_co2_ppress*p + b - if ( stomatal_model == 2 ) then - gs_mol_err = h2o_co2_stoma_diffuse_ratio*(1 + medlyn_slope(ft)/sqrt(vpd))*max(anet,0._r8)/leaf_co2_ppress*can_press + stomatal_intercept_btran - ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress*p + b - else if ( stomatal_model == 1 ) then - hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) - gs_mol_err = bb_slope(ft)*max(anet, 0._r8)*hs/leaf_co2_ppress*can_press + stomatal_intercept_btran - end if - - if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then - warn_msg = 'Stomatal conductance error check - weak convergence: '//trim(N2S(gs_mol))//' '//trim(N2S(gs_mol_err)) - call FatesWarn(warn_msg,index=1) - end if - - enddo !sunsha loop - - ! Stomatal resistance of the leaf-layer - if ( (hlm_use_planthydro.eq.itrue .and. EDPftvarcon_inst%hydr_k_lwp(ft)>nearzero) ) then - rstoma_out = LeafHumidityStomaResis(leaf_psi, veg_tempk, ceair, can_press, veg_esat, & - rb, gstoma, ft) - else - rstoma_out = 1._r8/gstoma - end if - - end if if_leafarea !is there leaf area? - - - end if if_daytime ! night or day + use EDParamsMod , only : theta_cj_c3, theta_cj_c4 - end associate - return + ! Arguments + ! ------------------------------------------------------------------------------------ + real(r8), intent(in) :: f_sun_lsl ! + real(r8), intent(in) :: parsun_lsl ! Absorbed PAR in sunlist leaves + real(r8), intent(in) :: parsha_lsl ! Absorved PAR in shaded leaves + real(r8), intent(in) :: laisun_lsl ! LAI in sunlit leaves + real(r8), intent(in) :: laisha_lsl ! LAI in shaded leaves + real(r8), intent(in) :: canopy_area_lsl ! + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) + real(r8), intent(in) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) + real(r8), intent(in) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) + real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8), intent(in) :: veg_esat ! saturation vapor pressure at veg_tempk (Pa) + + ! Important Note on the following gas pressures. This photosynthesis scheme will iteratively + ! solve for the co2 partial pressure at the leaf surface (ie in the stomata). The reference + ! point for these input values are NOT within that boundary layer that separates the stomata from + ! the canopy air space. The reference point for these is on the outside of that boundary + ! layer. This routine, which operates at the leaf scale, makes no assumptions about what the + ! scale of the refernce is, it could be lower atmosphere, it could be within the canopy + ! but most likely it is the closest value one can get to the edge of the leaf's boundary + ! layer. We use the convention "can_" because a reference point of within the canopy + ! ia a best reasonable scenario of where we can get that information from. + + real(r8), intent(in) :: can_press ! Air pressure NEAR the surface of the leaf (Pa) + real(r8), intent(in) :: can_co2_ppress ! Partial pressure of CO2 NEAR the leaf surface (Pa) + real(r8), intent(in) :: can_o2_ppress ! Partial pressure of O2 NEAR the leaf surface (Pa) + real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) + real(r8), intent(in) :: stomatal_intercept_btran !water-stressed minimum stomatal conductance (umol H2O/m**2/s) + real(r8), intent(in) :: cf ! s m**2/umol -> s/m (ideal gas conversion) [umol/m3] + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol /m**2/s) + real(r8), intent(in) :: ceair ! vapor pressure of air, constrained (Pa) + real(r8), intent(in) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) + real(r8), intent(in) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) + real(r8), intent(in) :: co2_cpoint ! CO2 compensation point (Pa) + real(r8), intent(in) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) + real(r8), intent(in) :: leaf_psi ! Leaf water potential [MPa] + real(r8), intent(in) :: rb ! Boundary Layer resistance of leaf [s/m] + + real(r8), intent(out) :: psn_out ! carbon assimilated in this leaf layer umolC/m2/s + real(r8), intent(out) :: rstoma_out ! stomatal resistance (1/gs_lsl) (s/m) + real(r8), intent(out) :: anet_av_out ! net leaf photosynthesis (umol CO2/m**2/s) + ! averaged over sun and shade leaves. + real(r8), intent(out) :: c13disc_z ! carbon 13 in newly assimilated carbon + + + + + ! Locals + ! ------------------------------------------------------------------------ + integer :: c3c4_path_index ! Index for which photosynthetic pathway + ! is active. C4 = 0, C3 = 1 + integer :: sunsha ! Index for differentiating sun and shade + real(r8) :: gstoma ! Stomatal Conductance of this leaf layer (m/s) + real(r8) :: agross ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: anet ! net leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: a_gs ! The assimilation (a) for calculating conductance (gs) + ! is either = to anet or agross + real(r8) :: je ! electron transport rate (umol electrons/m**2/s) + real(r8) :: qabs ! PAR absorbed by PS II (umol photons/m**2/s) + real(r8) :: aquad,bquad,cquad ! terms for quadratic equations + real(r8) :: r1,r2 ! roots of quadratic equation + real(r8) :: co2_inter_c ! intercellular leaf CO2 (Pa) + real(r8) :: co2_inter_c_old ! intercellular leaf CO2 (Pa) (previous iteration) + logical :: loop_continue ! Loop control variable + integer :: niter ! iteration loop index + real(r8) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) + real(r8) :: gs ! leaf stomatal conductance (m/s) + real(r8) :: hs ! fractional humidity at leaf surface (dimensionless) + real(r8) :: gs_mol_err ! gs_mol for error check + real(r8) :: ac ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) + real(r8) :: aj ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) + real(r8) :: ap ! product-limited (C3) or CO2-limited + ! (C4) gross photosynthesis (umol CO2/m**2/s) + real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) + real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) + real(r8) :: init_co2_inter_c ! First guess intercellular co2 specific to C path + real(r8) :: term ! intermediate variable in Medlyn stomatal conductance model + real(r8) :: vpd ! water vapor deficit in Medlyn stomatal model (KPa) + + + ! Parameters + ! ------------------------------------------------------------------------ + ! Fraction of light absorbed by non-photosynthetic pigments + real(r8),parameter :: fnps = 0.15_r8 + + ! For plants with no leaves, a miniscule amount of conductance + ! can happen through the stems, at a partial rate of cuticular conductance + real(r8),parameter :: stem_cuticle_loss_frac = 0.1_r8 + + ! empirical curvature parameter for electron transport rate + real(r8),parameter :: theta_psii = 0.7_r8 + + ! First guess on ratio between intercellular co2 and the atmosphere + ! an iterator converges on actual + real(r8),parameter :: init_a2l_co2_c3 = 0.7_r8 + real(r8),parameter :: init_a2l_co2_c4 = 0.4_r8 + + ! quantum efficiency, used only for C4 (mol CO2 / mol photons) (index 0) + real(r8),parameter,dimension(0:1) :: quant_eff = [0.05_r8,0.0_r8] + + ! empirical curvature parameter for ap photosynthesis co-limitation + real(r8),parameter :: theta_ip = 0.999_r8 + + associate( bb_slope => EDPftvarcon_inst%bb_slope ,& ! slope of BB relationship, unitless + medlyn_slope=> EDPftvarcon_inst%medlyn_slope , & ! Slope for Medlyn stomatal conductance model method, the unit is KPa^0.5 + stomatal_intercept=> EDPftvarcon_inst%stomatal_intercept ) !Unstressed minimum stomatal conductance, the unit is umol/m**2/s + + ! photosynthetic pathway: 0. = c4, 1. = c3 + c3c4_path_index = nint(EDPftvarcon_inst%c3psn(ft)) + + if (c3c4_path_index == c3_path_index) then + init_co2_inter_c = init_a2l_co2_c3 * can_co2_ppress + else + init_co2_inter_c = init_a2l_co2_c4 * can_co2_ppress + end if + + ! Part III: Photosynthesis and Conductance + ! ---------------------------------------------------------------------------------- + + if_daytime: if ( parsun_lsl <= 0._r8 ) then ! night time + + anet_av_out = -lmr + psn_out = 0._r8 + + ! The cuticular conductance already factored in maximum resistance as a bound + ! no need to re-bound it + + rstoma_out = cf/stomatal_intercept_btran + + c13disc_z = 0.0_r8 !carbon 13 discrimination in night time carbon flux, note value of 1.0 is used in CLM + + else ! day time (a little bit more complicated ...) + + ! Is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) + + if_leafarea: if ( laisun_lsl + laisha_lsl > 0._r8 ) then + + !Loop aroun shaded and unshaded leaves + psn_out = 0._r8 ! psn is accumulated across sun and shaded leaves. + rstoma_out = 0._r8 ! 1/rs is accumulated across sun and shaded leaves. + anet_av_out = 0._r8 + gstoma = 0._r8 + + do sunsha = 1,2 + ! Electron transport rate for C3 plants. + ! Convert par from W/m2 to umol photons/m**2/s using the factor 4.6 + ! Convert from units of par absorbed per unit ground area to par + ! absorbed per unit leaf area. + + if(sunsha == 1)then !sunlit + if(( laisun_lsl * canopy_area_lsl) > 0.0000000001_r8)then + + qabs = parsun_lsl / (laisun_lsl * canopy_area_lsl ) + qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 + + else + qabs = 0.0_r8 + end if + else + + qabs = parsha_lsl / (laisha_lsl * canopy_area_lsl) + qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 + + end if + + !convert the absorbed par into absorbed par per m2 of leaf, + ! so it is consistant with the vcmax and lmr numbers. + aquad = theta_psii + bquad = -(qabs + jmax) + cquad = qabs * jmax + call quadratic_f (aquad, bquad, cquad, r1, r2) + je = min(r1,r2) + + ! Initialize intercellular co2 + co2_inter_c = init_co2_inter_c + + niter = 0 + loop_continue = .true. + iter_loop: do while(loop_continue) + ! Increment iteration counter. Stop if too many iterations + niter = niter + 1 + + ! Save old co2_inter_c + co2_inter_c_old = co2_inter_c + + ! Photosynthesis limitation rate calculations + if (c3c4_path_index == c3_path_index)then + + ! C3: Rubisco-limited photosynthesis + ac = vcmax * max(co2_inter_c-co2_cpoint, 0._r8) / & + (co2_inter_c+mm_kco2 * (1._r8+can_o2_ppress / mm_ko2 )) + + ! C3: RuBP-limited photosynthesis + aj = je * max(co2_inter_c-co2_cpoint, 0._r8) / & + (4._r8*co2_inter_c+8._r8*co2_cpoint) + + ! Gross photosynthesis smoothing calculations. Co-limit ac and aj. + aquad = theta_cj_c3 + bquad = -(ac + aj) + cquad = ac * aj + call quadratic_f (aquad, bquad, cquad, r1, r2) + agross = min(r1,r2) + + else + + ! C4: Rubisco-limited photosynthesis + ac = vcmax + + ! C4: RuBP-limited photosynthesis + if(sunsha == 1)then !sunlit + !guard against /0's in the night. + if((laisun_lsl * canopy_area_lsl) > 0.0000000001_r8) then + aj = quant_eff(c3c4_path_index) * parsun_lsl * 4.6_r8 + !convert from per cohort to per m2 of leaf) + aj = aj / (laisun_lsl * canopy_area_lsl) + else + aj = 0._r8 + end if + else + aj = quant_eff(c3c4_path_index) * parsha_lsl * 4.6_r8 + aj = aj / (laisha_lsl * canopy_area_lsl) + end if + + ! C4: PEP carboxylase-limited (CO2-limited) + ap = co2_rcurve_islope * max(co2_inter_c, 0._r8) / can_press + + ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap + + aquad = theta_cj_c4 + bquad = -(ac + aj) + cquad = ac * aj + call quadratic_f (aquad, bquad, cquad, r1, r2) + ai = min(r1,r2) + + aquad = theta_ip + bquad = -(ai + ap) + cquad = ai * ap + call quadratic_f (aquad, bquad, cquad, r1, r2) + agross = min(r1,r2) + + end if + + ! Calculate anet, only exit iteration with negative anet when + ! using anet in calculating gs this is version B + anet = agross - lmr + + if ( stomatal_assim_model == gross_assim_model ) then + if ( stomatal_model == medlyn_model ) then + write (fates_log(),*) 'Gross Assimilation conductance is incompatible with the Medlyn model' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + a_gs = agross + else + if (anet < 0._r8) then + loop_continue = .false. + end if + a_gs = anet + end if + + ! With an <= 0, then gs_mol = stomatal_intercept_btran + leaf_co2_ppress = can_co2_ppress- h2o_co2_bl_diffuse_ratio/gb_mol * a_gs * can_press + leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + + if ( stomatal_model == medlyn_model ) then + !stomatal conductance calculated from Medlyn et al. (2011), the numerical & + !implementation was adapted from the equations in CLM5.0 + vpd = max((veg_esat - ceair), 50._r8) * 0.001_r8 !addapted from CLM5. Put some constraint on VPD + !when Medlyn stomatal conductance is being used, the unit is KPa. Ignoring the constraint will cause errors when model runs. + term = h2o_co2_stoma_diffuse_ratio * anet / (leaf_co2_ppress / can_press) + aquad = 1.0_r8 + bquad = -(2.0 * (stomatal_intercept_btran+ term) + (medlyn_slope(ft) * term)**2 / & + (gb_mol * vpd )) + cquad = stomatal_intercept_btran*stomatal_intercept_btran + & + (2.0*stomatal_intercept_btran + term * & + (1.0 - medlyn_slope(ft)* medlyn_slope(ft) / vpd)) * term + + call quadratic_f (aquad, bquad, cquad, r1, r2) + gs_mol = max(r1,r2) + + else if ( stomatal_model == ballberry_model ) then !stomatal conductance calculated from Ball et al. (1987) + aquad = leaf_co2_ppress + bquad = leaf_co2_ppress*(gb_mol - stomatal_intercept_btran) - bb_slope(ft) * a_gs * can_press + cquad = -gb_mol*(leaf_co2_ppress*stomatal_intercept_btran + & + bb_slope(ft)*anet*can_press * ceair/ veg_esat ) + + call quadratic_f (aquad, bquad, cquad, r1, r2) + gs_mol = max(r1,r2) + end if + + ! Derive new estimate for co2_inter_c + co2_inter_c = can_co2_ppress - anet * can_press * & + (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) + + ! Check for co2_inter_c convergence. Delta co2_inter_c/pair = mol/mol. + ! Multiply by 10**6 to convert to umol/mol (ppm). Exit iteration if + ! convergence criteria of +/- 1 x 10**-6 ppm is met OR if at least ten + ! iterations (niter=10) are completed + + if ((abs(co2_inter_c-co2_inter_c_old)/can_press*1.e06_r8 <= 2.e-06_r8) & + .or. niter == 5) then + loop_continue = .false. + end if + end do iter_loop + + ! End of co2_inter_c iteration. Check for an < 0, in which case gs_mol = bbb + ! And Final estimates for leaf_co2_ppress and co2_inter_c + ! (needed for early exit of co2_inter_c iteration when an < 0) + if (anet < 0._r8) then + gs_mol = stomatal_intercept_btran + end if + + ! Final estimates for leaf_co2_ppress and co2_inter_c + leaf_co2_ppress = can_co2_ppress - h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press + leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + co2_inter_c = can_co2_ppress - anet * can_press * & + (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) + + ! Convert gs_mol (umol /m**2/s) to gs (m/s) and then to rs (s/m) + gs = gs_mol / cf + + ! estimate carbon 13 discrimination in leaf level carbon + ! flux Liang WEI and Hang ZHOU 2018, based on + ! Ubierna and Farquhar, 2014 doi:10.1111/pce.12346, using the simplified model: + ! $\Delta ^{13} C = \alpha_s + (b - \alpha_s) \cdot \frac{C_i}{C_a}$ + ! just hard code b and \alpha_s for now, might move to parameter set in future + ! b = 27.0 alpha_s = 4.4 + ! TODO, not considering C4 or CAM right now, may need to address this + ! note co2_inter_c is intracelluar CO2, not intercelluar + c13disc_z = 4.4_r8 + (27.0_r8 - 4.4_r8) * & + min (can_co2_ppress, max (co2_inter_c, 0._r8)) / can_co2_ppress + + ! Accumulate total photosynthesis umol/m2 ground/s-1. + ! weight per unit sun and sha leaves. + if(sunsha == 1)then !sunlit + psn_out = psn_out + agross * f_sun_lsl + anet_av_out = anet_av_out + anet * f_sun_lsl + gstoma = gstoma + 1._r8/(min(1._r8/gs, rsmax0)) * f_sun_lsl + else + psn_out = psn_out + agross * (1.0_r8-f_sun_lsl) + anet_av_out = anet_av_out + anet * (1.0_r8-f_sun_lsl) + gstoma = gstoma + & + 1._r8/(min(1._r8/gs, rsmax0)) * (1.0_r8-f_sun_lsl) + end if + + ! Make sure iterative solution is correct + if (gs_mol < 0._r8) then + write (fates_log(),*)'Negative stomatal conductance:' + write (fates_log(),*)'gs_mol= ',gs_mol + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Compare with Medlyn model: gs_mol = 1.6*(1+m/sqrt(vpd)) * an/leaf_co2_ppress*p + b + if ( stomatal_model == 2 ) then + gs_mol_err = h2o_co2_stoma_diffuse_ratio*(1 + medlyn_slope(ft)/sqrt(vpd))*max(anet,0._r8)/leaf_co2_ppress*can_press + stomatal_intercept_btran + ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress*p + b + else if ( stomatal_model == 1 ) then + hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) + gs_mol_err = bb_slope(ft)*max(anet, 0._r8)*hs/leaf_co2_ppress*can_press + stomatal_intercept_btran + end if + + if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then + warn_msg = 'Stomatal conductance error check - weak convergence: '//trim(N2S(gs_mol))//' '//trim(N2S(gs_mol_err)) + call FatesWarn(warn_msg,index=1) + end if + + enddo !sunsha loop + + ! Stomatal resistance of the leaf-layer + if ( (hlm_use_planthydro.eq.itrue .and. EDPftvarcon_inst%hydr_k_lwp(ft)>nearzero) ) then + rstoma_out = LeafHumidityStomaResis(leaf_psi, veg_tempk, ceair, can_press, veg_esat, & + rb, gstoma, ft) + else + rstoma_out = 1._r8/gstoma + end if + + + else + + ! No leaf area. This layer is present only because of stems. + ! Net assimilation is zero, not negative because there are + ! no leaves to even respire + ! (leaves are off, or have reduced to 0) + + psn_out = 0._r8 + anet_av_out = 0._r8 + + rstoma_out = min(rsmax0,cf/(stem_cuticle_loss_frac*stomatal_intercept(ft))) + c13disc_z = 0.0_r8 + + end if if_leafarea !is there leaf area? + + + end if if_daytime ! night or day + + + end associate + return end subroutine LeafLayerPhotosynthesis ! ======================================================================================= From 140e6ff4ad15c32c6a3e3399186c7db31f62c20b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 18 Dec 2023 11:07:44 -0700 Subject: [PATCH 229/250] b4b for two-stream --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index c396329e85..6853742e5c 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -280,7 +280,6 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8),dimension(75) :: cohort_layer_tsai real(r8) :: cohort_elai real(r8) :: cohort_esai - real(r8) :: elai_layer real(r8) :: laisun,laisha real(r8) :: canopy_area real(r8) :: elai @@ -613,7 +612,6 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! laisun: m2 of exposed leaf, per m2 of crown. If this is the lowest layer ! for the pft/canopy group, than the m2 per crown is probably not ! as large as the layer above. - ! elai_layer: the exposed lai of the layer per m2 of crown (should be laisun+laisha) ! ------------------------------------------------------------------ if_radsolver: if(radiation_model.eq.norman_solver) then @@ -645,12 +643,12 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) laisun = (fsun*cohort_layer_elai(iv)) laisha = ((1._r8 - fsun)*cohort_layer_elai(iv)) if(fsun>nearzero) then - par_per_sunla = (rd_abs_leaf*fsun + rb_abs_leaf) / laisun + par_per_sunla = (rd_abs_leaf*fsun + rb_abs_leaf)! / laisun else par_per_sunla = 0._r8 end if - par_per_shala = rd_abs_leaf*(1._r8-fsun) / laisha - canopy_area = currentPatch%canopy_area_profile(cl,ft,iv) + par_per_shala = rd_abs_leaf*(1._r8-fsun) !/ laisha + canopy_area = 1._r8 !currentPatch%canopy_area_profile(cl,ft,iv) else @@ -658,13 +656,11 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) par_per_shala = 0._r8 laisun = (fsun*cohort_layer_elai(iv)) laisha = ((1._r8 - fsun)*cohort_layer_elai(iv)) - canopy_area = currentPatch%canopy_area_profile(cl,ft,iv) + canopy_area = 1._r8 !currentPatch%canopy_area_profile(cl,ft,iv) fsun = 0.5_r8 !avoid div0, should have no impact end if - elai_layer = cohort_layer_elai(iv) - end if if_radsolver ! Part VII: Calculate (1) maximum rate of carboxylation (vcmax), From b83584d92741944b2b005c009e74a57ad49b763c Mon Sep 17 00:00:00 2001 From: Marcos Longo Date: Tue, 19 Dec 2023 06:57:15 -0300 Subject: [PATCH 230/250] Updated parameter file with complete description for stress/drought-deciduous. --- parameter_files/fates_params_default.cdl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index f170fe2275..58f294bcce 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -469,7 +469,7 @@ variables: fates_phen_stem_drop_fraction:long_name = "fraction of stems to drop for non-woody species during drought/cold" ; double fates_phen_stress_decid(fates_pft) ; fates_phen_stress_decid:units = "logical flag" ; - fates_phen_stress_decid:long_name = "Binary flag for stress-deciduous leaf habit" ; + fates_phen_stress_decid:long_name = "Flag for stress/drought-deciduous leaf habit. 0 - not stress deciduous; 1 - default drought deciduous (two target states only, fully flushed or fully abscised); 2 - semi-deciduous" ; double fates_prescribed_npp_canopy(fates_pft) ; fates_prescribed_npp_canopy:units = "kgC / m^2 / yr" ; fates_prescribed_npp_canopy:long_name = "NPP per unit crown area of canopy trees for prescribed physiology mode" ; From 36105c35304d243b30de3820fe4df1c4143a9bbc Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 19 Dec 2023 10:53:48 -0700 Subject: [PATCH 231/250] more b4b stuff --- radiation/FatesRadiationDriveMod.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index 8c20f6d526..a64c0856af 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -163,13 +163,13 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) if_nrad: if (maxval(currentPatch%nrad(1,:))==0)then ! there are no leaf layers in this patch. it is effectively bare ground. + bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 + bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 currentPatch%radiation_error = 0.0_r8 do ib = 1,hlm_numSWb bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) - bc_out(s)%fabd_parb(ifp,ib) = 0.0_r8 - bc_out(s)%fabi_parb(ifp,ib) = 0.0_r8 bc_out(s)%ftdd_parb(ifp,ib) = 1.0_r8 bc_out(s)%ftid_parb(ifp,ib) = 0.0_r8 bc_out(s)%ftii_parb(ifp,ib) = 1.0_r8 @@ -328,11 +328,6 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) shalai = shalai + sum(cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft))) else do iv = 1,cpatch%nrad(cl,ft) - sunlai = sunlai + cpatch%elai_profile(cl,ft,iv) * & - cpatch%f_sun(cl,ft,iv) - shalai = shalai + cpatch%elai_profile(cl,ft,iv) * & - (1._r8 - cpatch%f_sun(cl,ft,iv)) - cpatch%ed_laisun_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & cpatch%f_sun(CL,ft,iv) @@ -340,6 +335,11 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) (1._r8 - cpatch%f_sun(CL,ft,iv)) end do + + !needed for the VOC emissions, etc. + sunlai = sunlai + sum(cpatch%ed_laisun_z(CL,ft,1:cpatch%nrad(CL,ft))) + shalai = shalai + sum(cpatch%ed_laisha_z(CL,ft,1:cpatch%nrad(CL,ft))) + end if end do end do From 312593f98be4b0cae96f99ec413381238800987a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 20 Dec 2023 15:39:54 -0700 Subject: [PATCH 232/250] revert history to match main --- main/FatesHistoryInterfaceMod.F90 | 477 +++++++++++++++++++++++------- 1 file changed, 374 insertions(+), 103 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 9fb901d5c1..c985b427f3 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -84,7 +84,7 @@ module FatesHistoryInterfaceMod use FatesConstantsMod , only : dens_fresh_liquid_water use FatesConstantsMod , only : grav_earth use FatesLitterMod , only : litter_type - use FatesConstantsMod , only : secondaryforest + use FatesConstantsMod , only : secondaryland use PRTGenericMod , only : leaf_organ, fnrt_organ, sapw_organ use PRTGenericMod , only : struct_organ, store_organ, repro_organ @@ -308,13 +308,11 @@ module FatesHistoryInterfaceMod integer :: ih_growth_resp_secondary_si integer :: ih_primaryland_fusion_error_si - integer :: ih_disturbance_rate_p2p_si - integer :: ih_disturbance_rate_p2s_si - integer :: ih_disturbance_rate_s2s_si + integer :: ih_area_si_landuse + integer :: ih_disturbance_rate_si_lulu integer :: ih_fire_disturbance_rate_si integer :: ih_logging_disturbance_rate_si integer :: ih_fall_disturbance_rate_si - integer :: ih_potential_disturbance_rate_si integer :: ih_harvest_carbonflux_si integer :: ih_harvest_debt_si integer :: ih_harvest_debt_sec_si @@ -606,7 +604,7 @@ module FatesHistoryInterfaceMod integer :: ih_c_stomata_si_age integer :: ih_c_lblayer_si_age integer :: ih_agesince_anthrodist_si_age - integer :: ih_secondaryforest_area_si_age + integer :: ih_secondarylands_area_si_age integer :: ih_area_burnt_si_age ! integer :: ih_fire_rate_of_spread_front_si_age integer :: ih_fire_intensity_si_age @@ -678,12 +676,26 @@ module FatesHistoryInterfaceMod ! indices to (site x [canopy layer x leaf layer]) variables integer :: ih_parsun_z_si_cnlf integer :: ih_parsha_z_si_cnlf + integer :: ih_laisun_z_si_cnlf + integer :: ih_laisha_z_si_cnlf + integer :: ih_fabd_sun_si_cnlf + integer :: ih_fabd_sha_si_cnlf + integer :: ih_fabi_sun_si_cnlf + integer :: ih_fabi_sha_si_cnlf integer :: ih_ts_net_uptake_si_cnlf integer :: ih_crownarea_si_cnlf + integer :: ih_parprof_dir_si_cnlf + integer :: ih_parprof_dif_si_cnlf ! indices to (site x [canopy layer x leaf layer x pft]) variables integer :: ih_parsun_z_si_cnlfpft integer :: ih_parsha_z_si_cnlfpft + integer :: ih_laisun_z_si_cnlfpft + integer :: ih_laisha_z_si_cnlfpft + integer :: ih_fabd_sun_si_cnlfpft + integer :: ih_fabd_sha_si_cnlfpft + integer :: ih_fabi_sun_si_cnlfpft + integer :: ih_fabi_sha_si_cnlfpft integer :: ih_parprof_dir_si_cnlfpft integer :: ih_parprof_dif_si_cnlfpft @@ -713,6 +725,12 @@ module FatesHistoryInterfaceMod ! indices to (site x canopy layer) variables integer :: ih_parsun_top_si_can integer :: ih_parsha_top_si_can + integer :: ih_laisun_top_si_can + integer :: ih_laisha_top_si_can + integer :: ih_fabd_sun_top_si_can + integer :: ih_fabd_sha_top_si_can + integer :: ih_fabi_sun_top_si_can + integer :: ih_fabi_sha_top_si_can integer :: ih_crownarea_si_can ! indices to (patch age x fuel size class) variables @@ -751,6 +769,7 @@ module FatesHistoryInterfaceMod integer, private :: levelcwd_index_, levelage_index_ integer, private :: levcacls_index_, levcapf_index_ integer, private :: levclscpf_index_ + integer, private :: levlanduse_index_, levlulu_index_, levlupft_index_ contains @@ -760,8 +779,7 @@ module FatesHistoryInterfaceMod procedure :: assemble_history_output_types procedure :: update_history_dyn - procedure :: update_history_hifrq_simple - procedure :: update_history_hifrq_multi + procedure :: update_history_hifrq procedure :: update_history_hydraulics procedure :: update_history_nutrflux @@ -794,6 +812,9 @@ module FatesHistoryInterfaceMod procedure :: levelage_index procedure :: levagefuel_index procedure :: levclscpf_index + procedure :: levlanduse_index + procedure :: levlulu_index + procedure :: levlupft_index ! private work functions procedure, private :: define_history_vars @@ -822,6 +843,9 @@ module FatesHistoryInterfaceMod procedure, private :: set_levheight_index procedure, private :: set_levagefuel_index procedure, private :: set_levclscpf_index + procedure, private :: set_levlanduse_index + procedure, private :: set_levlulu_index + procedure, private :: set_levlupft_index procedure, private :: set_levelem_index procedure, private :: set_levelpft_index @@ -860,6 +884,7 @@ subroutine Init(this, num_threads, fates_bounds) use FatesIODimensionsMod, only : levelem, levelpft use FatesIODimensionsMod, only : levelcwd, levelage, levclscpf use FatesIODimensionsMod, only : levcdpf, levcdsc, levcdam + use FatesIODimensionsMod, only : levlanduse, levlulu, levlupft implicit none @@ -999,6 +1024,21 @@ subroutine Init(this, num_threads, fates_bounds) call this%dim_bounds(dim_count)%Init(levclscpf, num_threads, & fates_bounds%clscpf_begin, fates_bounds%clscpf_end) + dim_count = dim_count + 1 + call this%set_levlanduse_index(dim_count) + call this%dim_bounds(dim_count)%Init(levlanduse, num_threads, & + fates_bounds%landuse_begin, fates_bounds%landuse_end) + + dim_count = dim_count + 1 + call this%set_levlulu_index(dim_count) + call this%dim_bounds(dim_count)%Init(levlulu, num_threads, & + fates_bounds%lulu_begin, fates_bounds%lulu_end) + + dim_count = dim_count + 1 + call this%set_levlupft_index(dim_count) + call this%dim_bounds(dim_count)%Init(levlupft, num_threads, & + fates_bounds%lupft_begin, fates_bounds%lupft_end) + end subroutine Init ! ====================================================================== @@ -1119,6 +1159,18 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%clscpf_begin, thread_bounds%clscpf_end) + index = this%levlanduse_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%landuse_begin, thread_bounds%landuse_end) + + index = this%levlulu_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%lulu_begin, thread_bounds%lulu_end) + + index = this%levlupft_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%lupft_begin, thread_bounds%lupft_end) + end subroutine SetThreadBoundsEach ! =================================================================================== @@ -1134,6 +1186,7 @@ subroutine assemble_history_output_types(this) use FatesIOVariableKindMod, only : site_elem_r8, site_elpft_r8 use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8, site_clscpf_r8 use FatesIOVariableKindMod, only : site_cdpf_r8, site_cdsc_r8, site_cdam_r8 + use FatesIOVariableKindMod, only : site_landuse_r8, site_lulu_r8, site_lupft_r8 implicit none @@ -1217,7 +1270,16 @@ subroutine assemble_history_output_types(this) call this%set_dim_indices(site_clscpf_r8, 1, this%column_index()) call this%set_dim_indices(site_clscpf_r8, 2, this%levclscpf_index()) - + + call this%set_dim_indices(site_landuse_r8, 1, this%column_index()) + call this%set_dim_indices(site_landuse_r8, 2, this%levlanduse_index()) + + call this%set_dim_indices(site_lulu_r8, 1, this%column_index()) + call this%set_dim_indices(site_lulu_r8, 2, this%levlulu_index()) + + call this%set_dim_indices(site_lupft_r8, 1, this%column_index()) + call this%set_dim_indices(site_lupft_r8, 2, this%levlupft_index()) + end subroutine assemble_history_output_types ! =================================================================================== @@ -1631,6 +1693,51 @@ end function levclscpf_index ! ====================================================================================== + subroutine set_levlanduse_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levlanduse_index_ = index + end subroutine set_levlanduse_index + + integer function levlanduse_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levlanduse_index = this%levlanduse_index_ + end function levlanduse_index + + ! ====================================================================================== + + subroutine set_levlulu_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levlulu_index_ = index + end subroutine set_levlulu_index + + integer function levlulu_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levlulu_index = this%levlulu_index_ + end function levlulu_index + + ! ====================================================================================== + + subroutine set_levlupft_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levlupft_index_ = index + end subroutine set_levlupft_index + + integer function levlupft_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levlupft_index = this%levlupft_index_ + end function levlupft_index + + ! ====================================================================================== + subroutine zero_site_hvars(this, currentSite, upfreq_in) ! This routine zero's a history diagnostic variable @@ -1777,6 +1884,7 @@ subroutine init_dim_kinds_maps(this) use FatesIOVariableKindMod, only : site_elem_r8, site_elpft_r8 use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8, site_clscpf_r8 use FatesIOVariableKindMod, only : site_cdpf_r8, site_cdsc_r8, site_cdam_r8 + use FatesIOVariableKindMod, only : site_landuse_r8, site_lulu_r8, site_lupft_r8 implicit none @@ -1890,6 +1998,18 @@ subroutine init_dim_kinds_maps(this) index = index + 1 call this%dim_kinds(index)%Init(site_clscpf_r8, 2) + ! site x land use class + index = index + 1 + call this%dim_kinds(index)%Init(site_landuse_r8, 2) + + ! site x land use x land use class + index = index + 1 + call this%dim_kinds(index)%Init(site_lulu_r8, 2) + + ! site x land use x pft + index = index + 1 + call this%dim_kinds(index)%Init(site_lupft_r8, 2) + ! FIXME(bja, 2016-10) assert(index == fates_history_num_dim_kinds) end subroutine init_dim_kinds_maps @@ -2098,6 +2218,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) use FatesLitterMod , only : ncwd use FatesConstantsMod , only : ican_upper use FatesConstantsMod , only : ican_ustory + use FatesConstantsMod , only : n_landuse_cats use FatesSizeAgeTypeIndicesMod, only : get_sizeage_class_index use FatesSizeAgeTypeIndicesMod, only : get_sizeagepft_class_index use FatesSizeAgeTypeIndicesMod, only : get_agepft_class_index @@ -2193,6 +2314,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) real(r8) :: storec_understory_scpf(numpft*nlevsclass) integer :: return_code + integer :: i_dist, j_dist type(fates_patch_type),pointer :: cpatch type(fates_cohort_type),pointer :: ccohort @@ -2267,13 +2389,10 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_canopy_biomass_si => this%hvars(ih_canopy_biomass_si)%r81d, & hio_understory_biomass_si => this%hvars(ih_understory_biomass_si)%r81d, & hio_primaryland_fusion_error_si => this%hvars(ih_primaryland_fusion_error_si)%r81d, & - hio_disturbance_rate_p2p_si => this%hvars(ih_disturbance_rate_p2p_si)%r81d, & - hio_disturbance_rate_p2s_si => this%hvars(ih_disturbance_rate_p2s_si)%r81d, & - hio_disturbance_rate_s2s_si => this%hvars(ih_disturbance_rate_s2s_si)%r81d, & + hio_disturbance_rate_si_lulu => this%hvars(ih_disturbance_rate_si_lulu)%r82d, & hio_fire_disturbance_rate_si => this%hvars(ih_fire_disturbance_rate_si)%r81d, & hio_logging_disturbance_rate_si => this%hvars(ih_logging_disturbance_rate_si)%r81d, & hio_fall_disturbance_rate_si => this%hvars(ih_fall_disturbance_rate_si)%r81d, & - hio_potential_disturbance_rate_si => this%hvars(ih_potential_disturbance_rate_si)%r81d, & hio_harvest_carbonflux_si => this%hvars(ih_harvest_carbonflux_si)%r81d, & hio_harvest_debt_si => this%hvars(ih_harvest_debt_si)%r81d, & hio_harvest_debt_sec_si => this%hvars(ih_harvest_debt_sec_si)%r81d, & @@ -2430,6 +2549,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_yesterdaycanopylevel_canopy_si_scls => this%hvars(ih_yesterdaycanopylevel_canopy_si_scls)%r82d, & hio_yesterdaycanopylevel_understory_si_scls => this%hvars(ih_yesterdaycanopylevel_understory_si_scls)%r82d, & hio_area_si_age => this%hvars(ih_area_si_age)%r82d, & + hio_area_si_landuse => this%hvars(ih_area_si_landuse)%r82d, & hio_lai_si_age => this%hvars(ih_lai_si_age)%r82d, & hio_lai_secondary_si => this%hvars(ih_lai_secondary_si)%r81d, & hio_canopy_area_si_age => this%hvars(ih_canopy_area_si_age)%r82d, & @@ -2441,7 +2561,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_biomass_secondary_forest_si => this%hvars(ih_biomass_secondary_forest_si)%r81d, & hio_woodproduct_si => this%hvars(ih_woodproduct_si)%r81d, & hio_agesince_anthrodist_si_age => this%hvars(ih_agesince_anthrodist_si_age)%r82d, & - hio_secondaryforest_area_si_age => this%hvars(ih_secondaryforest_area_si_age)%r82d, & + hio_secondarylands_area_si_age => this%hvars(ih_secondarylands_area_si_age)%r82d, & hio_area_burnt_si_age => this%hvars(ih_area_burnt_si_age)%r82d, & ! hio_fire_rate_of_spread_front_si_age => this%hvars(ih_fire_rate_of_spread_front_si_age)%r82d, & hio_fire_intensity_si_age => this%hvars(ih_fire_intensity_si_age)%r82d, & @@ -2624,27 +2744,24 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! error in primary lands from patch fusion [m2 m-2 day-1] -> [m2 m-2 yr-1] hio_primaryland_fusion_error_si(io_si) = sites(s)%primary_land_patchfusion_error * days_per_year - ! output site-level disturbance rates [m2 m-2 day-1] -> [m2 m-2 yr-1] - hio_disturbance_rate_p2p_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_primary(1:N_DIST_TYPES)) * days_per_year - hio_disturbance_rate_p2s_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_secondary(1:N_DIST_TYPES)) * days_per_year - hio_disturbance_rate_s2s_si(io_si) = sum(sites(s)%disturbance_rates_secondary_to_secondary(1:N_DIST_TYPES)) * days_per_year + ! roll up disturbance rates in land-use x land-use array into a single dimension + do i_dist = 1, n_landuse_cats + do j_dist = 1, n_landuse_cats + hio_disturbance_rate_si_lulu(io_si, i_dist+n_landuse_cats*(j_dist-1)) = sum(sites(s)%disturbance_rates(1:n_dist_types,i_dist, j_dist)) * & + days_per_year + end do + end do - hio_fire_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ifire) + & - sites(s)%disturbance_rates_primary_to_secondary(dtype_ifire) + & - sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifire)) * & - days_per_year + ! output site-level disturbance rates [m2 m-2 day-1] -> [m2 m-2 yr-1] - TO DO rework this - hio_logging_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ilog) + & - sites(s)%disturbance_rates_primary_to_secondary(dtype_ilog) + & - sites(s)%disturbance_rates_secondary_to_secondary(dtype_ilog)) * & - days_per_year + hio_fire_disturbance_rate_si(io_si) = sum(sites(s)%disturbance_rates(dtype_ifire,1:n_landuse_cats,1:n_landuse_cats)) * & + days_per_year - hio_fall_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ifall) + & - sites(s)%disturbance_rates_primary_to_secondary(dtype_ifall) + & - sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifall)) * & - days_per_year + hio_logging_disturbance_rate_si(io_si) = sum(sites(s)%disturbance_rates(dtype_ilog,1:n_landuse_cats,1:n_landuse_cats)) * & + days_per_year - hio_potential_disturbance_rate_si(io_si) = sum(sites(s)%potential_disturbance_rates(1:N_DIST_TYPES)) * days_per_year + hio_fall_disturbance_rate_si(io_si) = sum(sites(s)%disturbance_rates(dtype_ifall,1:n_landuse_cats,1:n_landuse_cats)) * & + days_per_year hio_harvest_carbonflux_si(io_si) = sites(s)%mass_balance(element_pos(carbon12_element))%wood_product * AREA_INV @@ -2655,7 +2772,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! Increment the number of patches per site hio_npatches_si(io_si) = hio_npatches_si(io_si) + 1._r8 - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_npatches_sec_si(io_si) = hio_npatches_sec_si(io_si) + 1._r8 end if @@ -2665,6 +2782,9 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_area_si_age(io_si,cpatch%age_class) = hio_area_si_age(io_si,cpatch%age_class) & + cpatch%area * AREA_INV + hio_area_si_landuse(io_si, cpatch%land_use_label) = hio_area_si_landuse(io_si, cpatch%land_use_label)& + + cpatch%area * AREA_INV + ! 24hr veg temperature hio_tveg24(io_si) = hio_tveg24(io_si) + & (cpatch%tveg24%GetMean()- t_water_freeze_k_1atm)*cpatch%area*AREA_INV @@ -2694,7 +2814,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) endif ! some diagnostics on secondary forest area and its age distribution - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_fraction_secondary_forest_si(io_si) = hio_fraction_secondary_forest_si(io_si) + & cpatch%area * AREA_INV @@ -2704,13 +2824,10 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_agesince_anthrodist_si_age(io_si,ageclass_since_anthrodist) & + cpatch%area * AREA_INV - hio_secondaryforest_area_si_age(io_si,cpatch%age_class) = & - hio_secondaryforest_area_si_age(io_si,cpatch%age_class) & + hio_secondarylands_area_si_age(io_si,cpatch%age_class) = & + hio_secondarylands_area_si_age(io_si,cpatch%age_class) & + cpatch%area * AREA_INV - endif - ! Secondary forest mean LAI - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then hio_lai_secondary_si(io_si) = hio_lai_secondary_si(io_si) & + sum(cpatch%tlai_profile(:,:,:)) * cpatch%total_canopy_area end if @@ -2780,7 +2897,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) ! Increment the number of cohorts per site hio_ncohorts_si(io_si) = hio_ncohorts_si(io_si) + 1._r8 - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_ncohorts_sec_si(io_si) = hio_ncohorts_sec_si(io_si) + 1._r8 end if @@ -2896,7 +3013,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_nindivs_si_pft(io_si,ft) = hio_nindivs_si_pft(io_si,ft) + & ccohort%n * AREA_INV - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_nindivs_sec_si_pft(io_si,ft) = hio_nindivs_sec_si_pft(io_si,ft) + & ccohort%n * AREA_INV end if @@ -2904,7 +3021,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & (ccohort%n * AREA_INV) * total_m - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_biomass_sec_si_pft(io_si, ft) = hio_biomass_sec_si_pft(io_si, ft) + & (ccohort%n * AREA_INV) * total_m end if @@ -2914,7 +3031,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) + total_m * ccohort%n * AREA_INV ! track the total biomass on all secondary lands - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_biomass_secondary_forest_si(io_si) = hio_biomass_secondary_forest_si(io_si) + & total_m * ccohort%n * AREA_INV endif @@ -3044,7 +3161,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_npp_si_pft(io_si, ft) = hio_npp_si_pft(io_si, ft) + & ccohort%npp_acc_hold * n_perm2 / days_per_year / sec_per_day - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_gpp_sec_si_pft(io_si, ft) = hio_gpp_sec_si_pft(io_si, ft) + & ccohort%gpp_acc_hold * n_perm2 / days_per_year / sec_per_day hio_npp_sec_si_pft(io_si, ft) = hio_npp_sec_si_pft(io_si, ft) + & @@ -3185,7 +3302,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_m9_si_scls(io_si,scls) = hio_m9_si_scls(io_si,scls) + ccohort%smort*ccohort%n / m2_per_ha ! Examine secondary forest mortality and mortality rates - if(cpatch%anthro_disturbance_label .eq. secondaryforest) then + if(cpatch%land_use_label .eq. secondaryland) then if (hlm_use_cohort_age_tracking .eq.itrue) then hio_m10_sec_si_scls(io_si,scls) = hio_m10_sec_si_scls(io_si,scls) + & @@ -3497,7 +3614,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) hio_m3_mortality_understory_si_scpf(io_si,scpf) = hio_m3_mortality_understory_si_scpf(io_si,scpf) + & ccohort%cmort * ccohort%n / m2_per_ha - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_mortality_canopy_secondary_si_scls(io_si,scls) = hio_mortality_canopy_secondary_si_scls(io_si,scls) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & @@ -3817,7 +3934,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) sites(s)%fmort_rate_canopy(i_scls, i_pft) / m2_per_ha ! Shijie: Think about how to add later? - !if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + !if ( cpatch%land_use_label .eq. secondaryland ) then ! hio_mortality_canopy_secondary_si_scls(io_si,i_scls) = hio_mortality_canopy_secondary_si_scls(io_si,i_scls) + & ! sites(s)%term_nindivs_canopy(i_scls,i_pft) * days_per_year / m2_per_ha !end if @@ -4367,24 +4484,7 @@ subroutine update_history_dyn(this,nc,nsites,sites,bc_in) return end subroutine update_history_dyn - subroutine update_history_hifrq_multi(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) - ! - ! Arguments - class(fates_history_interface_type) :: this - integer , intent(in) :: nc ! clump index - integer , intent(in) :: nsites - type(ed_site_type) , intent(inout), target :: sites(nsites) - type(bc_in_type) , intent(in) :: bc_in(nsites) - type(bc_out_type) , intent(in) :: bc_out(nsites) - real(r8) , intent(in) :: dt_tstep - - ! This is just a dummy file for compatibility - - return - end subroutine update_history_hifrq_multi - - - subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) + subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ! --------------------------------------------------------------------------------- ! This is the call to update the history IO arrays that are expected to only change @@ -4399,7 +4499,6 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) type(bc_in_type) , intent(in) :: bc_in(nsites) - type(bc_out_type) , intent(in) :: bc_out(nsites) real(r8) , intent(in) :: dt_tstep ! Locals @@ -4422,8 +4521,7 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste type(fates_patch_type),pointer :: cpatch type(fates_cohort_type),pointer :: ccohort real(r8) :: per_dt_tstep ! Time step in frequency units (/s) - real(r8) :: clllpf_area - + associate( hio_gpp_si => this%hvars(ih_gpp_si)%r81d, & hio_gpp_secondary_si => this%hvars(ih_gpp_secondary_si)%r81d, & hio_npp_si => this%hvars(ih_npp_si)%r81d, & @@ -4475,8 +4573,28 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste hio_ts_net_uptake_si_cnlf => this%hvars(ih_ts_net_uptake_si_cnlf)%r82d, & hio_parsun_z_si_cnlfpft => this%hvars(ih_parsun_z_si_cnlfpft)%r82d, & hio_parsha_z_si_cnlfpft => this%hvars(ih_parsha_z_si_cnlfpft)%r82d, & + hio_laisun_z_si_cnlf => this%hvars(ih_laisun_z_si_cnlf)%r82d, & + hio_laisha_z_si_cnlf => this%hvars(ih_laisha_z_si_cnlf)%r82d, & + hio_laisun_z_si_cnlfpft => this%hvars(ih_laisun_z_si_cnlfpft)%r82d, & + hio_laisha_z_si_cnlfpft => this%hvars(ih_laisha_z_si_cnlfpft)%r82d, & + hio_laisun_top_si_can => this%hvars(ih_laisun_top_si_can)%r82d, & + hio_laisha_top_si_can => this%hvars(ih_laisha_top_si_can)%r82d, & + hio_fabd_sun_si_cnlfpft => this%hvars(ih_fabd_sun_si_cnlfpft)%r82d, & + hio_fabd_sha_si_cnlfpft => this%hvars(ih_fabd_sha_si_cnlfpft)%r82d, & + hio_fabi_sun_si_cnlfpft => this%hvars(ih_fabi_sun_si_cnlfpft)%r82d, & + hio_fabi_sha_si_cnlfpft => this%hvars(ih_fabi_sha_si_cnlfpft)%r82d, & + hio_fabd_sun_si_cnlf => this%hvars(ih_fabd_sun_si_cnlf)%r82d, & + hio_fabd_sha_si_cnlf => this%hvars(ih_fabd_sha_si_cnlf)%r82d, & + hio_fabi_sun_si_cnlf => this%hvars(ih_fabi_sun_si_cnlf)%r82d, & + hio_fabi_sha_si_cnlf => this%hvars(ih_fabi_sha_si_cnlf)%r82d, & + hio_parprof_dir_si_cnlf => this%hvars(ih_parprof_dir_si_cnlf)%r82d, & + hio_parprof_dif_si_cnlf => this%hvars(ih_parprof_dif_si_cnlf)%r82d, & hio_parprof_dir_si_cnlfpft => this%hvars(ih_parprof_dir_si_cnlfpft)%r82d, & hio_parprof_dif_si_cnlfpft => this%hvars(ih_parprof_dif_si_cnlfpft)%r82d, & + hio_fabd_sun_top_si_can => this%hvars(ih_fabd_sun_top_si_can)%r82d, & + hio_fabd_sha_top_si_can => this%hvars(ih_fabd_sha_top_si_can)%r82d, & + hio_fabi_sun_top_si_can => this%hvars(ih_fabi_sun_top_si_can)%r82d, & + hio_fabi_sha_top_si_can => this%hvars(ih_fabi_sha_top_si_can)%r82d, & hio_parsun_top_si_can => this%hvars(ih_parsun_top_si_can)%r82d, & hio_parsha_top_si_can => this%hvars(ih_parsha_top_si_can)%r82d, & hio_maint_resp_unreduced_si => this%hvars(ih_maint_resp_unreduced_si)%r81d, & @@ -4574,7 +4692,7 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste ccohort%resp_m_unreduced * n_perm2 * per_dt_tstep ! Secondary forest only - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + if ( cpatch%land_use_label .eq. secondaryland ) then hio_npp_secondary_si(io_si) = hio_npp_secondary_si(io_si) + & npp * n_perm2 * per_dt_tstep hio_gpp_secondary_si(io_si) = hio_gpp_secondary_si(io_si) + & @@ -4709,8 +4827,6 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste ! calculate where we are on multiplexed dimensions cnlfpft_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax cnlf_indx = ileaf + (ican-1) * nlevleaf - - clllpf_area = cpatch%canopy_area_profile(ican,ipft,ileaf)*cpatch%total_canopy_area ! ! first do all the canopy x leaf x pft calculations hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) + & @@ -4718,6 +4834,20 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) + & cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV ! + hio_laisun_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_laisun_z_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_laisha_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_laisha_z_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + ! + hio_fabd_sun_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabd_sun_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabd_sha_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabd_sha_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabi_sun_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabi_sun_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabi_sha_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabi_sha_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + ! hio_parprof_dir_si_cnlfpft(io_si,cnlfpft_indx) = hio_parprof_dir_si_cnlfpft(io_si,cnlfpft_indx) + & cpatch%parprof_pft_dir_z(ican,ipft,ileaf) * cpatch%area * AREA_INV hio_parprof_dif_si_cnlfpft(io_si,cnlfpft_indx) = hio_parprof_dif_si_cnlfpft(io_si,cnlfpft_indx) + & @@ -4728,6 +4858,20 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV hio_parsha_z_si_cnlf(io_si,cnlf_indx) = hio_parsha_z_si_cnlf(io_si,cnlf_indx) + & cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + ! + hio_laisun_z_si_cnlf(io_si,cnlf_indx) = hio_laisun_z_si_cnlf(io_si,cnlf_indx) + & + cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_laisha_z_si_cnlf(io_si,cnlf_indx) = hio_laisha_z_si_cnlf(io_si,cnlf_indx) + & + cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + ! + hio_fabd_sun_si_cnlf(io_si,cnlf_indx) = hio_fabd_sun_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabd_sha_si_cnlf(io_si,cnlf_indx) = hio_fabd_sha_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabi_sun_si_cnlf(io_si,cnlf_indx) = hio_fabi_sun_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabi_sha_si_cnlf(io_si,cnlf_indx) = hio_fabi_sha_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV end do ! @@ -4736,9 +4880,35 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste cpatch%ed_parsun_z(ican,ipft,1) * cpatch%area * AREA_INV hio_parsha_top_si_can(io_si,ican) = hio_parsha_top_si_can(io_si,ican) + & cpatch%ed_parsha_z(ican,ipft,1) * cpatch%area * AREA_INV + ! + hio_laisun_top_si_can(io_si,ican) = hio_laisun_top_si_can(io_si,ican) + & + cpatch%ed_laisun_z(ican,ipft,1) * cpatch%area * AREA_INV + hio_laisha_top_si_can(io_si,ican) = hio_laisha_top_si_can(io_si,ican) + & + cpatch%ed_laisha_z(ican,ipft,1) * cpatch%area * AREA_INV + ! + hio_fabd_sun_top_si_can(io_si,ican) = hio_fabd_sun_top_si_can(io_si,ican) + & + cpatch%fabd_sun_z(ican,ipft,1) * cpatch%area * AREA_INV + hio_fabd_sha_top_si_can(io_si,ican) = hio_fabd_sha_top_si_can(io_si,ican) + & + cpatch%fabd_sha_z(ican,ipft,1) * cpatch%area * AREA_INV + hio_fabi_sun_top_si_can(io_si,ican) = hio_fabi_sun_top_si_can(io_si,ican) + & + cpatch%fabi_sun_z(ican,ipft,1) * cpatch%area * AREA_INV + hio_fabi_sha_top_si_can(io_si,ican) = hio_fabi_sha_top_si_can(io_si,ican) + & + cpatch%fabi_sha_z(ican,ipft,1) * cpatch%area * AREA_INV + ! + end do + end do + ! PFT-mean radiation profiles + do ican = 1, cpatch%ncl_p + do ileaf = 1, maxval(cpatch%nrad(ican,:)) + ! calculate where we are on multiplexed dimensions + cnlf_indx = ileaf + (ican-1) * nlevleaf ! + hio_parprof_dir_si_cnlf(io_si,cnlf_indx) = hio_parprof_dir_si_cnlf(io_si,cnlf_indx) + & + cpatch%parprof_dir_z(ican,ileaf) * cpatch%area * AREA_INV + hio_parprof_dif_si_cnlf(io_si,cnlf_indx) = hio_parprof_dif_si_cnlf(io_si,cnlf_indx) + & + cpatch%parprof_dif_z(ican,ileaf) * cpatch%area * AREA_INV end do end do @@ -4782,11 +4952,8 @@ subroutine update_history_hifrq_simple(this,nc,nsites,sites,bc_in,bc_out,dt_tste end associate - end subroutine update_history_hifrq_simple - +end subroutine update_history_hifrq - - ! ===================================================================================== subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) @@ -5211,6 +5378,7 @@ subroutine define_history_vars(this, initialize_variables) use FatesIOVariableKindMod, only : site_scagpft_r8, site_agepft_r8 use FatesIOVariableKindMod, only : site_elem_r8, site_elpft_r8, site_clscpf_r8 use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8 + use FatesIOVariableKindMod, only : site_landuse_r8, site_lulu_r8 implicit none @@ -5591,6 +5759,17 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index=ih_biomass_si_age) + ! land use type resolved variables + call this%set_history_var(vname='FATES_PATCHAREA_LU', units='m2 m-2', & + long='patch area by land use type', use_default='active', & + avgflag='A', vtype=site_landuse_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index=ih_area_si_landuse) + + call this%set_history_var(vname='FATES_DISTURBANCE_RATE_MATRIX_LULU', units='m2 m-2 yr-1', & + long='disturbance rates by land use type x land use type matrix', use_default='active', & + avgflag='A', vtype=site_lulu_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index=ih_disturbance_rate_si_lulu) + ! Secondary forest area and age diagnostics call this%set_history_var(vname='FATES_SECONDARY_FOREST_FRACTION', & @@ -5624,7 +5803,7 @@ subroutine define_history_vars(this, initialize_variables) long='secondary forest patch area age distribution since any kind of disturbance', & use_default='inactive', avgflag='A', vtype=site_age_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & - index=ih_secondaryforest_area_si_age) + index=ih_secondarylands_area_si_age) ! Fire Variables @@ -6267,27 +6446,6 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_primaryland_fusion_error_si) - call this%set_history_var(vname='FATES_DISTURBANCE_RATE_P2P', & - units='m2 m-2 yr-1', & - long='disturbance rate from primary to primary lands', & - use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_disturbance_rate_p2p_si) - - call this%set_history_var(vname='FATES_DISTURBANCE_RATE_P2S', & - units='m2 m-2 yr-1', & - long='disturbance rate from primary to secondary lands', & - use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_disturbance_rate_p2s_si ) - - call this%set_history_var(vname='FATES_DISTURBANCE_RATE_S2S', & - units='m2 m-2 yr-1', & - long='disturbance rate from secondary to secondary lands', & - use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_disturbance_rate_s2s_si) - call this%set_history_var(vname='FATES_DISTURBANCE_RATE_FIRE', & units='m2 m-2 yr-1', long='disturbance rate from fire', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & @@ -6306,13 +6464,6 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_fall_disturbance_rate_si) - call this%set_history_var(vname='FATES_DISTURBANCE_RATE_POTENTIAL', & - units='m2 m-2 yr-1', & - long='potential (i.e., including unresolved) disturbance rate', & - use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_potential_disturbance_rate_si) - call this%set_history_var(vname='FATES_HARVEST_CARBON_FLUX', & units='kg m-2 yr-1', & long='harvest carbon flux in kg carbon per m2 per year', & @@ -6553,6 +6704,90 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_parsha_top_si_can) + call this%set_history_var(vname='FATES_LAISUN_Z_CLLL', units='m2 m-2', & + long='LAI in the sun by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisun_z_si_cnlf) + + call this%set_history_var(vname='FATES_LAISHA_Z_CLLL', units='m2 m-2', & + long='LAI in the shade by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisha_z_si_cnlf) + + call this%set_history_var(vname='FATES_LAISUN_Z_CLLLPF', units='m2 m-2', & + long='LAI in the sun by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisun_z_si_cnlfpft) + + call this%set_history_var(vname='FATES_LAISHA_Z_CLLLPF', units='m2 m-2', & + long='LAI in the shade by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisha_z_si_cnlfpft) + + call this%set_history_var(vname='FATES_LAISUN_TOP_CL', units='m2 m-2', & + long='LAI in the sun by the top leaf layer of each canopy layer', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisun_top_si_can) + + call this%set_history_var(vname='FATES_LAISHA_TOP_CL', units='m2 m-2', & + long='LAI in the shade by the top leaf layer of each canopy layer', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisha_top_si_can) + + call this%set_history_var(vname='FATES_FABD_SUN_CLLLPF', units='1', & + long='sun fraction of direct light absorbed by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sun_si_cnlfpft) + + call this%set_history_var(vname='FATES_FABD_SHA_CLLLPF', units='1', & + long='shade fraction of direct light absorbed by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sha_si_cnlfpft) + + call this%set_history_var(vname='FATES_FABI_SUN_CLLLPF', units='1', & + long='sun fraction of indirect light absorbed by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sun_si_cnlfpft) + + call this%set_history_var(vname='FATES_FABI_SHA_CLLLPF', units='1', & + long='shade fraction of indirect light absorbed by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sha_si_cnlfpft) + + call this%set_history_var(vname='FATES_FABD_SUN_CLLL', units='1', & + long='sun fraction of direct light absorbed by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sun_si_cnlf) + + call this%set_history_var(vname='FATES_FABD_SHA_CLLL', units='1', & + long='shade fraction of direct light absorbed by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sha_si_cnlf) + + call this%set_history_var(vname='FATES_FABI_SUN_CLLL', units='1', & + long='sun fraction of indirect light absorbed by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sun_si_cnlf) + + call this%set_history_var(vname='FATES_FABI_SHA_CLLL', units='1', & + long='shade fraction of indirect light absorbed by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sha_si_cnlf) + call this%set_history_var(vname='FATES_PARPROF_DIR_CLLLPF', units='W m-2', & long='radiative profile of direct PAR through each canopy, leaf, and PFT', & use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & @@ -6565,6 +6800,42 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_parprof_dif_si_cnlfpft) + call this%set_history_var(vname='FATES_PARPROF_DIR_CLLL', units='W m-2', & + long='radiative profile of direct PAR through each canopy and leaf layer (averaged across PFTs)', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parprof_dir_si_cnlf) + + call this%set_history_var(vname='FATES_PARPROF_DIF_CLLL', units='W m-2', & + long='radiative profile of diffuse PAR through each canopy and leaf layer (averaged across PFTs)', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parprof_dif_si_cnlf) + + call this%set_history_var(vname='FATES_FABD_SUN_TOPLF_CL', units='1', & + long='sun fraction of direct light absorbed by the top leaf layer of each canopy layer', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sun_top_si_can) + + call this%set_history_var(vname='FATES_FABD_SHA_TOPLF_CL', units='1', & + long='shade fraction of direct light absorbed by the top leaf layer of each canopy layer', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sha_top_si_can) + + call this%set_history_var(vname='FATES_FABI_SUN_TOPLF_CL', units='1', & + long='sun fraction of indirect light absorbed by the top leaf layer of each canopy layer', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sun_top_si_can) + + call this%set_history_var(vname='FATES_FABI_SHA_TOPLF_CL', units='1', & + long='shade fraction of indirect light absorbed by the top leaf layer of each canopy layer', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sha_top_si_can) + !!! canopy-resolved fluxes and structure call this%set_history_var(vname='FATES_NET_C_UPTAKE_CLLL', & From 62a37f9ea5805c83e4975bd3443c84b63a39b6bf Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 20 Dec 2023 15:58:55 -0700 Subject: [PATCH 233/250] removed solver error (redundant with conservation error) --- main/FatesRestartInterfaceMod.F90 | 3 +-- radiation/FatesNormanRadMod.F90 | 4 ++-- radiation/FatesRadiationDriveMod.F90 | 2 -- radiation/TwoStreamMLPEMod.F90 | 8 -------- 4 files changed, 3 insertions(+), 14 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 320ea3f926..27e9264535 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -3678,8 +3678,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 - currentPatch%solve_err(:) = hlm_hio_ignore_val - currentPatch%consv_err(:) = hlm_hio_ignore_val + currentPatch%consv_err(:) = 0._r8 ! ----------------------------------------------------------- ! When calling norman radiation from the short-timestep diff --git a/radiation/FatesNormanRadMod.F90 b/radiation/FatesNormanRadMod.F90 index 7da38a34ce..c0b14baf05 100644 --- a/radiation/FatesNormanRadMod.F90 +++ b/radiation/FatesNormanRadMod.F90 @@ -478,8 +478,8 @@ subroutine PatchNormanRadiation (currentPatch, & end do!L ! Zero out the radiation error for the current patch before conducting the conservation check - currentPatch%radiation_error = 0.0_r8 - + currentPatch%radiation_error = 0._r8 + do ib = 1,hlm_numSWb Dif_dn(:,:,:) = 0.00_r8 Dif_up(:,:,:) = 0.00_r8 diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index a64c0856af..28a5cec08b 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -121,7 +121,6 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 - currentPatch%solve_err(:) = hlm_hio_ignore_val currentPatch%consv_err(:) = hlm_hio_ignore_val currentPatch%solar_zenith_flag = bc_in(s)%filter_vegzen_pa(ifp) @@ -209,7 +208,6 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) sites(s)%ipiv_2str, & ! inout (scratch) bc_out(s)%albd_parb(ifp,ib), & ! out bc_out(s)%albi_parb(ifp,ib), & ! out - currentPatch%solve_err(ib), & ! out currentPatch%consv_err(ib), & ! out bc_out(s)%fabd_parb(ifp,ib), & ! out bc_out(s)%fabi_parb(ifp,ib), & ! out diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index ca2900646c..05d4bd04c4 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -1060,7 +1060,6 @@ subroutine Solve(this, ib, & ipiv, & albedo_beam, & albedo_diff, & - solve_err, & consv_err, & frac_abs_can_beam, & frac_abs_can_diff, & @@ -1104,10 +1103,6 @@ subroutine Solve(this, ib, & real(r8) :: albedo_diff ! Mean albedo at canopy top generated from downwelling diffuse [-] real(r8) :: temp_err ! Used to build the other error terms, a temp - real(r8) :: solve_err ! This is the maximum error encountered when comparing the forward solution - ! of the linear solution A*x, to the known b, in Ax=b. This is the maximum - ! considering all equations, and both beam and diffuse boundaries. Units - ! are a fraction relative to the boundary flux. real(r8) :: consv_err ! radiation canopy balance conservation ! error, fraction of incident @@ -1210,8 +1205,6 @@ subroutine Solve(this, ib, & ! upper canopy. ! -------------------------------------------------------------------------- - solve_err = 0._r8 - if((Rbeam_atm+Rdiff_atm)rel_err_thresh)then write(log_unit,*) 'Poor forward solution on two-stream solver' write(log_unit,*) 'isol (1=beam or 2=diff): ',isol From 893d8cfa7d433330c2a3d71924017937bf0c7c6f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 21 Dec 2023 12:51:35 -0700 Subject: [PATCH 234/250] merge updates on two-stream with luh2, as well as consolidation of radiation error --- biogeochem/EDPatchDynamicsMod.F90 | 5 +++-- biogeochem/FatesPatchMod.F90 | 8 +++---- main/FatesHistoryInterfaceMod.F90 | 33 ++-------------------------- main/FatesRestartInterfaceMod.F90 | 5 ++--- radiation/FatesNormanRadMod.F90 | 9 ++++---- radiation/FatesRadiationDriveMod.F90 | 14 +++++++----- 6 files changed, 24 insertions(+), 50 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index ec234bef76..3fbdab801c 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2773,8 +2773,9 @@ subroutine fuse_2_patches(csite, dp, rp) rp%zstar = (dp%zstar*dp%area + rp%zstar*rp%area) * inv_sum_area rp%c_stomata = (dp%c_stomata*dp%area + rp%c_stomata*rp%area) * inv_sum_area rp%c_lblayer = (dp%c_lblayer*dp%area + rp%c_lblayer*rp%area) * inv_sum_area - rp%radiation_error = (dp%radiation_error*dp%area + rp%radiation_error*rp%area) * inv_sum_area - + rp%rad_error(1) = (dp%rad_error(1)*dp%area + rp%rad_error(1)*rp%area) * inv_sum_area + rp%rad_error(2) = (dp%rad_error(2)*dp%area + rp%rad_error(2)*rp%area) * inv_sum_area + rp%area = rp%area + dp%area !THIS MUST COME AT THE END! !insert donor cohorts into recipient patch diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index 61136e3872..8b6ed70620 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -121,7 +121,7 @@ module FatesPatchMod !--------------------------------------------------------------------------- ! RADIATION - real(r8) :: radiation_error ! radiation error [W/m2] + real(r8) :: rad_error(num_swb) ! radiation consv error by band [W/m2] real(r8) :: fcansno ! fraction of canopy covered in snow [0-1] logical :: solar_zenith_flag ! integer flag specifying daylight (based on zenith angle) real(r8) :: solar_zenith_angle ! solar zenith angle [radians] @@ -155,7 +155,7 @@ module FatesPatchMod real(r8), allocatable :: sabs_dif(:) ! fraction of incoming diffuse radiation that is absorbed by the canopy ! Twostream data structures - type(twostream_type) :: twostr ! This holds all two-stream data for the patch + class(twostream_type),pointer :: twostr ! This holds all two-stream data and procedures !--------------------------------------------------------------------------- @@ -327,7 +327,7 @@ subroutine NanValues(this) this%nrmlzd_parprof_pft_dif_z(:,:,:,:) = nan ! RADIATION - this%radiation_error = nan + this%rad_error(:) = nan this%fcansno = nan this%solar_zenith_flag = .false. this%solar_zenith_angle = nan @@ -418,7 +418,7 @@ subroutine ZeroValues(this) this%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0.0_r8 ! RADIATION - this%radiation_error = 0.0_r8 + this%rad_error(:) = 0.0_r8 this%fabd_sun_z(:,:,:) = 0.0_r8 this%fabd_sha_z(:,:,:) = 0.0_r8 this%fabi_sun_z(:,:,:) = 0.0_r8 diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index c985b427f3..41ab2ca1b6 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -14,6 +14,7 @@ module FatesHistoryInterfaceMod use FatesGlobals , only : endrun => fates_endrun use EDParamsMod , only : nclmax, maxpft use FatesConstantsMod , only : ican_upper + use FatesRadiationMemMod , only : num_swb use PRTGenericMod , only : element_pos use PRTGenericMod , only : num_elements use PRTGenericMod , only : prt_cnp_flex_allom_hyp @@ -684,8 +685,6 @@ module FatesHistoryInterfaceMod integer :: ih_fabi_sha_si_cnlf integer :: ih_ts_net_uptake_si_cnlf integer :: ih_crownarea_si_cnlf - integer :: ih_parprof_dir_si_cnlf - integer :: ih_parprof_dif_si_cnlf ! indices to (site x [canopy layer x leaf layer x pft]) variables integer :: ih_parsun_z_si_cnlfpft @@ -4587,8 +4586,6 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_fabd_sha_si_cnlf => this%hvars(ih_fabd_sha_si_cnlf)%r82d, & hio_fabi_sun_si_cnlf => this%hvars(ih_fabi_sun_si_cnlf)%r82d, & hio_fabi_sha_si_cnlf => this%hvars(ih_fabi_sha_si_cnlf)%r82d, & - hio_parprof_dir_si_cnlf => this%hvars(ih_parprof_dir_si_cnlf)%r82d, & - hio_parprof_dif_si_cnlf => this%hvars(ih_parprof_dif_si_cnlf)%r82d, & hio_parprof_dir_si_cnlfpft => this%hvars(ih_parprof_dir_si_cnlfpft)%r82d, & hio_parprof_dif_si_cnlfpft => this%hvars(ih_parprof_dif_si_cnlfpft)%r82d, & hio_fabd_sun_top_si_can => this%hvars(ih_fabd_sun_top_si_can)%r82d, & @@ -4650,7 +4647,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) cpatch%c_lblayer * cpatch%total_canopy_area * mol_per_umol hio_rad_error_si(io_si) = hio_rad_error_si(io_si) + & - cpatch%radiation_error * cpatch%area * AREA_INV + max(abs(cpatch%rad_error(1)),abs(cpatch%rad_error(2))) * cpatch%area * AREA_INV ! Only accumulate the instantaneous vegetation temperature for vegetated patches if (cpatch%patchno .ne. 0) then @@ -4898,20 +4895,6 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) end do end do - ! PFT-mean radiation profiles - do ican = 1, cpatch%ncl_p - do ileaf = 1, maxval(cpatch%nrad(ican,:)) - - ! calculate where we are on multiplexed dimensions - cnlf_indx = ileaf + (ican-1) * nlevleaf - ! - hio_parprof_dir_si_cnlf(io_si,cnlf_indx) = hio_parprof_dir_si_cnlf(io_si,cnlf_indx) + & - cpatch%parprof_dir_z(ican,ileaf) * cpatch%area * AREA_INV - hio_parprof_dif_si_cnlf(io_si,cnlf_indx) = hio_parprof_dif_si_cnlf(io_si,cnlf_indx) + & - cpatch%parprof_dif_z(ican,ileaf) * cpatch%area * AREA_INV - end do - end do - ipa = ipa + 1 cpatch => cpatch%younger end do !patch loop @@ -6800,18 +6783,6 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_parprof_dif_si_cnlfpft) - call this%set_history_var(vname='FATES_PARPROF_DIR_CLLL', units='W m-2', & - long='radiative profile of direct PAR through each canopy and leaf layer (averaged across PFTs)', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_parprof_dir_si_cnlf) - - call this%set_history_var(vname='FATES_PARPROF_DIF_CLLL', units='W m-2', & - long='radiative profile of diffuse PAR through each canopy and leaf layer (averaged across PFTs)', & - use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & - hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_parprof_dif_si_cnlf) - call this%set_history_var(vname='FATES_FABD_SUN_TOPLF_CL', units='1', & long='sun fraction of direct light absorbed by the top leaf layer of each canopy layer', & use_default='inactive', avgflag='A', vtype=site_can_r8, & diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 27e9264535..161321d352 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -3678,7 +3678,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 - currentPatch%consv_err(:) = 0._r8 + currentPatch%rad_error(:) = 0._r8 ! ----------------------------------------------------------- ! When calling norman radiation from the short-timestep @@ -3745,8 +3745,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) sites(s)%ipiv_2str, & ! inout (scratch) bc_out(s)%albd_parb(ifp,ib), & ! out bc_out(s)%albi_parb(ifp,ib), & ! out - currentPatch%solve_err(ib), & ! out - currentPatch%consv_err(ib), & ! out + currentPatch%rad_error(ib), & ! out bc_out(s)%fabd_parb(ifp,ib), & ! out bc_out(s)%fabi_parb(ifp,ib), & ! out bc_out(s)%ftdd_parb(ifp,ib), & ! out diff --git a/radiation/FatesNormanRadMod.F90 b/radiation/FatesNormanRadMod.F90 index c0b14baf05..af9aa65659 100644 --- a/radiation/FatesNormanRadMod.F90 +++ b/radiation/FatesNormanRadMod.F90 @@ -477,10 +477,10 @@ subroutine PatchNormanRadiation (currentPatch, & end do!ft end do!L - ! Zero out the radiation error for the current patch before conducting the conservation check - currentPatch%radiation_error = 0._r8 - do ib = 1,hlm_numSWb + + currentPatch%rad_error(ib) = 0._r8 + Dif_dn(:,:,:) = 0.00_r8 Dif_up(:,:,:) = 0.00_r8 do L = 1, currentPatch%NCL_p !work down from the top of the canopy. @@ -899,8 +899,9 @@ subroutine PatchNormanRadiation (currentPatch, & if ( (currentPatch%total_canopy_area / currentPatch%area) .gt. tolerance ) then ! normalize rad error by the veg-covered fraction of the patch because that is ! the only part that this code applies to - currentPatch%radiation_error = currentPatch%radiation_error + error & + currentPatch%rad_error(ib) = currentPatch%rad_error(ib) + error & * currentPatch%total_canopy_area / currentPatch%area + endif lai_reduction(:) = 0.0_r8 diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index 28a5cec08b..2773b46c8a 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -121,7 +121,7 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 - currentPatch%consv_err(:) = hlm_hio_ignore_val + currentPatch%rad_error(:) = hlm_hio_ignore_val currentPatch%solar_zenith_flag = bc_in(s)%filter_vegzen_pa(ifp) currentPatch%solar_zenith_angle = bc_in(s)%coszen_pa(ifp) @@ -164,7 +164,7 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) ! there are no leaf layers in this patch. it is effectively bare ground. bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 - currentPatch%radiation_error = 0.0_r8 + currentPatch%rad_error(:) = 0.0_r8 do ib = 1,hlm_numSWb bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) @@ -208,7 +208,7 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) sites(s)%ipiv_2str, & ! inout (scratch) bc_out(s)%albd_parb(ifp,ib), & ! out bc_out(s)%albi_parb(ifp,ib), & ! out - currentPatch%consv_err(ib), & ! out + currentPatch%rad_error(ib), & ! out bc_out(s)%fabd_parb(ifp,ib), & ! out bc_out(s)%fabi_parb(ifp,ib), & ! out bc_out(s)%ftdd_parb(ifp,ib), & ! out @@ -385,9 +385,11 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) end do !cl ! Convert normalized radiation error units from fraction of radiation to W/m2 - cpatch%radiation_error = cpatch%radiation_error * (bc_in(s)%solad_parb(ifp,ipar) + & - bc_in(s)%solai_parb(ifp,ipar)) - + do ib = 1,num_swb + cpatch%rad_error(ib) = cpatch%rad_error(ib) * & + (bc_in(s)%solad_parb(ifp,ib) + bc_in(s)%solai_parb(ifp,ib)) + end do + ! output the actual PAR profiles through the canopy for diagnostic purposes do cl = 1, cpatch%ncl_p do ft = 1,numpft From b743547dac5e488b1252ded4753904d6256dc9e3 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 22 Dec 2023 09:34:44 -0700 Subject: [PATCH 235/250] two-stream cleaning up --- biogeochem/FatesPatchMod.F90 | 2 +- biogeophys/FatesPlantRespPhotosynthMod.F90 | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index 8b6ed70620..cd96c86004 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -155,7 +155,7 @@ module FatesPatchMod real(r8), allocatable :: sabs_dif(:) ! fraction of incoming diffuse radiation that is absorbed by the canopy ! Twostream data structures - class(twostream_type),pointer :: twostr ! This holds all two-stream data and procedures + type(twostream_type) :: twostr ! This holds all two-stream data and procedures !--------------------------------------------------------------------------- diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 6853742e5c..a70b76d116 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -654,8 +654,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) par_per_sunla = 0._r8 par_per_shala = 0._r8 - laisun = (fsun*cohort_layer_elai(iv)) - laisha = ((1._r8 - fsun)*cohort_layer_elai(iv)) + laisun = 0.5_r8*cohort_layer_elai(iv) + laisha = 0.5_r8*cohort_layer_elai(iv) canopy_area = 1._r8 !currentPatch%canopy_area_profile(cl,ft,iv) fsun = 0.5_r8 !avoid div0, should have no impact From 03668195d4537f40d3c104550340b76ddcafe1f0 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 27 Dec 2023 12:44:22 -0700 Subject: [PATCH 236/250] adding text around preserve_b4b --- biogeochem/EDCanopyStructureMod.F90 | 4 ++ biogeochem/FatesAllometryMod.F90 | 71 ---------------------- biogeophys/FatesPlantRespPhotosynthMod.F90 | 7 ++- main/EDInitMod.F90 | 9 ++- radiation/FatesRadiationDriveMod.F90 | 9 ++- 5 files changed, 20 insertions(+), 80 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 31bab561ef..b5b87e8f0c 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1586,6 +1586,8 @@ subroutine leaf_area_profile( currentSite ) ! How much of each tree is stem area index? Assuming that there is ! This may indeed be zero if there is a sensecent grass ! ---------------------------------------------------------------- + ! preserve_b4b will be removed soon. This is kept here to prevent + ! round off errors in the baseline tests for the two-stream code (RGK 12-27-23) if_preserve_b4b: if(preserve_b4b) then lai = currentCohort%treelai * currentCohort%c_area/currentPatch%total_canopy_area sai = currentCohort%treesai * currentCohort%c_area/currentPatch%total_canopy_area @@ -1809,6 +1811,8 @@ subroutine leaf_area_profile( currentSite ) ! -------------------------------------------------------------------------- currentPatch%canopy_mask(:,:) = 0 + ! preserve_b4b will be removed soon. This is kept here to prevent + ! round off errors in the baseline tests for the two-stream code (RGK 12-27-23) if(preserve_b4b) then do cl = 1,currentPatch%NCL_p do ft = 1,numpft diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index 07e6c4c836..9cc8fbe4fd 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -2627,77 +2627,6 @@ subroutine VegAreaLayer(tree_lai,tree_sai,tree_height,iv,nv,pft,snow_depth, & integer, parameter :: layer_height_const_lad = 2 ! constant leaf area depth assumption integer, parameter :: layer_height_method = layer_height_const_depth - - logical, parameter :: preserve_b4b = .true. - - - if_preserve_b4b: if(preserve_b4b) then - - if( (tree_lai+tree_sai) > nearzero)then - - ! lai = tree_lai * currentCohort%c_area/currentPatch%total_canopy_area - ! sai = tree_sai * currentCohort%c_area/currentPatch%total_canopy_area - - ! See issue: https://github.com/NGEET/fates/issues/899 - ! fleaf = currentCohort%treelai / (currentCohort%treelai + currentCohort%treesai) - fleaf = tree_lai / (tree_lai+tree_sai) - else - fleaf = 0._r8 - endif - - if(iv==0)then ! Whole plant (not just specific layer) - - layer_top_height = tree_height - layer_bot_height = tree_height - ( tree_height * prt_params%crown_depth_frac(pft) ) - - else - - layer_top_height = tree_height - ( real(iv-1,r8)/nv * tree_height * & - prt_params%crown_depth_frac(pft) ) - - layer_bot_height = tree_height - ( real(iv,r8)/nv * tree_height * & - prt_params%crown_depth_frac(pft) ) - end if - - fraction_exposed = 1.0_r8 - if(snow_depth > layer_top_height)then - fraction_exposed = 0._r8 - endif - if(snow_depth < layer_bot_height)then - fraction_exposed = 1._r8 - endif - if(snow_depth >= layer_bot_height .and. & - snow_depth <= layer_top_height) then !only partly hidden... - fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(snow_depth -layer_bot_height)/ & - (layer_top_height-layer_bot_height )))) - endif - - if(iv==0) then - remainder = tree_lai+tree_sai - elseif(iv==nv) then - remainder = (tree_lai + tree_sai) - & - (dlower_vai(iv) - dinc_vai(iv)) - if(remainder > dinc_vai(iv) )then - write(fates_log(), *)'ED: issue with remainder', & - tree_lai,tree_sai,dinc_vai(iv), & - nv,remainder - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - else - remainder = dinc_vai(iv) - end if - - if(present(tlai_layer)) tlai_layer = remainder * fleaf !* currentCohort%c_area/currentPatch%total_canopy_area - if(present(tsai_layer)) tsai_layer = remainder * (1._r8-fleaf) !* currentCohort%c_area/currentPatch%total_canopy_area - elai_layer = fraction_exposed * remainder * fleaf - esai_layer = fraction_exposed * remainder * (1._r8-fleaf) - - - return - - end if if_preserve_b4b - - tree_vai = tree_lai + tree_sai if_any_vai: if(tree_vai>0._r8)then diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index a70b76d116..53a61be5df 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -1015,7 +1015,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! Normalize canopy total conductance by the effective LAI ! The value here was integrated over each cohort x leaf layer ! and was weighted by m2 of effective leaf area for each layer - + ! preserve_b4b will be removed soon. This is kept here to prevent + ! round off errors in the baseline tests for the two-stream code (RGK 12-27-23) if(preserve_b4b) then patch_la = patch_la/ currentPatch%total_canopy_area end if @@ -1029,7 +1030,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! Normalize the leaf-area weighted canopy conductance ! The denominator is the total effective leaf area in the canopy, ! units of [m/s]*[m2] / [m2] = [m/s] - + ! preserve_b4b will be removed soon. This is kept here to prevent + ! round off errors in the baseline tests for the two-stream code (RGK 12-27-23) if_preserve_b4b3: if(preserve_b4b) then elai = calc_areaindex(currentPatch,'elai') g_sb_leaves = g_sb_leaves / (elai*currentPatch%total_canopy_area) @@ -2433,7 +2435,6 @@ subroutine LeafLayerBiophysicalRates( parsun_per_la, & vcmaxc = fth25_f(vcmaxhd, vcmaxse) jmaxc = fth25_f(jmaxhd, jmaxse) - !!if ( parsun_per_la <= nearzero) then ! night time [preserve_b4b] if(parsun_per_la <= 0._r8) then vcmax = 0._r8 jmax = 0._r8 diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index ad72efdd8d..fd44f07bbe 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -19,7 +19,6 @@ module EDInitMod use FatesGlobals , only : fates_log use FatesInterfaceTypesMod , only : hlm_is_restart use FatesInterfaceTypesMod , only : hlm_current_tod - use FatesInterfaceTypesMod , only : hlm_numSWb use EDPftvarcon , only : EDPftvarcon_inst use PRTParametersMod , only : prt_params use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts @@ -28,6 +27,7 @@ module EDInitMod use EDPhysiologyMod , only : calculate_sp_properties use ChecksBalancesMod , only : SiteMassStock use FatesInterfaceTypesMod , only : hlm_day_of_year + use FatesRadiationMemMod , only : num_swb use EDTypesMod , only : ed_site_type use FatesPatchMod , only : fates_patch_type use FatesCohortMod , only : fates_cohort_type @@ -99,7 +99,6 @@ module EDInitMod private logical :: debug = .false. - logical, parameter :: preserve_b4b = .true. integer :: istat ! return status code character(len=255) :: smsg ! Message string for deallocation errors character(len=*), parameter, private :: sourcefile = & @@ -610,7 +609,7 @@ subroutine init_patches( nsites, sites, bc_in) call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & biomass_stock,litter_stock,seed_stock) end do - if(.not.preserve_b4b) call set_patchno(sites(s)) + call set_patchno(sites(s)) enddo else @@ -701,8 +700,8 @@ subroutine init_patches( nsites, sites, bc_in) new_patch_area_gt_zero: if(newparea_withlanduse.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode allocate(newp) - call newp%Create(age, newparea_withlanduse, i_lu_state, nocomp_pft, & - hlm_numSWb, numpft, sites(s)%nlevsoil, hlm_current_tod, & + call newp%Create(age, newparea_withlanduse, i_lu_state, nocomp_pft, & + num_swb, numpft, sites(s)%nlevsoil, hlm_current_tod, & regeneration_model) if(is_first_patch.eq.itrue)then !is this the first patch? diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index 2773b46c8a..835c80158c 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -141,6 +141,8 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) ! non-zero diffuse radiation when cosz<=0 ! Temporarily turn off to preserve b4b + ! preserve_b4b will be removed soon. This is kept here to prevent + ! round off errors in the baseline tests for the two-stream code (RGK 12-27-23) if (.not.preserve_b4b) then bc_out(s)%albd_parb(ifp,:) = 1._r8 bc_out(s)%albi_parb(ifp,:) = 1._r8 @@ -302,6 +304,8 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) bc_out(s)%fsun_pa(ifp) = 0._r8 + ! preserve_b4b will be removed soon. This is kept here to prevent + ! round off errors in the baseline tests for the two-stream code (RGK 12-27-23) if(.not.preserve_b4b)then bc_out(s)%laisun_pa(ifp) = 0._r8 bc_out(s)%laisha_pa(ifp) = calc_areaindex(cpatch,'elai') @@ -320,6 +324,8 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) do cl = 1, cpatch%ncl_p do ft = 1,numpft + ! preserve_b4b will be removed soon. This is kept here to prevent + ! round off errors in the baseline tests for the two-stream code (RGK 12-27-23) if(.not.preserve_b4b) then sunlai = sunlai + sum(cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & cpatch%f_sun(cl,ft,1:cpatch%nrad(cl,ft))) @@ -341,7 +347,8 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) end if end do end do - + ! preserve_b4b will be removed soon. This is kept here to prevent + ! round off errors in the baseline tests for the two-stream code (RGK 12-27-23) if(.not.preserve_b4b)then shalai = shalai-sunlai end if From 5e4c6df4e425f79eb6ef2dcb9bd9b3d3d8b69f42 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 27 Dec 2023 13:14:54 -0700 Subject: [PATCH 237/250] removed redundant declaration --- biogeochem/EDCanopyStructureMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index b5b87e8f0c..4cd6930437 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -45,7 +45,6 @@ module EDCanopyStructureMod use PRTGenericMod, only : struct_organ use PRTGenericMod, only : SetState use PRTGenericMod, only : carbon12_element - use FatesAllometryMod , only : VegAreaLayer use FatesTwoStreamInterfaceMod, only : FatesConstructRadElements use FatesRadiationMemMod , only : twostr_solver From f4160299a2ed805c3f38ce11153779813a0d6896 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 3 Jan 2024 12:11:08 -0500 Subject: [PATCH 238/250] Updating scipy module importing to work for both new and old conventions --- tools/modify_fates_paramfile.py | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/tools/modify_fates_paramfile.py b/tools/modify_fates_paramfile.py index 69fccfc3e6..7578bf82a7 100755 --- a/tools/modify_fates_paramfile.py +++ b/tools/modify_fates_paramfile.py @@ -17,8 +17,6 @@ # ======================================================================================= import os -#from scipy.io import netcdf as nc -import scipy import argparse import shutil import tempfile @@ -28,6 +26,16 @@ import numpy as np import code # For development: code.interact(local=dict(globals(), **locals())) +# Newer versions of scipy have dropped the netcdf module and +# netcdf functions are part of the io parent module +try: + from scipy import io as nc + +except: + from scipy.io import netcdf as nc + + + # ======================================================================================== # ======================================================================================== # Main @@ -86,7 +94,7 @@ def main(): try: shutil.copyfile(args.inputfname, tempfilename) # - ncfile = scipy.io.netcdf_file(tempfilename, 'a') + ncfile = nc.netcdf_file(tempfilename, 'a') # var = ncfile.variables[args.varname] @@ -175,8 +183,8 @@ def main(): ### close the file that's open and start over. ncfile.close() os.remove(tempfilename) - ncfile = scipy.io.netcdf_file(tempfilename, 'w') - ncfile_old = scipy.io.netcdf_file(args.inputfname, 'r') + ncfile = nc.netcdf_file(tempfilename, 'w') + ncfile_old = nc.netcdf_file(args.inputfname, 'r') # try: ncfile.history = ncfile_old.history From 9fa0153bd9fff7630a148a5555dc6a74f10a0fc6 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 3 Jan 2024 13:11:41 -0500 Subject: [PATCH 239/250] added try clause to scipy module loading --- tools/BatchPatchParams.py | 10 ++++++++-- tools/FatesPFTIndexSwapper.py | 12 ++++++++---- tools/UpdateParamAPI.py | 21 ++++++++++++++------- 3 files changed, 30 insertions(+), 13 deletions(-) diff --git a/tools/BatchPatchParams.py b/tools/BatchPatchParams.py index db4588ca5d..2ac9312019 100755 --- a/tools/BatchPatchParams.py +++ b/tools/BatchPatchParams.py @@ -7,9 +7,15 @@ import os import argparse import code # For development: code.interact(local=dict(globals(), **locals())) -import scipy import xml.etree.ElementTree as et +# Newer versions of scipy have dropped the netcdf module and +# netcdf functions are part of the io parent module +try: + from scipy import io as nc +except: + from scipy.io import netcdf as nc + debug = True # --------------------------------------------------------------------------------------- @@ -176,7 +182,7 @@ def main(): # Append history - fp_nc = scipy.io.netcdf_file(new_nc, 'a') + fp_nc = nc.netcdf_file(new_nc, 'a') fp_nc.history = "This file was generated by BatchPatchParams.py:\n"\ "CDL Base File = {}\n"\ "XML patch file = {}"\ diff --git a/tools/FatesPFTIndexSwapper.py b/tools/FatesPFTIndexSwapper.py index dee1032a6c..f987ac2de7 100755 --- a/tools/FatesPFTIndexSwapper.py +++ b/tools/FatesPFTIndexSwapper.py @@ -15,10 +15,14 @@ import getopt import code # For development: code.interact(local=locals()) from datetime import datetime -#from scipy.io import netcdf -import scipy #import matplotlib.pyplot as plt +# Newer versions of scipy have dropped the netcdf module and +# netcdf functions are part of the io parent module +try: + from scipy import io as nc +except: + from scipy.io import netcdf as nc # ======================================================================================= # Parameters @@ -148,9 +152,9 @@ def main(argv): num_pft_out = len(donor_pft_indices) # Open the netcdf files - fp_out = scipy.io.netcdf_file(output_fname, 'w') + fp_out = nc.netcdf_file(output_fname, 'w') - fp_in = scipy.io.netcdf_file(input_fname, 'r') + fp_in = nc.netcdf_file(input_fname, 'r') for key, value in sorted(fp_in.dimensions.items()): if(key==pft_dim_name): diff --git a/tools/UpdateParamAPI.py b/tools/UpdateParamAPI.py index 7f49412eff..da8360adb1 100755 --- a/tools/UpdateParamAPI.py +++ b/tools/UpdateParamAPI.py @@ -12,10 +12,17 @@ import os import argparse import code # For development: code.interact(local=dict(globals(), **locals())) -from scipy.io import netcdf import xml.etree.ElementTree as et import numpy as np +# Newer versions of scipy have dropped the netcdf module and +# netcdf functions are part of the io parent module +try: + from scipy import io as nc + +except: + from scipy.io import netcdf as nc + # ======================================================================================= def load_xml(xmlfile): @@ -157,10 +164,10 @@ def removevar(base_nc,varname): # The trick here, is to copy the whole file, minus the variable of interest # into a temp file. Then completely remove the old file, and - fp_base = netcdf.netcdf_file(base_nc, 'r',mmap=False) + fp_base = nc.netcdf_file(base_nc, 'r',mmap=False) new_nc = os.popen('mktemp').read().rstrip('\n') - fp_new = netcdf.netcdf_file(new_nc, 'w',mmap=False) + fp_new = nc.netcdf_file(new_nc, 'w',mmap=False) found = False for key, value in sorted(fp_base.dimensions.items()): @@ -248,7 +255,7 @@ def main(): print("The dimension size should be a scalar") exit(2) - ncfile = netcdf.netcdf_file(base_nc,"a",mmap=False) + ncfile = nc.netcdf_file(base_nc,"a",mmap=False) ncfile.createDimension(dimname, values[0]) ncfile.flush() ncfile.close() @@ -264,7 +271,7 @@ def main(): exit(2) # Find which parameters use this dimension - ncfile = netcdf.netcdf_file(base_nc,"r",mmap=False) + ncfile = nc.netcdf_file(base_nc,"r",mmap=False) found = False for key, value in sorted(ncfile.dimensions.items()): if(key==dimname): @@ -315,7 +322,7 @@ def main(): except: print("no long-name (ln), exiting");exit(2) - ncfile = netcdf.netcdf_file(base_nc,"a",mmap=False) + ncfile = nc.netcdf_file(base_nc,"a",mmap=False) try: # print("trying val: {}".format(paramname)) @@ -375,7 +382,7 @@ def main(): print("to change a parameter, the field must have a name attribute") exit(2) - ncfile = netcdf.netcdf_file(base_nc,"a",mmap=False) + ncfile = nc.netcdf_file(base_nc,"a",mmap=False) ncvar_o = ncfile.variables[paramname_o] # dims_o = ncvar_o.dimensions dtype_o = ncvar_o.typecode() From 64eb770e71af3aee468c4b423bde60fd2a7c4f41 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 3 Jan 2024 15:43:36 -0500 Subject: [PATCH 240/250] deleted unnecessary comment --- biogeochem/FatesPatchMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index cd96c86004..d86e5c5d51 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -113,7 +113,6 @@ module FatesPatchMod real(r8) :: c_stomata ! mean stomatal conductance of all leaves in the patch [umol/m2/s] real(r8) :: c_lblayer ! mean boundary layer conductance of all leaves in the patch [umol/m2/s] - !TODO - can we delete these? real(r8) :: psn_z(nclmax,maxpft,nlevleaf) real(r8) :: nrmlzd_parprof_pft_dir_z(num_rad_stream_types,nclmax,maxpft,nlevleaf) real(r8) :: nrmlzd_parprof_pft_dif_z(num_rad_stream_types,nclmax,maxpft,nlevleaf) From 6935a4098e9e90bb45cf5ada2ff92f55036ad415 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 3 Jan 2024 15:45:33 -0500 Subject: [PATCH 241/250] removed unncecessary comment --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 53a61be5df..3612b9ad34 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -2246,8 +2246,6 @@ subroutine LeafLayerMaintenanceRespiration_Ryan_1991(lnc_top, & real(r8), parameter :: lmrc = 1.15912391_r8 ! scaling factor for high ! temperature inhibition (25 C = 1.0) - !veg_tempk = 27._r8+271._r8 - lmr25top = EDPftvarcon_inst%maintresp_leaf_ryan1991_baserate(ft) * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) lmr25top = lmr25top * lnc_top / (umolC_to_kgC * g_per_kg) From 5daf737732a9d76af0964c5ac08fb4be1f3a55b3 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 3 Jan 2024 15:47:01 -0500 Subject: [PATCH 242/250] set intent in on veg_tempk --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 3612b9ad34..59fd3c7a6a 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -2231,7 +2231,7 @@ subroutine LeafLayerMaintenanceRespiration_Ryan_1991(lnc_top, & real(r8), intent(in) :: lnc_top ! Leaf nitrogen content per unit area at canopy top [gN/m2] real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8) :: veg_tempk ! vegetation temperature + real(r8), intent(in) :: veg_tempk ! vegetation temperature real(r8), intent(out) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) ! Locals From 16429199019cf61bf7fd28801bc816796a2ac505 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 3 Jan 2024 15:52:19 -0500 Subject: [PATCH 243/250] removed unused global declarations in history --- main/FatesIOVariableKindMod.F90 | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/main/FatesIOVariableKindMod.F90 b/main/FatesIOVariableKindMod.F90 index 726eddbae6..07df7b8270 100644 --- a/main/FatesIOVariableKindMod.F90 +++ b/main/FatesIOVariableKindMod.F90 @@ -51,16 +51,6 @@ module FatesIOVariableKindMod character(*), parameter, public :: site_elcwd_r8 = 'SI_ELEMCWD_R8' character(*), parameter, public :: site_elage_r8 = 'SI_ELEMAGE_R8' - - integer, parameter, public :: upfreq_dyn = 1 ! dynamics variables - integer, parameter, public :: upfreq_hifr = 2 ! high frequency variables - !integer, parameter, public :: upfreq_dyn_multi = 3 ! dynamics multi-dimension - integer, parameter, public :: upfreq_hydr = 4 ! Hydro variables - integer, parameter, public :: upfreq_nutr = 5 - integer, parameter, public :: upfreq_hifr_multi = 6 ! high frequency multi-dim - - - ! NOTE(RGK, 2016) %active is not used yet. Was intended as a check on the HLM->FATES ! control parameter passing to ensure all active dimension types received all ! dimensioning specifications from the host, but we currently arent using those From 200f0244b548bb2fc5953db646e2d155068e65f8 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 3 Jan 2024 16:13:51 -0500 Subject: [PATCH 244/250] removing hlm_numSWb use in code, it is redundant --- biogeochem/EDPatchDynamicsMod.F90 | 4 +- main/EDParamsMod.F90 | 28 +----- main/EDTypesMod.F90 | 2 +- main/FatesInterfaceMod.F90 | 37 ++++---- main/FatesInventoryInitMod.F90 | 5 +- main/FatesRestartInterfaceMod.F90 | 9 +- radiation/FatesNormanRadMod.F90 | 110 +++++++++++------------ radiation/FatesRadiationDriveMod.F90 | 11 ++- radiation/FatesTwoStreamInterfaceMod.F90 | 7 +- tools/FatesPFTIndexSwapper.py | 2 +- 10 files changed, 91 insertions(+), 124 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 3fbdab801c..140c108d66 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -47,7 +47,6 @@ module EDPatchDynamicsMod use FatesConstantsMod , only : fates_tiny use FatesConstantsMod , only : nocomp_bareground use FatesInterfaceTypesMod , only : hlm_use_planthydro - use FatesInterfaceTypesMod , only : hlm_numSWb use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : numpft use FatesInterfaceTypesMod , only : hlm_stepsize @@ -106,6 +105,7 @@ module EDPatchDynamicsMod use FatesRunningMeanMod, only : ema_sdlng_mdd use FatesRunningMeanMod, only : ema_sdlng_emerg_h2o, ema_sdlng_mort_par, ema_sdlng2sap_par use FatesRunningMeanMod, only : ema_24hr, fixed_24hr, ema_lpa, ema_longterm + use FatesRadiationMemMod, only : num_swb ! CIME globals use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) @@ -603,7 +603,7 @@ subroutine spawn_patches( currentSite, bc_in) allocate(newPatch) call newPatch%Create(age, site_areadis, i_landusechange_receiverpatchlabel, i_nocomp_pft, & - hlm_numSWb, numpft, currentSite%nlevsoil, hlm_current_tod, & + num_swb, numpft, currentSite%nlevsoil, hlm_current_tod, & regeneration_model) ! Initialize the litter pools to zero, these diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index b9b9e06544..beaf11e140 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -106,33 +106,7 @@ module EDParamsMod real(r8), public :: dinc_vai(nlevleaf) = fates_unset_r8 ! VAI bin widths array real(r8), public :: dlower_vai(nlevleaf) = fates_unset_r8 ! lower edges of VAI bins - ! TODO: we use this cp_maxSWb only because we have a static array q(size=2) of - ! land-ice abledo for vis and nir. This should be a parameter, which would - ! get us on track to start using multi-spectral or hyper-spectral (RGK 02-2017) - - integer, parameter, public :: maxSWb = 2 ! maximum number of broad-bands in the - ! shortwave spectrum cp_numSWb <= cp_maxSWb - ! this is just for scratch-array purposes - ! if cp_numSWb is larger than this value - ! simply bump this number up as needed - -integer, parameter, public :: ivis = 1 ! This is the array index for short-wave - ! radiation in the visible spectrum, as expected - ! in boundary condition files and parameter - ! files. This will be compared with - ! the HLM's expectation in FatesInterfaceMod -integer, parameter, public :: inir = 2 ! This is the array index for short-wave - ! radiation in the near-infrared spectrum, as expected - ! in boundary condition files and parameter - ! files. This will be compared with - ! the HLM's expectation in FatesInterfaceMod - -integer, parameter, public :: ipar = ivis ! The photosynthetically active band - ! can be approximated to be equal to the visible band - - - -integer, parameter, public :: maxpft = 16 ! maximum number of PFTs allowed + integer, parameter, public :: maxpft = 16 ! maximum number of PFTs allowed real(r8),protected,public :: q10_mr ! Q10 for respiration rate (for soil fragmenation and plant respiration) (unitless) real(r8),protected,public :: q10_froz ! Q10 for frozen-soil respiration rates (for soil fragmentation) (unitless) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 49dfb44dfe..34e5f319d7 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -28,7 +28,7 @@ module EDTypesMod use FatesInterfaceTypesMod,only : hlm_parteh_mode use FatesCohortMod, only : fates_cohort_type use FatesPatchMod, only : fates_patch_type - use EDParamsMod, only : maxSWb, nclmax, nlevleaf, maxpft + use EDParamsMod, only : nclmax, nlevleaf, maxpft use FatesConstantsMod, only : n_dbh_bins, n_dist_types use shr_log_mod, only : errMsg => shr_log_errMsg diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 751139cf7a..c8a6303850 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -499,8 +499,8 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats, allocate(bc_in%precip24_pa(maxpatch_total)) ! Radiation - allocate(bc_in%solad_parb(maxpatch_total,hlm_numSWb)) - allocate(bc_in%solai_parb(maxpatch_total,hlm_numSWb)) + allocate(bc_in%solad_parb(maxpatch_total,num_swb)) + allocate(bc_in%solai_parb(maxpatch_total,num_swb)) ! Hydrology allocate(bc_in%smp_sl(nlevsoil_in)) @@ -532,8 +532,8 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats, allocate(bc_in%filter_vegzen_pa(maxpatch_total)) allocate(bc_in%coszen_pa(maxpatch_total)) allocate(bc_in%fcansno_pa(maxpatch_total)) - allocate(bc_in%albgr_dir_rb(hlm_numSWb)) - allocate(bc_in%albgr_dif_rb(hlm_numSWb)) + allocate(bc_in%albgr_dir_rb(num_swb)) + allocate(bc_in%albgr_dif_rb(num_swb)) ! Plant-Hydro BC's if (hlm_use_planthydro.eq.itrue) then @@ -610,13 +610,13 @@ subroutine allocate_bcout(bc_out, nlevsoil_in, nlevdecomp_in) allocate(bc_out%rssha_pa(maxpatch_total)) ! Canopy Radiation - allocate(bc_out%albd_parb(maxpatch_total,hlm_numSWb)) - allocate(bc_out%albi_parb(maxpatch_total,hlm_numSWb)) - allocate(bc_out%fabd_parb(maxpatch_total,hlm_numSWb)) - allocate(bc_out%fabi_parb(maxpatch_total,hlm_numSWb)) - allocate(bc_out%ftdd_parb(maxpatch_total,hlm_numSWb)) - allocate(bc_out%ftid_parb(maxpatch_total,hlm_numSWb)) - allocate(bc_out%ftii_parb(maxpatch_total,hlm_numSWb)) + allocate(bc_out%albd_parb(maxpatch_total,num_swb)) + allocate(bc_out%albi_parb(maxpatch_total,num_swb)) + allocate(bc_out%fabd_parb(maxpatch_total,num_swb)) + allocate(bc_out%fabi_parb(maxpatch_total,num_swb)) + allocate(bc_out%ftdd_parb(maxpatch_total,num_swb)) + allocate(bc_out%ftid_parb(maxpatch_total,num_swb)) + allocate(bc_out%ftii_parb(maxpatch_total,num_swb)) ! We allocate the boundary conditions to the BGC @@ -1487,14 +1487,13 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(hlm_numSWb > num_swb) then - write(fates_log(), *) 'FATES sets a maximum number of shortwave bands' - write(fates_log(), *) 'for some scratch-space, num_swb' - write(fates_log(), *) 'it defaults to 2, but can be increased as needed' - write(fates_log(), *) 'your driver or host model is intending to drive' - write(fates_log(), *) 'FATES with:',hlm_numSWb,' bands.' - write(fates_log(), *) 'please increase num_swb in FatesRadiationMemMod to match' - write(fates_log(), *) 'or exceed this value' + if(hlm_numSWb .ne. num_swb) then + write(fates_log(), *) 'FATES performs radiation scattering in the' + write(fates_log(), *) 'visible and near-infrared broad-bands for shortwave radiation.' + write(fates_log(), *) 'The host model has signaled to FATES that it is not tracking two' + write(fates_log(), *) 'bands.' + write(fates_log(), *) 'hlm_numSWb (HLM side):',hlm_numSWb + write(fates_log(), *) 'num_swb (FATES side): ',num_swb call endrun(msg=errMsg(sourcefile, __LINE__)) end if diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 941203d31b..61f77387f4 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -37,7 +37,6 @@ module FatesInventoryInitMod use FatesInterfaceTypesMod, only : hlm_inventory_ctrl_file use FatesInterfaceTypesMod, only : nleafage use FatesInterfaceTypesMod, only : hlm_current_tod - use FatesInterfaceTypesMod, only : hlm_numSWb use FatesInterfaceTypesMod, only : numpft use FatesLitterMod , only : litter_type use EDTypesMod , only : ed_site_type @@ -76,7 +75,7 @@ module FatesInventoryInitMod use PRTGenericMod, only : StorageNutrientTarget use FatesConstantsMod, only : fates_unset_int use EDCanopyStructureMod, only : canopy_summarization, canopy_structure - + use FatesRadiationMemMod, only : num_swb implicit none private @@ -285,7 +284,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) area_init = 0.0_r8 allocate(newpatch) call newpatch%Create(age_init, area_init, primaryland, & - fates_unset_int, hlm_numSWb, numpft, sites(s)%nlevsoil, & + fates_unset_int, num_swb, numpft, sites(s)%nlevsoil, & hlm_current_tod, regeneration_model) newpatch%patchno = ipa diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 161321d352..a2e7089c76 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -2706,7 +2706,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in, bc_out) use FatesPatchMod, only : fates_patch_type use EDParamsMod, only : regeneration_model use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch - use FatesInterfaceTypesMod, only : hlm_current_tod, hlm_numSWb, numpft + use FatesInterfaceTypesMod, only : hlm_current_tod, numpft use EDTypesMod, only : area use EDInitMod, only : zero_site use EDInitMod, only : init_site_vars @@ -2777,7 +2777,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in, bc_out) ! the nocomp_pft label is set after patch creation has occured in 'get_restart_vectors' ! make new patch call newp%Create(fates_unset_r8, fates_unset_r8, primaryland, & - nocomp_pft, hlm_numSWb, numpft, sites(s)%nlevsoil, & + nocomp_pft, num_swb, numpft, sites(s)%nlevsoil, & hlm_current_tod, regeneration_model) ! Initialize the litter pools to zero, these @@ -3644,7 +3644,6 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) use FatesNormanRadMod, only : PatchNormanRadiation use EDTypesMod, only : ed_site_type use FatesPatchMod, only : fates_patch_type - use FatesInterfaceTypesMod, only : hlm_numSWb ! !ARGUMENTS: class(fates_restart_interface_type) , intent(inout) :: this @@ -3703,7 +3702,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) ! no radiation is absorbed bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 - do ib = 1,hlm_numSWb + do ib = 1,num_swb bc_out(s)%albd_parb(ifp,ib) = currentPatch%gnd_alb_dir(ib) bc_out(s)%albi_parb(ifp,ib) = currentPatch%gnd_alb_dif(ib) @@ -3732,7 +3731,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) call twostr%CanopyPrep(currentPatch%fcansno) call twostr%ZenithPrep(currentPatch%solar_zenith_angle) - do ib = 1,hlm_numSWb + do ib = 1,num_swb twostr%band(ib)%albedo_grnd_diff = currentPatch%gnd_alb_dif(ib) twostr%band(ib)%albedo_grnd_beam = currentPatch%gnd_alb_dir(ib) diff --git a/radiation/FatesNormanRadMod.F90 b/radiation/FatesNormanRadMod.F90 index af9aa65659..19d41caa6f 100644 --- a/radiation/FatesNormanRadMod.F90 +++ b/radiation/FatesNormanRadMod.F90 @@ -10,30 +10,26 @@ module FatesNormanRadMod #include "shr_assert.h" - use EDTypesMod , only : ed_site_type - use FatesPatchMod, only : fates_patch_type - use EDParamsMod, only : maxpft - use FatesConstantsMod , only : r8 => fates_r8 - use FatesConstantsMod , only : itrue - use FatesConstantsMod , only : pi_const - use FatesConstantsMod , only : nocomp_bareground + use EDTypesMod , only : ed_site_type + use FatesPatchMod , only : fates_patch_type + use EDParamsMod , only : maxpft + use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : itrue + use FatesConstantsMod , only : pi_const + use FatesConstantsMod , only : nocomp_bareground use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : bc_out_type - use FatesInterfaceTypesMod , only : hlm_numSWb use FatesInterfaceTypesMod , only : numpft - use EDParamsMod , only : maxSWb - use EDParamsMod , only : nclmax - use EDParamsMod , only : nlevleaf - use EDTypesMod , only : n_rad_stream_types - use EDTypesMod , only : idiffuse - use EDTypesMod , only : idirect - use EDParamsMod , only : ivis - use EDParamsMod , only : inir - use EDParamsMod , only : ipar - use EDCanopyStructureMod, only: calc_areaindex - use FatesGlobals , only : fates_log - use FatesGlobals, only : endrun => fates_endrun - use EDPftvarcon, only : EDPftvarcon_inst + use EDParamsMod , only : nclmax + use EDParamsMod , only : nlevleaf + use FatesRadiationMemMod , only : num_swb + use FatesRadiationMemMod , only : num_rad_stream_types + use FatesRadiationmemMod , only : idirect, idiffuse + use FatesRadiationMemMod , only : ivis, inir, ipar + use EDCanopyStructureMod , only : calc_areaindex + use FatesGlobals , only : fates_log + use FatesGlobals , only : endrun => fates_endrun + use EDPftvarcon , only : EDPftvarcon_inst ! CIME globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -47,7 +43,7 @@ module FatesNormanRadMod character(len=*), parameter, private :: sourcefile = & __FILE__ - ! real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + ! real(r8), public :: albice(num_swb) = & ! albedo land ice by waveband (1=vis, 2=nir) ! (/ 0.80_r8, 0.55_r8 /) !parameters of canopy snow reflectance model. @@ -55,11 +51,11 @@ module FatesNormanRadMod ! and so they are stored here for now in common with the ice parameters above. ! in principle these could be moved to the parameter file. - real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + real(r8), public :: albice(num_swb) = & ! albedo land ice by waveband (1=vis, 2=nir) (/ 0.80_r8, 0.55_r8 /) - real(r8), public :: rho_snow(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + real(r8), public :: rho_snow(num_swb) = & ! albedo land ice by waveband (1=vis, 2=nir) (/ 0.80_r8, 0.55_r8 /) - real(r8), public :: tau_snow(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + real(r8), public :: tau_snow(num_swb) = & ! albedo land ice by waveband (1=vis, 2=nir) (/ 0.01_r8, 0.01_r8 /) contains @@ -83,13 +79,13 @@ subroutine PatchNormanRadiation (currentPatch, & ! ----------------------------------------------------------------------------------- type(fates_patch_type), intent(inout), target :: currentPatch - real(r8), intent(inout) :: albd_parb_out(hlm_numSWb) - real(r8), intent(inout) :: albi_parb_out(hlm_numSWb) - real(r8), intent(inout) :: fabd_parb_out(hlm_numSWb) - real(r8), intent(inout) :: fabi_parb_out(hlm_numSWb) - real(r8), intent(inout) :: ftdd_parb_out(hlm_numSWb) - real(r8), intent(inout) :: ftid_parb_out(hlm_numSWb) - real(r8), intent(inout) :: ftii_parb_out(hlm_numSWb) + real(r8), intent(inout) :: albd_parb_out(num_swb) + real(r8), intent(inout) :: albi_parb_out(num_swb) + real(r8), intent(inout) :: fabd_parb_out(num_swb) + real(r8), intent(inout) :: fabi_parb_out(num_swb) + real(r8), intent(inout) :: ftdd_parb_out(num_swb) + real(r8), intent(inout) :: ftid_parb_out(num_swb) + real(r8), intent(inout) :: ftii_parb_out(num_swb) ! Locals ! ----------------------------------------------------------------------------------- @@ -106,25 +102,25 @@ subroutine PatchNormanRadiation (currentPatch, & real(r8) :: tr_dif_z(nclmax,maxpft,nlevleaf) ! Exponential transmittance of diffuse radiation through a single layer real(r8) :: weighted_dir_tr(nclmax) real(r8) :: weighted_fsun(nclmax) - real(r8) :: weighted_dif_ratio(nclmax,maxSWb) + real(r8) :: weighted_dif_ratio(nclmax,num_swb) real(r8) :: weighted_dif_down(nclmax) real(r8) :: weighted_dif_up(nclmax) - real(r8) :: refl_dif(nclmax,maxpft,nlevleaf,maxSWb) ! Term for diffuse radiation reflected by laye - real(r8) :: tran_dif(nclmax,maxpft,nlevleaf,maxSWb) ! Term for diffuse radiation transmitted by layer - real(r8) :: dif_ratio(nclmax,maxpft,nlevleaf,maxSWb) ! Ratio of upward to forward diffuse fluxes + real(r8) :: refl_dif(nclmax,maxpft,nlevleaf,num_swb) ! Term for diffuse radiation reflected by laye + real(r8) :: tran_dif(nclmax,maxpft,nlevleaf,num_swb) ! Term for diffuse radiation transmitted by layer + real(r8) :: dif_ratio(nclmax,maxpft,nlevleaf,num_swb) ! Ratio of upward to forward diffuse fluxes real(r8) :: Dif_dn(nclmax,maxpft,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) real(r8) :: Dif_up(nclmax,maxpft,nlevleaf) ! Upward diffuse flux above canopy layer J (W/m**2 ground area) real(r8) :: lai_change(nclmax,maxpft,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) real(r8) :: frac_lai ! Fraction of lai in each layer real(r8) :: frac_sai ! Fraction of sai in each layer - real(r8) :: f_abs(nclmax,maxpft,nlevleaf,maxSWb) ! Fraction of light absorbed by surfaces. - real(r8) :: rho_layer(nclmax,maxpft,nlevleaf,maxSWb)! Weighted verage reflectance of layer - real(r8) :: tau_layer(nclmax,maxpft,nlevleaf,maxSWb)! Weighted average transmittance of layer - real(r8) :: f_abs_leaf(nclmax,maxpft,nlevleaf,maxSWb) + real(r8) :: f_abs(nclmax,maxpft,nlevleaf,num_swb) ! Fraction of light absorbed by surfaces. + real(r8) :: rho_layer(nclmax,maxpft,nlevleaf,num_swb)! Weighted verage reflectance of layer + real(r8) :: tau_layer(nclmax,maxpft,nlevleaf,num_swb)! Weighted average transmittance of layer + real(r8) :: f_abs_leaf(nclmax,maxpft,nlevleaf,num_swb) real(r8) :: Abs_dir_z(maxpft,nlevleaf) real(r8) :: Abs_dif_z(maxpft,nlevleaf) - real(r8) :: abs_rad(maxSWb) !radiation absorbed by soil + real(r8) :: abs_rad(num_swb) !radiation absorbed by soil real(r8) :: tr_soili ! Radiation transmitted to the soil surface. real(r8) :: tr_soild ! Radiation transmitted to the soil surface. real(r8) :: phi1b(maxpft) ! Radiation transmitted to the soil surface. @@ -147,8 +143,8 @@ subroutine PatchNormanRadiation (currentPatch, & real(r8) :: gdir - real(r8), parameter :: forc_dir(n_rad_stream_types) = (/ 1.0_r8, 0.0_r8 /) ! These are binary switches used - real(r8), parameter :: forc_dif(n_rad_stream_types) = (/ 0.0_r8, 1.0_r8 /) ! to turn off and on radiation streams + real(r8), parameter :: forc_dir(num_rad_stream_types) = (/ 1.0_r8, 0.0_r8 /) ! These are binary switches used + real(r8), parameter :: forc_dif(num_rad_stream_types) = (/ 0.0_r8, 1.0_r8 /) ! to turn off and on radiation streams @@ -180,13 +176,13 @@ subroutine PatchNormanRadiation (currentPatch, & ! Initialize the ouput arrays ! --------------------------------------------------------------------------------- - albd_parb_out(1:hlm_numSWb) = 0.0_r8 - albi_parb_out(1:hlm_numSWb) = 0.0_r8 - fabd_parb_out(1:hlm_numSWb) = 0.0_r8 - fabi_parb_out(1:hlm_numSWb) = 0.0_r8 - ftdd_parb_out(1:hlm_numSWb) = 1.0_r8 - ftid_parb_out(1:hlm_numSWb) = 1.0_r8 - ftii_parb_out(1:hlm_numSWb) = 1.0_r8 + albd_parb_out(1:num_swb) = 0.0_r8 + albi_parb_out(1:num_swb) = 0.0_r8 + fabd_parb_out(1:num_swb) = 0.0_r8 + fabi_parb_out(1:num_swb) = 0.0_r8 + ftdd_parb_out(1:num_swb) = 1.0_r8 + ftid_parb_out(1:num_swb) = 1.0_r8 + ftii_parb_out(1:num_swb) = 1.0_r8 ! Is this pft/canopy layer combination present in this patch? rho_layer(:,:,:,:)=0.0_r8 @@ -210,7 +206,7 @@ subroutine PatchNormanRadiation (currentPatch, & frac_sai = 1.0_r8 - frac_lai ! layer level reflectance qualities - do ib = 1,hlm_numSWb !vis, nir + do ib = 1,num_swb !vis, nir rho_layer(L,ft,iv,ib)=frac_lai*rhol(ft,ib)+frac_sai*rhos(ft,ib) tau_layer(L,ft,iv,ib)=frac_lai*taul(ft,ib)+frac_sai*taus(ft,ib) @@ -252,7 +248,7 @@ subroutine PatchNormanRadiation (currentPatch, & !do this once for one unit of diffuse, and once for one unit of direct radiation - do radtype = 1, n_rad_stream_types + do radtype = 1, num_rad_stream_types ! Extract information that needs to be provided by ED into local array. ! RGK: NOT SURE WHY WE NEED FTWEIGHT ... @@ -281,7 +277,7 @@ subroutine PatchNormanRadiation (currentPatch, & weighted_dir_tr(L) = 0.0_r8 weighted_fsun(L) = 0._r8 - weighted_dif_ratio(L,1:hlm_numSWb) = 0._r8 + weighted_dif_ratio(L,1:num_swb) = 0._r8 !Each canopy layer (canopy, understorey) has multiple 'parallel' pft's @@ -432,7 +428,7 @@ subroutine PatchNormanRadiation (currentPatch, & ! Iterative solution do scattering !==============================================================================! - do ib = 1,hlm_numSWb !vis, nir + do ib = 1,num_swb !vis, nir !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! ! Leaf scattering coefficient and terms do diffuse radiation reflected ! and transmitted by a layer @@ -472,12 +468,12 @@ subroutine PatchNormanRadiation (currentPatch, & weighted_dif_ratio(L,ib) = weighted_dif_ratio(L,ib) + & dif_ratio(L,ft,1,ib) * ftweight(L,ft,1) !instance where the first layer ftweight is used a proxy for the whole column. FTWA - end do!hlm_numSWb + end do!num_swb endif ! currentPatch%canopy_mask end do!ft end do!L - do ib = 1,hlm_numSWb + do ib = 1,num_swb currentPatch%rad_error(ib) = 0._r8 @@ -983,7 +979,7 @@ subroutine PatchNormanRadiation (currentPatch, & end if end if - end do !hlm_numSWb + end do !num_swb enddo ! rad-type diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index 835c80158c..42175579a2 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -21,7 +21,6 @@ module FatesRadiationDriveMod use FatesConstantsMod , only : nearzero use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : bc_out_type - use FatesInterfaceTypesMod , only : hlm_numSWb use FatesInterfaceTypesMod , only : numpft use FatesRadiationMemMod, only : num_rad_stream_types use FatesRadiationMemMod, only : idirect, idiffuse @@ -125,8 +124,8 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) currentPatch%solar_zenith_flag = bc_in(s)%filter_vegzen_pa(ifp) currentPatch%solar_zenith_angle = bc_in(s)%coszen_pa(ifp) - currentPatch%gnd_alb_dif(1:hlm_numSWb) = bc_in(s)%albgr_dif_rb(1:hlm_numSWb) - currentPatch%gnd_alb_dir(1:hlm_numSWb) = bc_in(s)%albgr_dir_rb(1:hlm_numSWb) + currentPatch%gnd_alb_dif(1:num_swb) = bc_in(s)%albgr_dif_rb(1:num_swb) + currentPatch%gnd_alb_dir(1:num_swb) = bc_in(s)%albgr_dir_rb(1:num_swb) currentPatch%fcansno = bc_in(s)%fcansno_pa(ifp) if(radiation_model.eq.twostr_solver) then @@ -168,7 +167,7 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 currentPatch%rad_error(:) = 0.0_r8 - do ib = 1,hlm_numSWb + do ib = 1,num_swb bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) bc_out(s)%ftdd_parb(ifp,ib) = 1.0_r8 @@ -197,7 +196,7 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) !call twostr%CanopyPrep(bc_in(s)%fcansno_pa(ifp)) !call twostr%ZenithPrep(bc_in(s)%coszen_pa(ifp)) - do ib = 1,hlm_numSWb + do ib = 1,num_swb twostr%band(ib)%albedo_grnd_diff = bc_in(s)%albgr_dif_rb(ib) twostr%band(ib)%albedo_grnd_beam = bc_in(s)%albgr_dir_rb(ib) @@ -422,7 +421,7 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) ! Two-stream ! ----------------------------------------------------------- - do ib = 1,hlm_numSWb + do ib = 1,num_swb cpatch%twostr%band(ib)%Rbeam_atm = bc_in(s)%solad_parb(ifp,ib) cpatch%twostr%band(ib)%Rdiff_atm = bc_in(s)%solai_parb(ifp,ib) end do diff --git a/radiation/FatesTwoStreamInterfaceMod.F90 b/radiation/FatesTwoStreamInterfaceMod.F90 index 382d234d92..66cf47c58b 100644 --- a/radiation/FatesTwoStreamInterfaceMod.F90 +++ b/radiation/FatesTwoStreamInterfaceMod.F90 @@ -13,7 +13,8 @@ Module FatesTwoStreamInterfaceMod use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) - use FatesInterfaceTypesMod, only : numpft,hlm_numSWb + use FatesInterfaceTypesMod, only : numpft + use FatesRadiationMemMod , only : num_swb use FatesRadiationMemMod , only : ivis, inir use FatesRadiationMemMod , only : rho_snow,tau_snow use TwoStreamMLPEMod , only : air_ft, AllocateRadParams, rad_params @@ -509,10 +510,10 @@ subroutine TransferRadParams() integer :: ft,ib ! loop indices - call AllocateRadParams(numpft,hlm_numSWb) + call AllocateRadParams(numpft,num_swb) do ft = 1,numpft - do ib = 1,hlm_numSWb + do ib = 1,num_swb rad_params%rhol(ib,ft) = EDPftvarcon_inst%rhol(ft,ib) rad_params%rhos(ib,ft) = EDPftvarcon_inst%rhos(ft,ib) diff --git a/tools/FatesPFTIndexSwapper.py b/tools/FatesPFTIndexSwapper.py index f987ac2de7..9202a77ff0 100755 --- a/tools/FatesPFTIndexSwapper.py +++ b/tools/FatesPFTIndexSwapper.py @@ -15,7 +15,7 @@ import getopt import code # For development: code.interact(local=locals()) from datetime import datetime -#import matplotlib.pyplot as plt +# import matplotlib.pyplot as plt # Newer versions of scipy have dropped the netcdf module and # netcdf functions are part of the io parent module try: From f6832c387773689af7310f2791fd02a68c58e53a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 3 Jan 2024 19:57:44 -0500 Subject: [PATCH 245/250] two-stream responding to reviewer comments --- radiation/FatesNormanRadMod.F90 | 9 --------- radiation/FatesRadiationDriveMod.F90 | 4 ++-- radiation/FatesRadiationMemMod.F90 | 5 ++--- ...StreamInterfaceMod.F90 => FatesTwoStreamUtilsMod.F90} | 4 ++-- 4 files changed, 6 insertions(+), 16 deletions(-) rename radiation/{FatesTwoStreamInterfaceMod.F90 => FatesTwoStreamUtilsMod.F90} (99%) diff --git a/radiation/FatesNormanRadMod.F90 b/radiation/FatesNormanRadMod.F90 index 19d41caa6f..24cf38fbb7 100644 --- a/radiation/FatesNormanRadMod.F90 +++ b/radiation/FatesNormanRadMod.F90 @@ -803,15 +803,6 @@ subroutine PatchNormanRadiation (currentPatch, & forc_dir(radtype) * tr_dir_z(L,ft,iv) currentPatch%nrmlzd_parprof_pft_dif_z(radtype,L,ft,iv) = & Dif_dn(L,ft,iv) + Dif_up(L,ft,iv) - ! - !currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) = & - ! currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) + & - ! (forc_dir(radtype) * tr_dir_z(L,ft,iv)) * & - ! (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) - !currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) = & - ! currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) + & - ! (Dif_dn(L,ft,iv) + Dif_up(L,ft,iv)) * & - ! (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) end do end if ! ib = visible end if ! present diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index 42175579a2..cb642c1289 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -30,8 +30,8 @@ module FatesRadiationDriveMod use FatesRadiationMemMod, only : twostr_solver use EDParamsMod, only : radiation_model use TwoStreamMLPEMod, only : normalized_upper_boundary - use FatesTwoStreamInterfaceMod, only : FatesPatchFSun - use FatesTwoStreamInterfaceMod, only : CheckPatchRadiationBalance + use FatesTwoStreamUtilsMod, only : FatesPatchFSun + use FatesTwoStreamUtilsMod, only : CheckPatchRadiationBalance use FatesInterfaceTypesMod , only : hlm_hio_ignore_val use EDParamsMod , only : dinc_vai,dlower_vai use EDParamsMod , only : nclmax diff --git a/radiation/FatesRadiationMemMod.F90 b/radiation/FatesRadiationMemMod.F90 index 3e72e766d4..6927c6bf3c 100644 --- a/radiation/FatesRadiationMemMod.F90 +++ b/radiation/FatesRadiationMemMod.F90 @@ -11,9 +11,8 @@ Module FatesRadiationMemMod ! For now, this module also holds relevant data for Norman radiation ! --------------------------------------------------------------------------- - integer, parameter :: r8 = selected_real_kind(12) - - + use FatesConstantsMod, only : r8 => fates_r8 + integer, parameter, public :: norman_solver = 1 integer, parameter, public :: twostr_solver = 2 diff --git a/radiation/FatesTwoStreamInterfaceMod.F90 b/radiation/FatesTwoStreamUtilsMod.F90 similarity index 99% rename from radiation/FatesTwoStreamInterfaceMod.F90 rename to radiation/FatesTwoStreamUtilsMod.F90 index 66cf47c58b..e621f84928 100644 --- a/radiation/FatesTwoStreamInterfaceMod.F90 +++ b/radiation/FatesTwoStreamUtilsMod.F90 @@ -1,4 +1,4 @@ -Module FatesTwoStreamInterfaceMod +Module FatesTwoStreamUtilsMod ! This module holds routines that are specific to connecting FATES with ! the two-stream radiation module. These routines are used to @@ -531,4 +531,4 @@ subroutine TransferRadParams() end subroutine TransferRadParams -end Module FatesTwoStreamInterfaceMod +end Module FatesTwoStreamUtilsMod From d127f519810c0d5d5d764b346e42139bd5650706 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 3 Jan 2024 20:05:33 -0500 Subject: [PATCH 246/250] resolving more reviewer comments --- .../radiation/RadiationUTestDriver.py | 2 +- radiation/FatesTwoStreamUtilsMod.F90 | 4 ++-- radiation/TwoStreamMLPEMod.F90 | 10 +++++----- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/functional_unit_testing/radiation/RadiationUTestDriver.py b/functional_unit_testing/radiation/RadiationUTestDriver.py index f8ab759ed2..b7c32d74d3 100644 --- a/functional_unit_testing/radiation/RadiationUTestDriver.py +++ b/functional_unit_testing/radiation/RadiationUTestDriver.py @@ -50,7 +50,7 @@ alloc_radparams_call = f90_twostr_obj.__twostreammlpemod_MOD_allocateradparams set_radparams_call = f90_wrap_obj.__radiationwrapmod_MOD_setradparam set_radparams_call.argtypes = [POINTER(c_double),POINTER(c_int),POINTER(c_int),c_char_p,c_long] -param_prep_call = f90_twostr_obj.__twostreammlpemod_MOD_paramprep +param_prep_call = f90_twostr_obj.__twostreammlpemod_MOD_radparamprep setup_canopy_call = f90_wrap_obj.__radiationwrapmod_MOD_setupcanopy setup_canopy_call.argtypes = [POINTER(c_int),POINTER(c_int),POINTER(c_int), \ diff --git a/radiation/FatesTwoStreamUtilsMod.F90 b/radiation/FatesTwoStreamUtilsMod.F90 index e621f84928..5a87ff24b0 100644 --- a/radiation/FatesTwoStreamUtilsMod.F90 +++ b/radiation/FatesTwoStreamUtilsMod.F90 @@ -23,7 +23,7 @@ Module FatesTwoStreamUtilsMod use EDTypesMod , only : ed_site_type use EDParamsMod , only : nclmax use TwoStreamMLPEMod , only : twostream_type - use TwoStreamMLPEMod , only : ParamPrep + use TwoStreamMLPEMod , only : RadParamPrep use TwoStreamMLPEMod , only : AllocateRadParams use TwoStreamMLPEMod , only : rel_err_thresh,area_err_thresh use EDPftvarcon , only : EDPftvarcon_inst @@ -525,7 +525,7 @@ subroutine TransferRadParams() rad_params%clumping_index(ft) = EDPftvarcon_inst%clumping_index(ft) end do - call ParamPrep() + call RadParamPrep() return end subroutine TransferRadParams diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index 05d4bd04c4..53ee4d0b5e 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -222,7 +222,7 @@ Module TwoStreamMLPEMod end type twostream_type - public :: ParamPrep + public :: RadParamPrep public :: AllocateRadParams public :: TwoStreamLogInit @@ -638,7 +638,7 @@ end subroutine Dump ! ================================================================================================ - subroutine ParamPrep() + subroutine RadParamPrep() integer :: ft integer :: nbands @@ -686,7 +686,7 @@ subroutine ParamPrep() rad_params%om_stem(ib,ft) = rad_params%rhos(ib,ft) + rad_params%taus(ib,ft) if( rad_params%om_leaf(ib,ft) > 0.99_r8 ) then - write(log_unit,*) "In: TwoStreamMLPEMod.F90:ParamPrep()" + write(log_unit,*) "In: TwoStreamMLPEMod.F90:RadParamPrep()" write(log_unit,*) "An extremely high leaf scattering coefficient was generated:" write(log_unit,*) "om = tau + rho" write(log_unit,*) "band = ",ib @@ -697,7 +697,7 @@ subroutine ParamPrep() call endrun(msg=errMsg(sourcefile, __LINE__)) end if if( rad_params%om_stem(ib,ft) > 0.99_r8 ) then - write(log_unit,*) "In: TwoStreamMLPEMod.F90:ParamPrep()" + write(log_unit,*) "In: TwoStreamMLPEMod.F90:RadParamPrep()" write(log_unit,*) "An extremely high stem scattering coefficient was generated:" write(log_unit,*) "om = tau + rho" write(log_unit,*) "band = ",ib @@ -713,7 +713,7 @@ subroutine ParamPrep() end do return - end subroutine ParamPrep + end subroutine RadParamPrep ! ================================================================================================ From 3e4ff345cf54820d4b67f28964792a87ed271736 Mon Sep 17 00:00:00 2001 From: jessica needham Date: Thu, 4 Jan 2024 15:11:13 -0800 Subject: [PATCH 247/250] update FatesPFTIndexSwapper.py to work with landuse --- tools/FatesPFTIndexSwapper.py | 31 ++++++++++++++++++++++--------- 1 file changed, 22 insertions(+), 9 deletions(-) diff --git a/tools/FatesPFTIndexSwapper.py b/tools/FatesPFTIndexSwapper.py index 99e258bdc6..9b3c9cd20e 100755 --- a/tools/FatesPFTIndexSwapper.py +++ b/tools/FatesPFTIndexSwapper.py @@ -28,6 +28,7 @@ hydro_dim_name = 'fates_hydr_organs' litt_dim_name = 'fates_litterclass' string_dim_name = 'fates_string_length' +landuse_dim_name = 'fates_landuseclass' class timetype: @@ -165,14 +166,14 @@ def main(argv): in_var = fp_in.variables.get(key) - - + # Idenfity if this variable has pft dimension - pft_dim_found = -1 - prt_dim_found = -1 - hydro_dim_found = -1 - litt_dim_found = -1 - string_dim_found = -1 + pft_dim_found = -1 + prt_dim_found = -1 + hydro_dim_found = -1 + litt_dim_found = -1 + string_dim_found = -1 + landuse_dim_found = -1 pft_dim_len = len(fp_in.variables.get(key).dimensions) for idim, name in enumerate(fp_in.variables.get(key).dimensions): @@ -188,13 +189,18 @@ def main(argv): hydro_dim_found = idim if(name==string_dim_name): string_dim_found = idim - + if(name==landuse_dim_name): + landuse_dim_found = idim + + + + # Copy over the input data # Tedious, but I have to permute through all combinations of dimension position if( pft_dim_len == 0 ): out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) out_var.assignValue(float(fp_in.variables.get(key).data)) - elif( (pft_dim_found==-1) & (prt_dim_found==-1) & (litt_dim_found==-1) & (hydro_dim_found==-1) ): + elif( (pft_dim_found==-1) & (prt_dim_found==-1) & (litt_dim_found==-1) & (hydro_dim_found==-1) & (landuse_dim_found==-1) ): out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] elif( (pft_dim_found==0) & (pft_dim_len==1) ): # 1D fates_pft @@ -231,6 +237,10 @@ def main(argv): out_var[:] = in_var[:] elif( (litt_dim_found==0) & (string_dim_found>=0) ): + out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + + elif( (landuse_dim_found==0) & (string_dim_found>=0) ): out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] @@ -241,6 +251,9 @@ def main(argv): elif( litt_dim_found==0 ): out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] + elif( landuse_dim_found==0 ): + out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] elif( hydro_dim_found==0): out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] From 0079a852d5de4f302bcef17f64edea800927e816 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 10 Jan 2024 12:57:28 -0700 Subject: [PATCH 248/250] Fixing zero protections on two-stream zenith calcualtions --- biogeochem/EDCanopyStructureMod.F90 | 2 +- biogeophys/FatesPlantRespPhotosynthMod.F90 | 2 +- main/FatesInterfaceMod.F90 | 2 +- radiation/TwoStreamMLPEMod.F90 | 11 ++++++----- 4 files changed, 9 insertions(+), 8 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 4cd6930437..23d851ea92 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -45,7 +45,7 @@ module EDCanopyStructureMod use PRTGenericMod, only : struct_organ use PRTGenericMod, only : SetState use PRTGenericMod, only : carbon12_element - use FatesTwoStreamInterfaceMod, only : FatesConstructRadElements + use FatesTwoStreamUtilsMod, only : FatesConstructRadElements use FatesRadiationMemMod , only : twostr_solver ! CIME Globals diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 59fd3c7a6a..d110932054 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -69,7 +69,7 @@ module FATESPlantRespPhotosynthMod use FatesRadiationMemMod, only : norman_solver,twostr_solver use EDParamsMod, only : radiation_model use FatesRadiationMemMod, only : ipar - use FatesTwoStreamInterfaceMod, only : FatesGetCohortAbsRad + use FatesTwoStreamUtilsMod, only : FatesGetCohortAbsRad use FatesAllometryMod , only : VegAreaLayer ! CIME Globals diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index c8a6303850..7b5b72ad9e 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -108,7 +108,7 @@ module FatesInterfaceMod use FatesHistoryInterfaceMod , only : fates_hist use FatesHydraulicsMemMod , only : nshell use FatesHydraulicsMemMod , only : nlevsoi_hyd_max - use FatesTwoStreamInterfaceMod, only : TransferRadParams + use FatesTwoStreamUtilsMod, only : TransferRadParams ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index 53ee4d0b5e..3f7df8d1ef 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -877,7 +877,7 @@ end subroutine CanopyPrep ! ================================================================================================ - subroutine ZenithPrep(this,cosz) + subroutine ZenithPrep(this,cosz_in) ! Pre-process things that change with the zenith angle ! i.e. the beam optical properties @@ -889,8 +889,9 @@ subroutine ZenithPrep(this,cosz) class(twostream_type) :: this integer :: ib ! band index, matches indexing of rad_params - real(r8) :: cosz ! Cosine of the zenith angle + real(r8),intent(in) :: cosz_in ! Un-protected cosine of the zenith angle + real(r8) :: cosz ! the near-zero protected cosz integer :: ican ! scattering element canopy layer index (top down) integer :: icol ! scattering element column real(r8) :: asu ! single scattering albedo @@ -908,12 +909,12 @@ subroutine ZenithPrep(this,cosz) ! the Kb_leaf that creates ! a singularity and the actual - if( (cosz-1.0) > nearzero ) then + if( (cosz_in-1.0) > nearzero ) then write(log_unit,*)"The cosine of the zenith angle cannot exceed 1" write(log_unit,*)"cosz: ",cosz write(log_unit,*)"TwoStreamMLPEMod.F90:ZenithPrep" call endrun(msg=errMsg(sourcefile, __LINE__)) - elseif(cosz<0._r8)then + elseif(cosz_in<0._r8)then write(log_unit,*)"The cosine of the zenith angle should not be less than zero" write(log_unit,*)"It can be exactly zero, but not less than" write(log_unit,*)"cosz: ",cosz @@ -921,7 +922,7 @@ subroutine ZenithPrep(this,cosz) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - cosz = max(0.001,cosz) + cosz = max(0.001,cosz_in) this%cosz = cosz From af2c3b9994352af7aa408ada7178acfed330729f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 12 Jan 2024 11:55:17 -0700 Subject: [PATCH 249/250] Fixes to nan checks in fates two-stream --- radiation/TwoStreamMLPEMod.F90 | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/radiation/TwoStreamMLPEMod.F90 b/radiation/TwoStreamMLPEMod.F90 index 3f7df8d1ef..941a57c32e 100644 --- a/radiation/TwoStreamMLPEMod.F90 +++ b/radiation/TwoStreamMLPEMod.F90 @@ -27,7 +27,8 @@ Module TwoStreamMLPEMod use shr_log_mod , only: errMsg => shr_log_errMsg use shr_sys_mod , only: shr_sys_abort use FatesConstantsMod, only : r8 => fates_r8 - + use shr_infnan_mod, only : shr_infnan_isnan + implicit none private @@ -369,7 +370,9 @@ function GetRdDn(this,ican,icol,ib,vai) result(r_diff_dn) scelb%B1*scelb%lambda2_diff*exp(-scelb%a*vai)) if(debug)then - if(isnan(r_diff_dn))then + ! if(isnan(r_diff_dn))then !RGK: NVHPC HAS A BUG IN THIS INTRINSIC (01-2024) + ! if(r_diff_dn /= r_diff_dn) then + if(shr_infnan_isnan(r_diff_dn)) then write(log_unit,*)"GETRDN" write(log_unit,*)scelg%Kb write(log_unit,*)scelb%a @@ -827,7 +830,9 @@ subroutine CanopyPrep(this,frac_snow) scelb%betad = betad_om / scelb%om if(debug)then - if(isnan(scelb%betad))then + !if(isnan(scelb%betad))then !RGK: NVHPC HAS A BUG IN THIS INTRINSIC (01-2024) + !if(scelb%betad /= scelb%betad) then + if(shr_infnan_isnan(scelb%betad))then write(log_unit,*)"nans in canopy prep" write(log_unit,*) ib,ican,icol,ft write(log_unit,*) scelb%betad,scelb%om,lai,sai From 7b2cdbe1b2a7d8eee436db0f759c632ac5e75e08 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 12 Jan 2024 13:27:46 -0700 Subject: [PATCH 250/250] fixed try statement on module importing in python scipy --- tools/BatchPatchParams.py | 2 +- tools/FatesPFTIndexSwapper.py | 2 +- tools/UpdateParamAPI.py | 2 +- tools/modify_fates_paramfile.py | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/tools/BatchPatchParams.py b/tools/BatchPatchParams.py index 2ac9312019..cd3e934632 100755 --- a/tools/BatchPatchParams.py +++ b/tools/BatchPatchParams.py @@ -13,7 +13,7 @@ try: from scipy import io as nc -except: +except ImportError: from scipy.io import netcdf as nc debug = True diff --git a/tools/FatesPFTIndexSwapper.py b/tools/FatesPFTIndexSwapper.py index 057cf49319..c63f8891b7 100755 --- a/tools/FatesPFTIndexSwapper.py +++ b/tools/FatesPFTIndexSwapper.py @@ -21,7 +21,7 @@ try: from scipy import io as nc -except: +except ImportError: from scipy.io import netcdf as nc # ======================================================================================= diff --git a/tools/UpdateParamAPI.py b/tools/UpdateParamAPI.py index da8360adb1..cc9ffa1faa 100755 --- a/tools/UpdateParamAPI.py +++ b/tools/UpdateParamAPI.py @@ -20,7 +20,7 @@ try: from scipy import io as nc -except: +except ImportError: from scipy.io import netcdf as nc # ======================================================================================= diff --git a/tools/modify_fates_paramfile.py b/tools/modify_fates_paramfile.py index 7578bf82a7..1b25ae7171 100755 --- a/tools/modify_fates_paramfile.py +++ b/tools/modify_fates_paramfile.py @@ -31,7 +31,7 @@ try: from scipy import io as nc -except: +except ImportError: from scipy.io import netcdf as nc