diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 83f10a26b5..485d46cd86 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1307,7 +1307,7 @@ end subroutine canopy_spread ! ===================================================================================== - subroutine canopy_summarization( nsites, sites, bc_in ) + subroutine canopy_summarization( nsites, sites ) ! ---------------------------------------------------------------------------------- ! Much of this routine was once ed_clm_link minus all the IO and history stuff @@ -1323,7 +1323,6 @@ subroutine canopy_summarization( nsites, sites, bc_in ) ! !ARGUMENTS integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) - type(bc_in_type) , intent(in) :: bc_in(nsites) ! ! !LOCAL VARIABLES: type (fates_patch_type) , pointer :: currentPatch diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index e122206a53..b7802695c4 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -680,7 +680,7 @@ subroutine spawn_patches( currentSite, bc_in ) call newPatch%Create(age, site_areadis, i_landusechange_receiverpatchlabel, i_nocomp_pft, & num_swb, numpft, currentSite%nlevsoil, hlm_current_tod, & - hlm_regeneration_model) + hlm_regeneration_model, currentSite%api) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -1371,7 +1371,7 @@ subroutine spawn_patches( currentSite, bc_in ) call buffer_patch%Create(0._r8, 0._r8, i_land_use_label, 0, & num_swb, numpft, currentSite%nlevsoil, hlm_current_tod, & - hlm_regeneration_model) + hlm_regeneration_model, currentSite%api) ! Initialize the litter pools to zero do el=1,num_elements @@ -1664,7 +1664,7 @@ subroutine split_patch(currentSite, currentPatch, new_patch, fraction_to_keep, a call new_patch%Create(0._r8, temp_area, & currentPatch%land_use_label, currentPatch%nocomp_pft_label, & num_swb, numpft, currentSite%nlevsoil, hlm_current_tod, & - hlm_regeneration_model) + hlm_regeneration_model, currentSite%api) ! Initialize the litter pools to zero, these ! pools will be populated shortly diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index f509aec000..b62b3e7522 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -3215,7 +3215,7 @@ subroutine fragmentation_scaler( currentPatch, bc_in) if ( use_hlm_soil_scalar ) then ! Calculate the fragmentation_scaler - currentPatch%fragmentation_scaler = min(1.0_r8,max(0.0_r8,bc_in%t_scalar_sisl * bc_in%w_scalar_sisl)) + currentPatch%fragmentation_scaler = min(1.0_r8,max(0.0_r8,currentPatch%bc_in%t_scalar_sisl * currentPatch%bc_in%w_scalar_sisl)) else diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index 9b3b9ef919..0e2e8a15ab 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -32,6 +32,9 @@ module FatesPatchMod use FatesRadiationMemMod, only : num_rad_stream_types use FatesInterfaceTypesMod, only : hlm_hio_ignore_val use FatesInterfaceTypesMod, only : numpft + use FatesInterfaceTypesMod, only : bc_in_type + use FatesInterfaceTypesMod, only : bc_out_type + use FatesInterfaceTypesMod, only : fates_interface_registry_base_type use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) use shr_log_mod, only : errMsg => shr_log_errMsg @@ -48,6 +51,14 @@ module FatesPatchMod type (fates_cohort_type), pointer :: shortest => null() ! pointer to patch's shortest cohort type (fates_patch_type), pointer :: older => null() ! pointer to next older patch type (fates_patch_type), pointer :: younger => null() ! pointer to next younger patch + + ! BC data + ! TODO change this to a specific bc type for incremental refactor purposes if this method is picked + type(bc_in_type) :: bc_in + type(bc_out_type) :: bc_out + + ! API registry container + type(fates_interface_registry_base_type) :: api !--------------------------------------------------------------------------- @@ -242,13 +253,16 @@ module FatesPatchMod procedure :: Dump procedure :: CheckVars + procedure, private :: InitializeInterfaceRegistry + procedure, private :: InitializeInterfaceVariables + end type fates_patch_type contains !=========================================================================== - subroutine Init(this, num_swb, num_levsoil) + subroutine Init(this, num_swb, num_levsoil, api_pointer) ! ! DESCRIPTION: ! Initialize a new patch - allocate arrays and set values to nan and/or 0.0 @@ -258,6 +272,7 @@ subroutine Init(this, num_swb, num_levsoil) class(fates_patch_type), intent(inout) :: this ! patch object integer, intent(in) :: num_swb ! number of shortwave broad-bands to track integer, intent(in) :: num_levsoil ! number of soil layers + class(fates_interface_registry_base_type), pointer, intent(in) :: api_pointer ! allocate arrays allocate(this%tr_soil_dir(num_swb)) @@ -270,6 +285,13 @@ subroutine Init(this, num_swb, num_levsoil) allocate(this%sabs_dif(num_swb)) allocate(this%fragmentation_scaler(num_levsoil)) + ! Initialize the patch-level API registry + call this%InitializeInterfaceRegistry() + + ! Initialize and register the variables in the API registry + ! This also allocates the boundary conditions + call this%InitializeInterfaceVariables(api_pointer) + ! initialize all values to nan call this%NanValues() @@ -507,6 +529,12 @@ subroutine NanValues(this) this%scorch_ht(:) = nan this%tfc_ros = nan this%frac_burnt = nan + + ! Boundary conditions + this%bc_in%w_scalar_sisl(:) = nan + this%bc_in%t_scalar_sisl(:) = nan + this%bc_in%nlevdecomp = fates_unset_int + this%bc_in%nlevsoil = fates_unset_int end subroutine NanValues @@ -594,6 +622,12 @@ subroutine ZeroValues(this) this%tfc_ros = 0.0_r8 this%frac_burnt = 0.0_r8 + ! Boundary conditions + this%bc_in%w_scalar_sisl(:) = 0.0_r8 + this%bc_in%t_scalar_sisl(:) = 0.0_r8 + this%bc_in%nlevdecomp = 0.0_r8 + this%bc_in%nlevsoil = 0.0_r8 + end subroutine ZeroValues !=========================================================================== @@ -686,7 +720,7 @@ end subroutine InitLitter !=========================================================================== subroutine Create(this, age, area, land_use_label, nocomp_pft, num_swb, num_pft, & - num_levsoil, current_tod, regeneration_model) + num_levsoil, current_tod, regeneration_model, api_pointer) ! ! DESCRIPTION: ! create a new patch with input and default values @@ -703,11 +737,13 @@ subroutine Create(this, age, area, land_use_label, nocomp_pft, num_swb, num_pft, integer, intent(in) :: num_levsoil ! number of soil layers integer, intent(in) :: current_tod ! time of day [seconds past 0Z] integer, intent(in) :: regeneration_model ! regeneration model version + + class(fates_interface_registry_base_type), pointer, intent(in) :: api_pointer ! initialize patch - ! sets all values to nan, then some values to zero - call this%Init(num_swb, num_levsoil) - + ! sets all values to nan, then some values to zero, and initialize interface registry + call this%Init(num_swb, num_levsoil, api_pointer) + ! initialize running means for patch call this%InitRunningMeans(current_tod, regeneration_model, num_pft) @@ -1288,4 +1324,44 @@ end subroutine CheckVars !=========================================================================== + subroutine InitializeInterfaceRegistry(this) + + use FatesInterfaceTypesMod, only: hlm_fates_soil_level + + class(fates_patch_type), intent(inout) :: this + + ! Initialize the patch-level interface variable registry for the FATES-side + call this%api%InitializeInterfaceRegistry() + + ! Register the boundary condition data variables that are set during initialization only + ! See RegisterInterfaceVariables patch-type bound procedure for remaining variables registrations + call this%api%Register(hlm_fates_soil_level, this%bc_in%nlevsoil) + + end subroutine InitializeInterfaceRegistry + +! ====================================================================================== + + subroutine InitializeInterfaceVariables(this, input_api) + + use FatesInterfaceTypesMod, only : hlm_fates_decomp_frac_moisture + use FatesInterfaceTypesMod, only : hlm_fates_decomp_frac_temperature + + class(fates_patch_type), intent(inout) :: this + class(fates_interface_registry_base_type), intent(in) :: input_api + + ! Initialize interface variables + call this%api%InitializeInterfaceVariables(input_api) + + ! Allocate the boundary conditions array using the BCs set during initialization + allocate(this%bc_in%w_scalar_sisl(this%bc_in%nlevsoil)) + allocate(this%bc_in%t_scalar_sisl(this%bc_in%nlevsoil)) + + ! Register the boundary condintion variables not exclusively updated during initialization + call this%api%Register(hlm_fates_decomp_frac_moisture, this%bc_in%w_scalar_sisl) + call this%api%Register(hlm_fates_decomp_frac_temperature, this%bc_in%t_scalar_sisl) + + end subroutine InitializeInterfaceVariables + +! ====================================================================================== + end module FatesPatchMod diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index b4f93ba5c9..22370eaeaf 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -29,7 +29,7 @@ module EDAccumulateFluxesMod !------------------------------------------------------------------------------ - subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) + subroutine AccumulateFluxes_ED(nsites, sites, bc_in, dt_time) ! ! !DESCRIPTION: @@ -40,14 +40,13 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) use EDTypesMod , only : ed_site_type, AREA use FatesPatchMod, only : fates_patch_type use FatesCohortMod, only : fates_cohort_type - use FatesInterfaceTypesMod , only : bc_in_type,bc_out_type + use FatesInterfaceTypesMod , only : bc_in_type ! ! !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) real(r8), intent(in) :: dt_time ! timestep interval ! ! !LOCAL VARIABLES: diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 8f34b90532..83027b65d7 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -53,7 +53,7 @@ module EDInitMod use EDTypesMod , only : phen_dstat_moistoff use EDTypesMod , only : phen_cstat_notcold use EDTypesMod , only : phen_dstat_moiston - use FatesInterfaceTypesMod , only : bc_in_type,bc_out_type + use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_use_inventory_init use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog @@ -128,7 +128,7 @@ module EDInitMod ! ============================================================================ - subroutine init_site_vars( site_in, bc_in, bc_out ) + subroutine init_site_vars( site_in, bc_in ) ! ! !DESCRIPTION: ! @@ -136,7 +136,6 @@ subroutine init_site_vars( site_in, bc_in, bc_out ) ! !ARGUMENTS type(ed_site_type), intent(inout) :: site_in type(bc_in_type),intent(in) :: bc_in - type(bc_out_type),intent(in) :: bc_out ! ! !LOCAL VARIABLES: !---------------------------------------------------------------------- @@ -784,7 +783,7 @@ subroutine init_patches( nsites, sites, bc_in) call newp%Create(age, newparea, nocomp_bareground_land, nocomp_bareground, & num_swb, numpft, sites(s)%nlevsoil, hlm_current_tod, & - hlm_regeneration_model) + hlm_regeneration_model, sites(s)%api) ! set pointers for first patch (or only patch, if nocomp is false) newp%patchno = 1 @@ -863,7 +862,7 @@ subroutine init_patches( nsites, sites, bc_in) call newp%Create(age, newparea, i_lu_state, nocomp_pft, & num_swb, numpft, sites(s)%nlevsoil, hlm_current_tod, & - hlm_regeneration_model) + hlm_regeneration_model, sites(s)%api) if (is_first_patch) then !is this the first patch? ! set pointers for first patch (or only patch, if nocomp is false) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index a6a2269026..a37a169fc4 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -9,6 +9,7 @@ module EDTypesMod use FatesConstantsMod, only : secondaryland use FatesConstantsMod, only : secondary_age_threshold use FatesConstantsMod, only : nearzero + use FatesConstantsMod , only : n_landuse_cats use FatesGlobals, only : fates_log use FatesHydraulicsMemMod, only : ed_cohort_hydr_type use FatesHydraulicsMemMod, only : ed_site_hydr_type @@ -29,8 +30,8 @@ module EDTypesMod use FatesConstantsMod, only : fates_unset_r8 use FatesInterfaceTypesMod,only : bc_in_type use FatesInterfaceTypesMod,only : bc_out_type - use FatesConstantsMod , only : n_landuse_cats use FatesInterfaceTypesMod,only : hlm_parteh_mode + use FatesInterfaceTypesMod,only : fates_interface_registry_base_type use FatesCohortMod, only : fates_cohort_type use FatesPatchMod, only : fates_patch_type use EDParamsMod, only : nclmax, nlevleaf, maxpft @@ -327,10 +328,15 @@ module EDTypesMod type, public :: ed_site_type - ! POINTERS + !! POINTERS + + ! patch pointers type (fates_patch_type), pointer :: oldest_patch => null() ! pointer to oldest patch at the site type (fates_patch_type), pointer :: youngest_patch => null() ! pointer to yngest patch at the site + ! interface pointer + type(fates_interface_registry_base_type), pointer :: api => null() ! pointer to the fates interface type api + ! Resource management type (ed_resources_management_type) :: resources_management ! resources_management at the site @@ -339,6 +345,10 @@ module EDTypesMod ! position in history output fields !integer :: clump_id + ! Arrays that map the HLM subgrid index for each patch in this site + integer, allocatable :: column_map(:) + integer, allocatable :: patch_map(:) + ! Global index of this site in the history output file integer :: h_gid diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 6f8bd6879d..6c3ad56c90 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -114,6 +114,7 @@ module FatesInterfaceMod use FatesTwoStreamUtilsMod, only : TransferRadParams use LeafBiophysicsMod , only : lb_params use LeafBiophysicsMod , only : FvCB1980 + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) @@ -160,7 +161,14 @@ module FatesInterfaceMod type(bc_pconst_type) :: bc_pconst + ! This is the interface registry which associates variables with a common keyword + ! FATES sites have a pointer to this, hence the "target" attribute + type(fates_interface_registry_base_type), pointer :: api + + contains + procedure, public :: UpdateInterfaceVariables + end type fates_interface_type character(len=*), parameter :: sourcefile = & @@ -186,7 +194,7 @@ module FatesInterfaceMod public :: DetermineGridCellNeighbors logical :: debug = .false. ! for debugging this module - + contains ! ==================================================================================== @@ -302,8 +310,6 @@ subroutine zero_bcs(fates,s) fates%bc_in(s)%tot_litc = 0.0_r8 fates%bc_in(s)%snow_depth_si = 0.0_r8 fates%bc_in(s)%frac_sno_eff_si = 0.0_r8 - fates%bc_in(s)%w_scalar_sisl(:) = 0.0_r8 - fates%bc_in(s)%t_scalar_sisl(:) = 0.0_r8 if(do_fates_salinity)then fates%bc_in(s)%salinity_sl(:) = 0.0_r8 @@ -500,8 +506,6 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats, allocate(bc_in%z_sisl(nlevsoil_in)) allocate(bc_in%decomp_id(nlevsoil_in)) allocate(bc_in%dz_decomp_sisl(nlevdecomp_in)) - allocate(bc_in%w_scalar_sisl(nlevsoil_in)) - allocate(bc_in%t_scalar_sisl(nlevsoil_in)) ! Lightning (or successful ignitions) and population density ! Fire related variables @@ -2691,7 +2695,44 @@ subroutine FatesReadParameters(param_reader) call fates_params%Destroy() deallocate(fates_params) + +end subroutine FatesReadParameters + +! ====================================================================================== + +subroutine UpdateInterfaceVariables(this) + + use FatesInterfaceTypesMod, only : subgrid_column_index + + class(fates_interface_type), intent(inout) :: this + + class(fates_interface_registry_base_type), pointer :: patch_api + class(fates_patch_type), pointer :: currentPatch - end subroutine FatesReadParameters + integer :: s ! site index + + do s = 1, this%nsites + currentPatch => this%sites(s)%oldest_patch + do while (associated(currentPatch)) + + patch_api => currentPatch%api + + ! Transfer the column index to the HLM interface registry + ! While this may be duplicative for older patches, we need + ! to ensure that the new patches are provided with the column index + this%api%subgrid_indices(subgrid_column_index) = this%sites(s)%column_map(currentPatch%patchno) + + ! Update the patch boundary condition via the HLM Interface data pointer + call patch_api%Update(this%api) + + ! TODO: Update the HLM interface variables with the patch variables here + + currentPatch => currentPatch%younger + end do + end do + +end subroutine UpdateInterfaceVariables + +! ====================================================================================== end module FatesInterfaceMod diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 06cdb7c606..64c555799c 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -2,11 +2,14 @@ module FatesInterfaceTypesMod use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue,ifalse + use FatesConstantsMod , only : fates_unset_int use FatesGlobals , only : fates_global_verbose use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun use shr_log_mod , only : errMsg => shr_log_errMsg use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + + use FatesInterfaceVariableTypeMod, only : fates_interface_variable_type implicit none @@ -281,6 +284,27 @@ module FatesInterfaceTypesMod integer, parameter, public :: fates_dispersal_cadence_monthly = 2 ! Disperse seeds monthly integer, parameter, public :: fates_dispersal_cadence_yearly = 3 ! Disperse seeds yearly + integer, parameter :: hlm_subgrid_levels = 5 ! The number of subgrid hierarchy levels that the HLM + ! Including the gridcell level, ELM = 5, CLM = 4 + + ! Subgrid levels for HLM-FATES interface variable + integer, parameter, public :: subgrid_gridcell_index = 5 + integer, parameter, public :: subgrid_topounit_index = 4 + integer, parameter, public :: subgrid_landunit_index = 3 + integer, parameter, public :: subgrid_column_index = 2 + integer, parameter, public :: subgrid_patch_index = 1 + + ! Registry keys parameters + character(len=*), parameter, public :: hlm_fates_soil_level = 'soil_level_number' + character(len=*), parameter, public :: hlm_fates_decomp_frac_moisture = 'decomp_frac_moisture' + character(len=*), parameter, public :: hlm_fates_decomp_frac_temperature = 'decomp_frac_temperature' + + ! Registry update frequency parameters + integer, parameter :: registry_update_init = 1 ! variable only needs to be updated during initialization + integer, parameter :: registry_update_daily = 2 ! variable needs to be updated daily + integer, parameter :: registry_update_timestep = 3 ! variable needs to be updated at each timestep + integer, parameter :: registry_update_types_num = 3 ! number of update frequency types + ! ------------------------------------------------------------------------------------- ! These vectors are used for history output mapping ! CLM/ALM have limited support for multi-dimensional history output arrays. @@ -841,13 +865,56 @@ module FatesInterfaceTypesMod end type bc_pconst_type + ! Base type to be extended for the API registry + type, public :: fates_interface_registry_base_type + + ! container array of interface variables + type(fates_interface_variable_type), allocatable :: vars(:) + + ! registry metadata + ! TODO: make an extended type for the HLM interface that holds the subgrid info + integer :: num_api_vars ! number of variables in the registry + integer :: num_api_vars_update_init ! number of variables that update only at initialization + integer :: num_api_vars_update_daily ! number of variables that update daily + + integer :: subgrid_indices(hlm_subgrid_levels) ! HLM patch ID associated with this patch + ! 1 = patch, 2 = column, 3 = landunit, 4 = topounit, 5 = gridcell + + ! Arrays that hold the indices of variables based on update frequency + integer, allocatable :: index_filter_init(:) ! index of variables that update only at initialization + integer, allocatable :: index_filter_daily(:) ! index of variables that update daily + ! integer, allocatable :: index_filter_timestep(:) ! index of variables that update at each timestep + + + contains + + procedure :: InitializeInterfaceRegistry + procedure :: InitializeInterfaceVariables + procedure :: Update => UpdateInterfaceVariables + + generic :: Register => RegisterInterfaceVariables_0d, & + RegisterInterfaceVariables_1d, & + RegisterInterfaceVariables_2d + procedure, private :: RegisterInterfaceVariables_0d + procedure, private :: RegisterInterfaceVariables_1d + procedure, private :: RegisterInterfaceVariables_2d + + procedure, private :: DefineInterfaceRegistry + procedure, private :: DefineInterfaceVariable + procedure, private :: SetFilterMapArrays + procedure, private :: GetRegistryIndex + procedure, private :: GetRegistryKey + + end type fates_interface_registry_base_type + public :: ZeroBCOutCarbonFluxes contains + - ! ====================================================================================== + ! ====================================================================================== - subroutine ZeroBCOutCarbonFluxes(bc_out) + subroutine ZeroBCOutCarbonFluxes(bc_out) ! !ARGUMENTS type(bc_out_type), intent(inout) :: bc_out @@ -859,6 +926,338 @@ subroutine ZeroBCOutCarbonFluxes(bc_out) end subroutine ZeroBCOutCarbonFluxes - - + ! ====================================================================================== + + subroutine InitializeInterfaceRegistry(this) + + ! This initializes the interface registry + + class(fates_interface_registry_base_type), intent(inout) :: this + + logical :: initialize + + ! initial registry integers + this%num_api_vars = 0 + this%num_api_vars_update_init = 0 + this%num_api_vars_update_daily = 0 + this%subgrid_indices = fates_unset_int + + ! First count up the keys defined in the registry + call this%DefineInterfaceRegistry(initialize=.false.) + + ! Allocate the registry variables array + allocate(this%vars(this%num_api_vars)) + + ! Allocate the index maps + allocate(this%index_filter_init(this%num_api_vars_update_init)) + allocate(this%index_filter_daily(this%num_api_vars_update_daily)) + + ! Now initialize the registry keys + call this%DefineInterfaceRegistry(initialize=.true.) + + ! Set filter map arrays + call this%SetFilterMapArrays() + + end subroutine InitializeInterfaceRegistry + + ! ====================================================================================== + + subroutine DefineInterfaceRegistry(this, initialize) + + ! This procedure defines the list of common names to be associated with FATES and HLM + ! variables. + + class(fates_interface_registry_base_type), intent(inout) :: this + + logical, intent(in) :: initialize ! false = count up the keys in the registry + + integer :: index ! Index to be incremented for each call to DefineInterfaceVariable() + + ! Initialize the index + index = 0 + + ! Define the interface registry names and indices + ! Variables that only need to be updated during initialization, such as dimensions + call this%DefineInterfaceVariable(key=hlm_fates_soil_level, initialize=initialize, index=index, & + update_frequency=registry_update_init) + + + ! Variables that need to be updated daily + call this%DefineInterfaceVariable(key=hlm_fates_decomp_frac_moisture, initialize=initialize, index=index) + call this%DefineInterfaceVariable(key=hlm_fates_decomp_frac_temperature, initialize=initialize, index=index) + + end subroutine DefineInterfaceRegistry + + ! ====================================================================================== + + subroutine DefineInterfaceVariable(this, key, initialize, index, update_frequency) + + class(fates_interface_registry_base_type), intent(inout) :: this + + character(len=*), intent(in) :: key + logical, intent(in) :: initialize + integer, intent(inout) :: index + integer, intent(in), optional :: update_frequency + + ! Local variables + integer :: index_type + integer :: update_frequency_local + + ! Increment the index + index = index + 1 + + ! If not initializing, increment the registry count variables, otherwise initialize the variable at the correct index + if (initialize) then + + ! Initialize the variable + if (present(update_frequency)) then + select case (update_frequency) + case (registry_update_init) + update_frequency_local = registry_update_init + case (registry_update_daily) + update_frequency_local = registry_update_daily + case default + write(fates_log(),*) 'ERROR: Unrecognized update frequency in DefineInterfaceVariable(): ', update_frequency + call endrun(msg=errMsg(__FILE__, __LINE__)) + end select + else + ! Default to daily update frequency + update_frequency_local = registry_update_daily + end if + + call this%vars(index)%Initialize(key, update_frequency_local) + + ! Not initializing, just counting the variables + else + + ! Increment the total API count + this%num_api_vars = this%num_api_vars + 1 + + ! Increment the count for the update frequency counts, defaulting to daily if not specified + if (present(update_frequency)) then + select case (update_frequency) + case (registry_update_init) + this%num_api_vars_update_init = this%num_api_vars_update_init + 1 + case (registry_update_daily) + this%num_api_vars_update_daily = this%num_api_vars_update_daily + 1 + case default + write(fates_log(),*) 'ERROR: Unrecognized update frequency in DefineInterfaceVariable(): ', update_frequency + call endrun(msg=errMsg(__FILE__, __LINE__)) + end select + else + ! Default to daily update frequency + this%num_api_vars_update_daily = this%num_api_vars_update_daily + 1 + end if + + end if + + end subroutine DefineInterfaceVariable + + ! ====================================================================================== + + subroutine SetFilterMapArrays(this) + + class(fates_interface_registry_base_type), intent(inout) :: this + + integer :: index + integer :: count_init + integer :: count_daily + + ! Initialize counters + count_init = 0 + count_daily = 0 + + ! Iterate over all registered variables and populate the filter maps accordingly + do index = 1, this%num_api_vars + if (this%vars(index)%update_frequency == registry_update_init) then + count_init = count_init + 1 + this%index_filter_init(count_init) = index + else if (this%vars(index)%update_frequency == registry_update_daily) then + count_daily = count_daily + 1 + this%index_filter_daily(count_daily) = index + else + write(fates_log(),*) 'ERROR: Unrecognized update frequency in SetFilterMapArrays(): ', this%vars(index)%update_frequency + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + end do + + ! Check that the counts match the expected sizes + if (count_init /= this%num_api_vars_update_init .or. & + count_daily /= this%num_api_vars_update_daily) then + + write(fates_log(),*) 'ERROR: Mismatch in initialization counts in SetFilterMapArrays(): ' + write(fates_log(),*) ' count_init = ', count_init, ' expected = ', this%num_api_vars_update_init + write(fates_log(),*) ' count_daily = ', count_daily, ' expected = ', this%num_api_vars_update_daily + call endrun(msg=errMsg(__FILE__, __LINE__)) + + end if + + end subroutine SetFilterMapArrays + + ! ====================================================================================== + + subroutine RegisterInterfaceVariables_0d(this, key, data, subgrid_index) + + ! This procedure is called by the to associate a data variable + ! with a particular registry key + + class(fates_interface_registry_base_type), intent(inout) :: this + + class(*), target, intent(in) :: data ! data to be associated with key + character(len=*), intent(in) :: key ! variable registry key + integer, intent(in), optional :: subgrid_index ! HLM subgrid index to associate with this variable + + integer :: subgrid_index_use + + if (present(subgrid_index)) then + subgrid_index_use = subgrid_index + else + subgrid_index_use = subgrid_patch_index + end if + + ! Get index from registry key and associate the given data pointer + call this%vars(this%GetRegistryIndex(key))%Register(data, active=.true., subgrid_index=subgrid_index_use) + + end subroutine RegisterInterfaceVariables_0d + + ! ====================================================================================== + + subroutine RegisterInterfaceVariables_1d(this, key, data, subgrid_index) + + ! This procedure is called by the to associate a data variable + ! with a particular registry key + + class(fates_interface_registry_base_type), intent(inout) :: this + + class(*), target, intent(in) :: data(:) ! data to be associated with key + character(len=*), intent(in) :: key ! variable registry key + integer, intent(in), optional :: subgrid_index ! HLM subgrid index to associate with this variable + + integer :: subgrid_index_use + + if (present(subgrid_index)) then + subgrid_index_use = subgrid_index + else + subgrid_index_use = subgrid_patch_index + end if + + ! Get index from registry key and associate the given data pointer + call this%vars(this%GetRegistryIndex(key))%Register(data(:), active=.true., subgrid_index=subgrid_index_use) + + end subroutine RegisterInterfaceVariables_1d + + ! ====================================================================================== + + subroutine RegisterInterfaceVariables_2d(this, key, data, subgrid_index) + + ! This procedure is called by the to associate a data variable + ! with a particular registry key + + class(fates_interface_registry_base_type), intent(inout) :: this + + class(*), target, intent(in) :: data(:,:) ! data to be associated with key + character(len=*), intent(in) :: key ! variable registry key + integer, intent(in), optional :: subgrid_index ! HLM subgrid index to associate with this variable + + integer :: subgrid_index_use + + if (present(subgrid_index)) then + subgrid_index_use = subgrid_index + else + subgrid_index_use = subgrid_patch_index + end if + + ! Get index from registry key and associate the given data pointer + call this%vars(this%GetRegistryIndex(key))%Register(data(:,:), active=.true., subgrid_index=subgrid_index_use) + + end subroutine RegisterInterfaceVariables_2d + + ! ====================================================================================== + + subroutine InitializeInterfaceVariables(this, api) + + class(fates_interface_registry_base_type), intent(inout) :: this ! registry being initialized + class(fates_interface_registry_base_type), intent(in) :: api ! registry updates source + + integer :: i, j + integer :: index_i, index_j + + ! Update the interface variables that are dimensions for fates boundary conditions + do i = 1, this%num_api_vars_update_init + + ! Get the index for the key associated with the current registry variable + j = api%GetRegistryIndex(api%GetRegistryKey(i)) + + ! Get the index for initialization-only variables + index_i = this%index_filter_init(i) + index_j = api%index_filter_init(j) + + ! Set the registry variables updated at initialization + call this%vars(index_i)%Update(api%vars(index_j), api%subgrid_indices) + + end do + + end subroutine InitializeInterfaceVariables + + ! ====================================================================================== + + subroutine UpdateInterfaceVariables(this, api) + + class(fates_interface_registry_base_type), intent(inout) :: this ! registry being updated + class(fates_interface_registry_base_type), intent(in) :: api ! registry update source + + integer :: i + integer :: j + + ! Iterate over all registered variables + do i = 1, this%num_api_vars + + ! Don't assume the index in the calling registry is the same as in the input registry + j = api%GetRegistryIndex(api%GetRegistryKey(i)) + + ! Update the registered variable and pass the subgrid indices information + call this%vars(i)%Update(api%vars(j), api%subgrid_indices) + end do + + end subroutine UpdateInterfaceVariables + + ! ====================================================================================== + + integer function GetRegistryIndex(this, key) result(index) + + ! This procedure returns the index associated with the key provided + + class(fates_interface_registry_base_type), intent(in) :: this + + character(len=*), intent(in) :: key ! variable registry key to search + + integer :: ivar ! Iterator + + ! Iterate over the registry until the associated key is found + do ivar = 1, this%num_api_vars + if (this%vars(ivar)%key == key) then + index = ivar + return + end if + end do + + end function GetRegistryIndex + + ! ====================================================================================== + + function GetRegistryKey(this, index) result(key) + + ! This procedure returns the index associated with the key provided + + class(fates_interface_registry_base_type), intent(in) :: this + + integer, intent(in) :: index ! variable registry index + character(len=:), allocatable :: key + + key = this%vars(index)%key + + end function GetRegistryKey + + ! ====================================================================================== + end module FatesInterfaceTypesMod diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 new file mode 100644 index 0000000000..9c21f21b69 --- /dev/null +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -0,0 +1,303 @@ +module FatesInterfaceVariableTypeMod + + ! This module contains the type definition and associated type-bound procedures + ! used to create an indexed list of associated HLM and FATES variables that are + ! related across the application programming interface. + ! This method is largely inspired by the FATES history infrastructure + + use shr_log_mod , only : errMsg => shr_log_errMsg + + use FatesGlobals, only : fates_log + use FatesGlobals, only : endrun => fates_endrun + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : fates_long_string_length + use FatesConstantsMod, only : fates_unset_int + + implicit none + private + + ! Interface registry variable type + type, public :: fates_interface_variable_type + + character(len=48) :: key ! common registry key + class(*), pointer :: data0d ! scalar polymorphic data pointer + class(*), pointer :: data1d(:) ! 1D polymorphic data pointer + class(*), pointer :: data2d(:,:) ! 2D polymorphic data pointer + class(*), pointer :: data3d(:,:,:) ! 3D polymorphic data pointer + logical :: active ! true if the variable is used by the host land model + integer :: subgrid ! subgrid level (0 = gridcell, 1 = landunit, 2 = column, 3 = patch) + integer :: data_rank ! rank of the variable (0, 1, 2, or 3) + integer :: update_frequency ! frequency of updates + integer, allocatable :: data_size(:) ! size of the first dimension of the variable + + contains + procedure :: Initialize => InitializeInterfaceVariable + procedure :: Update => UpdateInterfaceVariable + + generic :: Register => RegisterInterfaceVariable_0d, & + RegisterInterfaceVariable_1d, & + RegisterInterfaceVariable_2d + procedure, private :: RegisterInterfaceVariable_0d + procedure, private :: RegisterInterfaceVariable_1d + procedure, private :: RegisterInterfaceVariable_2d + + procedure, private :: CompareRegistryVariableSizes + + end type fates_interface_variable_type + + contains + + ! ==================================================================================== + + subroutine InitializeInterfaceVariable(this, key, update_frequency) + + class(fates_interface_variable_type), intent(inout) :: this + character(len=*), intent(in) :: key + integer, intent(in) :: update_frequency + + + allocate(this%data_size(3)) + + ! Initialize components that are set later + this%data_size = fates_unset_int + this%data_rank = fates_unset_int + this%data0d => null() + this%data1d => null() + this%data2d => null() + this%data3d => null() + this%active = .false. + + ! Initialize registry variable components that are updated at initialization + this%key = key + this%update_frequency = update_frequency + + end subroutine InitializeInterfaceVariable + + ! ==================================================================================== + + subroutine RegisterInterfaceVariable_0d(this, data, active, subgrid_index) + + class(fates_interface_variable_type), intent(inout) :: this + + class(*), target, intent(in) :: data + logical, intent(in) :: active + integer, intent(in) :: subgrid_index + + this%data0d => data + this%active = active + this%subgrid = subgrid_index + this%data_rank = rank(data) + + end subroutine RegisterInterfaceVariable_0d + + ! ==================================================================================== + + subroutine RegisterInterfaceVariable_1d(this, data, active, subgrid_index) + + class(fates_interface_variable_type), intent(inout) :: this + + class(*), target, intent(in) :: data(:) + logical, intent(in) :: active + integer, intent(in) :: subgrid_index + + this%data1d => data(:) + this%active = active + this%subgrid = subgrid_index + this%data_rank = rank(data) + this%data_size(1) = size(data, dim=1) + + end subroutine RegisterInterfaceVariable_1d + + ! ==================================================================================== + + subroutine RegisterInterfaceVariable_2d(this, data, active, subgrid_index) + + class(fates_interface_variable_type), intent(inout) :: this + + class(*), target, intent(in) :: data(:,:) + logical, intent(in) :: active + integer, intent(in) :: subgrid_index + + this%data2d => data(:,:) + this%active = active + this%subgrid = subgrid_index + this%data_rank = rank(data) + this%data_size(1) = size(data, dim=1) + this%data_size(2) = size(data, dim=2) + + end subroutine RegisterInterfaceVariable_2d + + ! ==================================================================================== + + subroutine UpdateInterfaceVariable(this, var, subgrid_indices) + + class(fates_interface_variable_type), intent(inout) :: this ! variable being updated + class(fates_interface_variable_type), intent(in) :: var ! variable update source + integer, intent(in) :: subgrid_indices(:) ! subgrid indices for the update source + + class(*), pointer :: data_var0d => null() + class(*), pointer :: data_var1d(:) => null() + class(*), pointer :: data_var2d(:,:) => null() + class(*), pointer :: data_var3d(:,:,:) => null() + + integer :: index ! index for the subgrid level of the input interface variable + character(len=fates_long_string_length) :: msg_mismatch = 'FATES ERROR: Mismatched interface variable types' + + ! This update method assumes that the first rank of the HLM data arrays + ! corresponds to the subgrid level of the interface variable type. + ! E.g. col_cf%w_scalar(c,1:nlevsoil) shows that the first dimension is the column index. + ! TODO: This should be held in an interface requirements document. + + ! Get the subgrid index for the updating variable + index = subgrid_indices(var%subgrid) + + ! Check that the index is valid + if (index == fates_unset_int) then + write(fates_log(),*) 'FATES ERROR: Unset subgrid index in UpdateInterfaceVariable' + write(fates_log(),*) ' Variable key, subgrid level: ', var%key, var%subgrid + write(fates_log(),*) ' API subgrid indices: ', subgrid_indices + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + ! Update the data pointer based on the rank of the source variable while indexing + ! into the appropriate subgrid level + ! TODO: This assumes HLM->FATES direction; Validate this for FATES->HLM direction + select case (var%data_rank) + case(0) + data_var0d => var%data0d + case(1) + data_var0d => var%data1d(index) + case(2) + data_var1d => var%data2d(index,:) + case(3) + data_var2d => var%data3d(index,:,:) + case default + write(fates_log(),*) 'FATES ERROR: Unsupported interface variable input rank in UpdateInterfaceVariable' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end select + + ! Update the data of the target variable using the source variable data pointer + ! Make sure the types match for the polymorphic data to allow for copying from the + ! source to the target. + ! Note that due to the use of polymorphic pointers, we must use select type constructs + ! to determine the actual type of the data being pointed to allowing for type-safe assignment. + ! This currently only supports real and integer types and no conversion between types + ! should be performed + select case (this%data_rank) + case(0) + select type(dest => this%data0d) + type is (real(r8)) + select type(source => data_var0d) + type is (real(r8)) + dest = source + class default + write(fates_log(),*), msg_mismatch + call endrun(msg=errMsg(__FILE__, __LINE__)) + end select + type is (integer) + select type(source => data_var0d) + type is (integer) + dest = source + class default + write(fates_log(),*), msg_mismatch + call endrun(msg=errMsg(__FILE__, __LINE__)) + end select + class default + write(fates_log(),*), 'FATES ERROR: Unsupported interface variable type' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end select + + case(1) + + ! Check that the dimensions of the source and target match + call this%CompareRegistryVariableSizes(var) + + select type(dest => this%data1d) + type is (real(r8)) + select type(source => data_var1d) + type is (real(r8)) + dest = source + class default + write(fates_log(),*), msg_mismatch + call endrun(msg=errMsg(__FILE__, __LINE__)) + end select + type is (integer) + select type(source => data_var1d) + type is (integer) + dest = source + class default + write(fates_log(),*), msg_mismatch + call endrun(msg=errMsg(__FILE__, __LINE__)) + end select + class default + write(fates_log(),*), 'FATES ERROR: Unsupported interface variable type' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end select + case(2) + + ! Check that the dimensions of the source and target match + call this%CompareRegistryVariableSizes(var) + + select type(dest => this%data2d) + type is (real(r8)) + select type(source => data_var2d) + type is (real(r8)) + dest = source + class default + write(fates_log(),*), msg_mismatch + call endrun(msg=errMsg(__FILE__, __LINE__)) + end select + type is (integer) + select type(source => data_var2d) + type is (integer) + dest = source + class default + write(fates_log(),*), msg_mismatch + call endrun(msg=errMsg(__FILE__, __LINE__)) + end select + class default + write(fates_log(),*), 'FATES ERROR: Unsupported interface variable type' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end select + case default + write(fates_log(),*) 'FATES ERROR: Unsupported interface variable target rank in UpdateInterfaceVariable' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end select + + end subroutine UpdateInterfaceVariable + + ! ==================================================================================== + + subroutine CompareRegistryVariableSizes(this, var) + + class(fates_interface_variable_type), intent(in) :: this ! variable being updated + class(fates_interface_variable_type), intent(in) :: var ! variable update source + + if (this%data_size(1) /= var%data_size(1) .or. & + this%data_size(2) /= var%data_size(2) .or. & + this%data_size(3) /= var%data_size(3)) then + + write(fates_log(),*) 'FATES ERROR: Mismatched interface variable sizes in UpdateInterfaceVariable' + + if (this%data_rank == 1) then + write(fates_log(),*) ' Target, size: ', this%key, this%data_size(1) + write(fates_log(),*) ' Source, size: ', var%key, var%data_size(1) + else if (this%data_rank == 2) then + write(fates_log(),*) ' Target, size: ', this%key, this%data_size(1), this%data_size(2) + write(fates_log(),*) ' Source, size: ', var%key, var%data_size(1), var%data_size(2) + else if (this%data_rank == 3) then + write(fates_log(),*) ' Target, size: ', this%key, this%data_size(1), this%data_size(2), this%data_size(3) + write(fates_log(),*) ' Source, size: ', var%key, var%data_size(1), var%data_size(2), var%data_size(3) + else + write(fates_log(),*) ' Unsupported interface variable rank in UpdateErrorMessage' + end if + + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + end subroutine CompareRegistryVariableSizes + + ! ==================================================================================== + +end module FatesInterfaceVariableTypeMod \ No newline at end of file diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 6673f4b819..61a162a952 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -284,7 +284,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) allocate(newpatch) call newpatch%Create(age_init, area_init, primaryland, & fates_unset_int, num_swb, numpft, sites(s)%nlevsoil, & - hlm_current_tod, hlm_regeneration_model) + hlm_current_tod, hlm_regeneration_model, sites(s)%api) newpatch%patchno = ipa newpatch%younger => null() diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index d3a73d55a9..6f99b9c07e 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -2859,7 +2859,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in, bc_out) io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) - call init_site_vars( sites(s), bc_in(s), bc_out(s) ) + call init_site_vars( sites(s), bc_in(s) ) call zero_site( sites(s) ) if ( rio_npatch_si(io_idx_si)<0 .or. rio_npatch_si(io_idx_si) > 10000 ) then @@ -2886,7 +2886,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in, bc_out) ! make new patch call newp%Create(fates_unset_r8, fates_unset_r8, primaryland, & nocomp_pft, num_swb, numpft, sites(s)%nlevsoil, & - hlm_current_tod, hlm_regeneration_model) + hlm_current_tod, hlm_regeneration_model, sites(s)%api) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches