From dc963518bf82e6125e917d410c13a085f345ceeb Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 20 May 2025 15:50:35 -0700 Subject: [PATCH 001/113] initial sketch of limited bc refactor subroutine update --- biogeochem/FatesPatchMod.F90 | 7 +++++++ main/FatesInterfaceMod.F90 | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 40 insertions(+) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index 9b3b9ef919..e659fa97d0 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -32,6 +32,8 @@ 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 shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) use shr_log_mod, only : errMsg => shr_log_errMsg @@ -48,6 +50,11 @@ 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 !--------------------------------------------------------------------------- diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 555fa526c1..346afc5bad 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -181,6 +181,7 @@ module FatesInterfaceMod public :: set_bcs public :: UpdateFatesRMeansTStep public :: InitTimeAveragingGlobals + public :: TransferBCIn private :: FatesReadParameters public :: DetermineGridCellNeighbors @@ -2675,4 +2676,36 @@ subroutine FatesReadParameters(param_reader) end subroutine FatesReadParameters +! ====================================================================================== + + subroutine TransferBCIn(this, transfer_array) + + + type(ed_site_type), intent(inout) :: this + real, intent(in) :: transfer_array(:,:) + + type(fates_patch_type), pointer :: currentPatch + + integer :: ifp + + currentPatch => this%oldest_patch + + ifp = 1 + do while associated(currentPatch) + + ! Set the HLM array index - TODO import multicolumn switch + if (multicolumn_singlesite) ifp = currentPatch%patchno + + currentPatch%bc_in%w_scalar_sisl = transfer_array(currentPatch%patchno,:) + + ! TODO - if not multicolumn, all younger patches should point to older patch, + ! IF input is column level or higher! + + currentPatch => this%younger + end do + + end subroutine TransferBCIn + + +! ====================================================================================== end module FatesInterfaceMod From 6550af3f17e0fec0819595953563b036233f0fb9 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 21 May 2025 10:56:49 -0700 Subject: [PATCH 002/113] converting the transfer procedure to be more generic --- main/FatesInterfaceMod.F90 | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 346afc5bad..d977b746a5 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2678,11 +2678,13 @@ end subroutine FatesReadParameters ! ====================================================================================== - subroutine TransferBCIn(this, transfer_array) + subroutine TransferBCIn(this, tag, transfer_array) + ! TODO - make an interface and dimensional versions of this subroutine? type(ed_site_type), intent(inout) :: this - real, intent(in) :: transfer_array(:,:) + character(len=*), intent(in) :: tag + real(r8), pointer, intent(in) :: transfer_array(:,:) type(fates_patch_type), pointer :: currentPatch @@ -2693,13 +2695,18 @@ subroutine TransferBCIn(this, transfer_array) ifp = 1 do while associated(currentPatch) - ! Set the HLM array index - TODO import multicolumn switch - if (multicolumn_singlesite) ifp = currentPatch%patchno + ! TODO import multicolumn switch + !if (multicolumn_singlesite) ifp = currentPatch%patchno - currentPatch%bc_in%w_scalar_sisl = transfer_array(currentPatch%patchno,:) + select case(trim(tag)) + + case('decomp_frac_moisture') + currentPatch%bc_in%w_scalar_sisl = transfer_array(ifp,:) ! TODO - if not multicolumn, all younger patches should point to older patch, ! IF input is column level or higher! + ! Given this, should the patch level bc subtypes actually be pointers to the + ! input values instead of copies of the pointer data? currentPatch => this%younger end do From 57b4c3d94550f95a0ea8d8f063fbbba3cc96e86f Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 21 May 2025 11:39:41 -0700 Subject: [PATCH 003/113] update to temporary design comment --- main/FatesInterfaceMod.F90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index d977b746a5..1654cd319e 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2703,10 +2703,11 @@ subroutine TransferBCIn(this, tag, transfer_array) case('decomp_frac_moisture') currentPatch%bc_in%w_scalar_sisl = transfer_array(ifp,:) - ! TODO - if not multicolumn, all younger patches should point to older patch, - ! IF input is column level or higher! - ! Given this, should the patch level bc subtypes actually be pointers to the - ! input values instead of copies of the pointer data? + ! NOTE: should the patch level bc subtypes actually be pointers to the + ! input values instead of copies of the pointer data? Or is not a good idea + ! since the HLM runs on a different time step than fates? + ! If these are not pointers then we really don't have a good way to avoid + ! memory duplicity. currentPatch => this%younger end do From 437149bd120c96622b53fef4abb76fc98308ffa9 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 21 May 2025 20:26:19 -0700 Subject: [PATCH 004/113] add generic interface for transfer bc in with different ranks --- main/FatesInterfaceMod.F90 | 64 ++++++++++++++++++++++++++++++++------ 1 file changed, 55 insertions(+), 9 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 1654cd319e..4a0436b36d 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -187,9 +187,19 @@ module FatesInterfaceMod public :: DetermineGridCellNeighbors logical :: debug = .false. ! for debugging this module - + + contains + ! ==================================================================================== + interface TransferBCIn(this, tag, data) + + module procedure TransferBCIn_1d + module procedure TransferBCIn_2d + module procedure TransferBCIn_3d + + end interface TransferBCIn + ! ==================================================================================== subroutine FatesInterfaceInit(log_unit,global_verbose) @@ -2678,30 +2688,66 @@ end subroutine FatesReadParameters ! ====================================================================================== - subroutine TransferBCIn(this, tag, transfer_array) + subroutine TransferBCIn_1d(this, tag, data) + + ! TODO - make an interface and dimensional versions of this subroutine? + + type(ed_site_type), intent(inout) :: this + character(len=*), intent(in) :: tag + real(r8), pointer, intent(in) :: data(:) + + type(fates_patch_type), pointer :: currentPatch + + ! LOCAL + integer :: ifc ! HLM column index + + currentPatch => this%oldest_patch + + do while associated(currentPatch) + + p = this%patch_map(currentPatch%patchno) + + select case(trim(tag)) + + case('leaf_area_index') + currentPatch%bc_in%hlm_sp_tlai = data(p) + ! currentPatch%bc_in%w_scalar_sisl => transfer_array(ifp,:) + + ! NOTE: should the patch level bc subtypes actually be pointers to the + ! input values instead of copies of the pointer data? Or is not a good idea + ! since the HLM runs on a different time step than fates? + ! If these are not pointers then we really don't have a good way to avoid + ! memory duplicity. + + currentPatch => this%younger + end do + +! ====================================================================================== + + subroutine TransferBCIn_2d(this, tag, data) ! TODO - make an interface and dimensional versions of this subroutine? type(ed_site_type), intent(inout) :: this character(len=*), intent(in) :: tag - real(r8), pointer, intent(in) :: transfer_array(:,:) + real(r8), pointer, intent(in) :: data(:,:) type(fates_patch_type), pointer :: currentPatch - integer :: ifp + ! LOCAL + integer :: c ! HLM column index currentPatch => this%oldest_patch - ifp = 1 do while associated(currentPatch) - ! TODO import multicolumn switch - !if (multicolumn_singlesite) ifp = currentPatch%patchno + c = this%column_map(currentPatch%patchno) select case(trim(tag)) case('decomp_frac_moisture') - currentPatch%bc_in%w_scalar_sisl = transfer_array(ifp,:) + currentPatch%bc_in%w_scalar_sisl = data(c,:) + ! currentPatch%bc_in%w_scalar_sisl => transfer_array(ifp,:) ! NOTE: should the patch level bc subtypes actually be pointers to the ! input values instead of copies of the pointer data? Or is not a good idea @@ -2712,7 +2758,7 @@ subroutine TransferBCIn(this, tag, transfer_array) currentPatch => this%younger end do - end subroutine TransferBCIn + end subroutine TransferBCIn_2d ! ====================================================================================== From 5ab259ae180389841ac63d70b9d0c2187a429a9e Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 2 Jul 2025 09:50:18 -0700 Subject: [PATCH 005/113] remove unused bc_out from init_site_vars --- main/EDInitMod.F90 | 5 ++--- main/FatesRestartInterfaceMod.F90 | 2 +- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 314a93adbd..def23c9c30 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: !---------------------------------------------------------------------- diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index f2c78051a1..6f5f914e4f 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -2869,7 +2869,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 From 3b5c62996758d40f71f3bd4263ba4e2d31d53fca Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 2 Jul 2025 09:55:26 -0700 Subject: [PATCH 006/113] remove unnecessary bc_in argument from canopy_summarization --- biogeochem/EDCanopyStructureMod.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) 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 From fc612308238d73c3bf948bc631855bb2036189f5 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 2 Jul 2025 09:58:00 -0700 Subject: [PATCH 007/113] remove unnecessary bc_out argument for accumulatefluxes_ed --- biogeophys/EDAccumulateFluxesMod.F90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) 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: From b9b40ace3637f259cabf372fbde500099a79a0da Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 15 Jul 2025 15:30:00 -0700 Subject: [PATCH 008/113] fix interface for module procedures --- main/FatesInterfaceMod.F90 | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 7de70cb442..8645aca917 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -188,11 +188,7 @@ module FatesInterfaceMod logical :: debug = .false. ! for debugging this module - -contains - - ! ==================================================================================== - interface TransferBCIn(this, tag, data) + interface TransferBCIn module procedure TransferBCIn_1d module procedure TransferBCIn_2d @@ -200,6 +196,8 @@ module FatesInterfaceMod end interface TransferBCIn +contains + ! ==================================================================================== subroutine FatesInterfaceInit(log_unit,global_verbose) From 62794b28cac9c8f34196ad3c83e58bb9f141919c Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 15 Jul 2025 15:35:25 -0700 Subject: [PATCH 009/113] correct do while statement --- main/FatesInterfaceMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 8645aca917..083fdc60c8 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2720,7 +2720,7 @@ subroutine TransferBCIn_1d(this, tag, data) currentPatch => this%oldest_patch - do while associated(currentPatch) + do while (associated(currentPatch)) p = this%patch_map(currentPatch%patchno) @@ -2756,7 +2756,7 @@ subroutine TransferBCIn_2d(this, tag, data) currentPatch => this%oldest_patch - do while associated(currentPatch) + do while (associated(currentPatch)) c = this%column_map(currentPatch%patchno) From f80185ce66e5d9ef4c15e9dee76366c4b2e22203 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 15 Jul 2025 15:42:47 -0700 Subject: [PATCH 010/113] correct select case and younger patch association --- main/FatesInterfaceMod.F90 | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 083fdc60c8..a6a527e930 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2736,7 +2736,10 @@ subroutine TransferBCIn_1d(this, tag, data) ! If these are not pointers then we really don't have a good way to avoid ! memory duplicity. - currentPatch => this%younger + end select + + currentPatch => currentPatch%younger + end do ! ====================================================================================== @@ -2772,7 +2775,10 @@ subroutine TransferBCIn_2d(this, tag, data) ! If these are not pointers then we really don't have a good way to avoid ! memory duplicity. - currentPatch => this%younger + end select + + currentPatch => currentPatch%younger + end do end subroutine TransferBCIn_2d From 3424c9191a98c601e8bac2c719736493c30f6cb6 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 15 Jul 2025 15:51:27 -0700 Subject: [PATCH 011/113] add missing end subroutine statment --- main/FatesInterfaceMod.F90 | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index a6a527e930..a3206e3fa4 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2707,8 +2707,6 @@ end subroutine FatesReadParameters subroutine TransferBCIn_1d(this, tag, data) - ! TODO - make an interface and dimensional versions of this subroutine? - type(ed_site_type), intent(inout) :: this character(len=*), intent(in) :: tag real(r8), pointer, intent(in) :: data(:) @@ -2742,12 +2740,12 @@ subroutine TransferBCIn_1d(this, tag, data) end do + end subroutine TransferBCIn_1d + ! ====================================================================================== subroutine TransferBCIn_2d(this, tag, data) - ! TODO - make an interface and dimensional versions of this subroutine? - type(ed_site_type), intent(inout) :: this character(len=*), intent(in) :: tag real(r8), pointer, intent(in) :: data(:,:) @@ -2783,6 +2781,5 @@ subroutine TransferBCIn_2d(this, tag, data) end subroutine TransferBCIn_2d - ! ====================================================================================== end module FatesInterfaceMod From dedfd4aef230c6be7ce5472bcccb7a87eb87d17f Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 15 Jul 2025 15:55:30 -0700 Subject: [PATCH 012/113] temporarily comment out the 3d option --- main/FatesInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index a3206e3fa4..c8d4795efd 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -192,7 +192,7 @@ module FatesInterfaceMod module procedure TransferBCIn_1d module procedure TransferBCIn_2d - module procedure TransferBCIn_3d + !module procedure TransferBCIn_3d end interface TransferBCIn From 8307ca6db00367032c631f097f7836be728c8736 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 16 Jul 2025 15:31:58 -0700 Subject: [PATCH 013/113] add site-level mapping vectors --- main/EDTypesMod.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 701a95eeb2..9ad1b12e8f 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -340,6 +340,9 @@ module EDTypesMod ! position in history output fields !integer :: clump_id + integer, allocatable :: column_map(:) + integer, allocatable :: patch_map(:) + ! Global index of this site in the history output file integer :: h_gid From 1f11e96177494bd49e8aa2cd7c97b07fbab4855a Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 16 Jul 2025 15:38:53 -0700 Subject: [PATCH 014/113] fix incorrect index definition --- main/FatesInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index c8d4795efd..a922ba3bd9 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2714,7 +2714,7 @@ subroutine TransferBCIn_1d(this, tag, data) type(fates_patch_type), pointer :: currentPatch ! LOCAL - integer :: ifc ! HLM column index + integer :: p ! patch index currentPatch => this%oldest_patch From a163f0aaf4fda64e6e244fc4e2959474757e77ee Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 16 Jul 2025 17:12:42 -0700 Subject: [PATCH 015/113] move BC transfer procedure from interface mod to site as type-bound procedure --- main/EDTypesMod.F90 | 88 ++++++++++++++++++++++++++++++++++++++ main/FatesInterfaceMod.F90 | 88 -------------------------------------- 2 files changed, 88 insertions(+), 88 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 9ad1b12e8f..53f7960d80 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -569,10 +569,18 @@ module EDTypesMod logical, allocatable :: landuse_vector_gt_min(:) ! is the land use state vector for each land use type greater than the minimum below which we ignore? logical :: transition_landuse_from_off_to_on ! special flag to use only when reading restarts, which triggers procedure to initialize land use + ! interface TransferBCIn + ! module procedure TransferBCIn_1d + ! module procedure TransferBCIn_2d + ! !module procedure TransferBCIn_3d + ! end interface TransferBCIn + contains procedure, public :: get_current_landuse_statevector procedure, public :: get_secondary_young_fraction + procedure, public :: TransferBCIn_1d + procedure, public :: TransferBCIn_2d end type ed_site_type @@ -833,4 +841,84 @@ function get_secondary_young_fraction(this) result(secondary_young_fraction) end function get_secondary_young_fraction + ! ====================================================================================== + + subroutine TransferBCIn_1d(this, tag, data) + + class(ed_site_type), intent(inout) :: this + character(len=*), intent(in) :: tag + real(r8), pointer, intent(in) :: data(:) + + type(fates_patch_type), pointer :: currentPatch + + ! LOCAL + integer :: p ! patch index + + currentPatch => this%oldest_patch + + do while (associated(currentPatch)) + + p = this%patch_map(currentPatch%patchno) + + select case(trim(tag)) + + case('leaf_area_index') + currentPatch%bc_in%hlm_sp_tlai = data(p) + ! currentPatch%bc_in%w_scalar_sisl => transfer_array(ifp,:) + + ! NOTE: should the patch level bc subtypes actually be pointers to the + ! input values instead of copies of the pointer data? Or is not a good idea + ! since the HLM runs on a different time step than fates? + ! If these are not pointers then we really don't have a good way to avoid + ! memory duplicity. + + end select + + currentPatch => currentPatch%younger + + end do + + end subroutine TransferBCIn_1d + + ! ====================================================================================== + + subroutine TransferBCIn_2d(this, tag, data) + + class(ed_site_type), intent(inout) :: this + character(len=*), intent(in) :: tag + real(r8), pointer, intent(in) :: data(:,:) + + type(fates_patch_type), pointer :: currentPatch + + ! LOCAL + integer :: c ! HLM column index + + currentPatch => this%oldest_patch + + do while (associated(currentPatch)) + + c = this%column_map(currentPatch%patchno) + + select case(trim(tag)) + + case('decomp_frac_moisture') + currentPatch%bc_in%w_scalar_sisl = data(c,:) + ! currentPatch%bc_in%w_scalar_sisl => transfer_array(ifp,:) + + ! NOTE: should the patch level bc subtypes actually be pointers to the + ! input values instead of copies of the pointer data? Or is not a good idea + ! since the HLM runs on a different time step than fates? + ! If these are not pointers then we really don't have a good way to avoid + ! memory duplicity. + + end select + + currentPatch => currentPatch%younger + + end do + + end subroutine TransferBCIn_2d + +! ====================================================================================== + end module EDTypesMod diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index a922ba3bd9..aed76ea5c8 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -181,21 +181,12 @@ module FatesInterfaceMod public :: set_bcs public :: UpdateFatesRMeansTStep public :: InitTimeAveragingGlobals - public :: TransferBCIn private :: FatesReadParameters public :: DetermineGridCellNeighbors logical :: debug = .false. ! for debugging this module - interface TransferBCIn - - module procedure TransferBCIn_1d - module procedure TransferBCIn_2d - !module procedure TransferBCIn_3d - - end interface TransferBCIn - contains ! ==================================================================================== @@ -2703,83 +2694,4 @@ subroutine FatesReadParameters(param_reader) end subroutine FatesReadParameters -! ====================================================================================== - - subroutine TransferBCIn_1d(this, tag, data) - - type(ed_site_type), intent(inout) :: this - character(len=*), intent(in) :: tag - real(r8), pointer, intent(in) :: data(:) - - type(fates_patch_type), pointer :: currentPatch - - ! LOCAL - integer :: p ! patch index - - currentPatch => this%oldest_patch - - do while (associated(currentPatch)) - - p = this%patch_map(currentPatch%patchno) - - select case(trim(tag)) - - case('leaf_area_index') - currentPatch%bc_in%hlm_sp_tlai = data(p) - ! currentPatch%bc_in%w_scalar_sisl => transfer_array(ifp,:) - - ! NOTE: should the patch level bc subtypes actually be pointers to the - ! input values instead of copies of the pointer data? Or is not a good idea - ! since the HLM runs on a different time step than fates? - ! If these are not pointers then we really don't have a good way to avoid - ! memory duplicity. - - end select - - currentPatch => currentPatch%younger - - end do - - end subroutine TransferBCIn_1d - -! ====================================================================================== - - subroutine TransferBCIn_2d(this, tag, data) - - type(ed_site_type), intent(inout) :: this - character(len=*), intent(in) :: tag - real(r8), pointer, intent(in) :: data(:,:) - - type(fates_patch_type), pointer :: currentPatch - - ! LOCAL - integer :: c ! HLM column index - - currentPatch => this%oldest_patch - - do while (associated(currentPatch)) - - c = this%column_map(currentPatch%patchno) - - select case(trim(tag)) - - case('decomp_frac_moisture') - currentPatch%bc_in%w_scalar_sisl = data(c,:) - ! currentPatch%bc_in%w_scalar_sisl => transfer_array(ifp,:) - - ! NOTE: should the patch level bc subtypes actually be pointers to the - ! input values instead of copies of the pointer data? Or is not a good idea - ! since the HLM runs on a different time step than fates? - ! If these are not pointers then we really don't have a good way to avoid - ! memory duplicity. - - end select - - currentPatch => currentPatch%younger - - end do - - end subroutine TransferBCIn_2d - -! ====================================================================================== end module FatesInterfaceMod From cca0a5d3b2d3d695af516c2dcae84591554990ad Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 17 Jul 2025 15:44:50 -0700 Subject: [PATCH 016/113] make generic procedure for transferbcin subroutine --- main/EDTypesMod.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 53f7960d80..70c79b364c 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -579,8 +579,10 @@ module EDTypesMod procedure, public :: get_current_landuse_statevector procedure, public :: get_secondary_young_fraction - procedure, public :: TransferBCIn_1d - procedure, public :: TransferBCIn_2d + + procedure, private :: TransferBCIn_1d + procedure, private :: TransferBCIn_2d + generic, public :: TransferBCIn => TransferBCIn_1d, TransferBCIn_2d end type ed_site_type From 549a590864972eb66268254db6f5cb96939c833d Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 17 Jul 2025 15:46:50 -0700 Subject: [PATCH 017/113] minor cleanup --- main/EDTypesMod.F90 | 7 ------- 1 file changed, 7 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 70c79b364c..b12f48e3b8 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -569,12 +569,6 @@ module EDTypesMod logical, allocatable :: landuse_vector_gt_min(:) ! is the land use state vector for each land use type greater than the minimum below which we ignore? logical :: transition_landuse_from_off_to_on ! special flag to use only when reading restarts, which triggers procedure to initialize land use - ! interface TransferBCIn - ! module procedure TransferBCIn_1d - ! module procedure TransferBCIn_2d - ! !module procedure TransferBCIn_3d - ! end interface TransferBCIn - contains procedure, public :: get_current_landuse_statevector @@ -905,7 +899,6 @@ subroutine TransferBCIn_2d(this, tag, data) case('decomp_frac_moisture') currentPatch%bc_in%w_scalar_sisl = data(c,:) - ! currentPatch%bc_in%w_scalar_sisl => transfer_array(ifp,:) ! NOTE: should the patch level bc subtypes actually be pointers to the ! input values instead of copies of the pointer data? Or is not a good idea From 57a43e25a23ff5acd6422df41f0a33706f5c4019 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 22 Jul 2025 11:58:43 -0700 Subject: [PATCH 018/113] initial handover from site-level bc_in to patch level bc_in for fragmentation scalar only --- biogeochem/EDPhysiologyMod.F90 | 2 +- biogeochem/FatesPatchMod.F90 | 11 +++++++++++ 2 files changed, 12 insertions(+), 1 deletion(-) 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 e659fa97d0..429666e062 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -276,6 +276,9 @@ subroutine Init(this, num_swb, num_levsoil) allocate(this%sabs_dir(num_swb)) allocate(this%sabs_dif(num_swb)) allocate(this%fragmentation_scaler(num_levsoil)) + allocate(this%bc_in%w_scalar_sisl(num_levsoil)) + allocate(this%bc_in%t_scalar_sisl(num_levsoil)) + ! initialize all values to nan call this%NanValues() @@ -514,6 +517,10 @@ 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 end subroutine NanValues @@ -601,6 +608,10 @@ 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 + end subroutine ZeroValues !=========================================================================== From cefd2d19cd2b7e7a25ca5a05986edc20794c5b2f Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 28 Jul 2025 16:33:13 -0700 Subject: [PATCH 019/113] remove w and t scalars from interface bc init procedures --- main/FatesInterfaceMod.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index aed76ea5c8..24f6931ee6 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -302,8 +302,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 +498,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 From 29f586b8789b4cbf639728d1f6ed1ad2809fd6e4 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 28 Jul 2025 16:37:58 -0700 Subject: [PATCH 020/113] add decomposition temperature limitation to transfer in --- main/EDTypesMod.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index bf12bdc5dc..3735c2de30 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -898,6 +898,8 @@ subroutine TransferBCIn_2d(this, tag, data) case('decomp_frac_moisture') currentPatch%bc_in%w_scalar_sisl = data(c,:) + case('decomp_frac_temperature') + currentPatch%bc_in%t_scalar_sisl = data(c,:) ! NOTE: should the patch level bc subtypes actually be pointers to the ! input values instead of copies of the pointer data? Or is not a good idea From aa269da3ec1d68fe1e159b2529872d9d29344f23 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 1 Aug 2025 16:33:37 -0700 Subject: [PATCH 021/113] Update fluxintolitterpool non-mimics section to use the patch-level bc_out litter variables. --- biogeochem/FatesSoilBGCFluxMod.F90 | 109 ++++++++++++++--------------- 1 file changed, 54 insertions(+), 55 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index e0af2a9e0f..98b69abc36 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -627,7 +627,6 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) ! !ARGUMENTS type(ed_site_type) , intent(inout) :: csite type(bc_in_type) , intent(in) :: bc_in - type(bc_out_type) , intent(inout),target :: bc_out ! !LOCAL VARIABLES: type (fates_patch_type), pointer :: currentPatch @@ -636,6 +635,7 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) real(r8), pointer :: flux_lab_si(:) real(r8), pointer :: flux_lig_si(:) type(litter_type), pointer :: litt + type(bc_out_type), pointer :: bc_out real(r8) :: surface_prof(bc_in%nlevsoil) ! this array is used to distribute ! fragmented litter on the surface @@ -700,46 +700,48 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) surface_prof(id) = surface_prof(id)/surface_prof_tot end do - ! Loop over the different elements. - do el = 1, num_elements - - ! Zero out the boundary flux arrays - ! Make a pointer to the cellulose, labile and lignin - ! flux partitions. - - select case (element_list(el)) - case (carbon12_element) - bc_out%litt_flux_cel_c_si(:) = 0.0_r8 - bc_out%litt_flux_lig_c_si(:) = 0.0_r8 - bc_out%litt_flux_lab_c_si(:) = 0.0_r8 - flux_cel_si => bc_out%litt_flux_cel_c_si(:) - flux_lab_si => bc_out%litt_flux_lab_c_si(:) - flux_lig_si => bc_out%litt_flux_lig_c_si(:) - case (nitrogen_element) - bc_out%litt_flux_cel_n_si(:) = 0._r8 - bc_out%litt_flux_lig_n_si(:) = 0._r8 - bc_out%litt_flux_lab_n_si(:) = 0._r8 - flux_cel_si => bc_out%litt_flux_cel_n_si(:) - flux_lab_si => bc_out%litt_flux_lab_n_si(:) - flux_lig_si => bc_out%litt_flux_lig_n_si(:) - case (phosphorus_element) - bc_out%litt_flux_cel_p_si(:) = 0._r8 - bc_out%litt_flux_lig_p_si(:) = 0._r8 - bc_out%litt_flux_lab_p_si(:) = 0._r8 - flux_cel_si => bc_out%litt_flux_cel_p_si(:) - flux_lab_si => bc_out%litt_flux_lab_p_si(:) - flux_lig_si => bc_out%litt_flux_lig_p_si(:) - end select + currentPatch => csite%oldest_patch + fluxpatchloop: do while (associated(currentPatch)) - currentPatch => csite%oldest_patch - do while (associated(currentPatch)) + ! Set a pointer to the litter object + ! for the current element on the current + ! patch + litt => currentPatch%litter(el) + bc_out => currentPatch%bc_out - ! Set a pointer to the litter object - ! for the current element on the current - ! patch - litt => currentPatch%litter(el) - area_frac = currentPatch%area/area + area_frac = currentPatch%area/area + + ! Loop over the different elements. + elemloop: do el = 1, num_elements + ! Zero out the boundary flux arrays + ! Make a pointer to the cellulose, labile and lignin + ! flux partitions. + + select case (element_list(el)) + case (carbon12_element) + bc_out%litt_flux_cel_c_si(:) = 0.0_r8 + bc_out%litt_flux_lig_c_si(:) = 0.0_r8 + bc_out%litt_flux_lab_c_si(:) = 0.0_r8 + flux_cel_si => bc_out%litt_flux_cel_c_si(:) + flux_lab_si => bc_out%litt_flux_lab_c_si(:) + flux_lig_si => bc_out%litt_flux_lig_c_si(:) + case (nitrogen_element) + bc_out%litt_flux_cel_n_si(:) = 0._r8 + bc_out%litt_flux_lig_n_si(:) = 0._r8 + bc_out%litt_flux_lab_n_si(:) = 0._r8 + flux_cel_si => bc_out%litt_flux_cel_n_si(:) + flux_lab_si => bc_out%litt_flux_lab_n_si(:) + flux_lig_si => bc_out%litt_flux_lig_n_si(:) + case (phosphorus_element) + bc_out%litt_flux_cel_p_si(:) = 0._r8 + bc_out%litt_flux_lig_p_si(:) = 0._r8 + bc_out%litt_flux_lab_p_si(:) = 0._r8 + flux_cel_si => bc_out%litt_flux_cel_p_si(:) + flux_lab_si => bc_out%litt_flux_lab_p_si(:) + flux_lig_si => bc_out%litt_flux_lig_p_si(:) + end select + do ic = 1, ncwd do id = 1,nlev_eff_decomp @@ -763,12 +765,8 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) end do end do - - - ! leaf and fine root fragmentation fluxes - do id = 1,nlev_eff_decomp flux_lab_si(id) = flux_lab_si(id) + & @@ -810,22 +808,23 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) litt%root_fines_frag(ilignin,j) * area_frac enddo - currentPatch => currentPatch%younger - end do + ! Normalize all masses over the decomposition layer's depth + ! Convert from kg/m2/day -> g/m3/s - ! Normalize all masses over the decomposition layer's depth - ! Convert from kg/m2/day -> g/m3/s + do id = 1,nlev_eff_decomp + flux_cel_si(id) = days_per_sec * g_per_kg * & + flux_cel_si(id) / bc_in%dz_decomp_sisl(id) + flux_lig_si(id) = days_per_sec * g_per_kg * & + flux_lig_si(id) / bc_in%dz_decomp_sisl(id) + flux_lab_si(id) = days_per_sec * g_per_kg * & + flux_lab_si(id) / bc_in%dz_decomp_sisl(id) + end do - do id = 1,nlev_eff_decomp - flux_cel_si(id) = days_per_sec * g_per_kg * & - flux_cel_si(id) / bc_in%dz_decomp_sisl(id) - flux_lig_si(id) = days_per_sec * g_per_kg * & - flux_lig_si(id) / bc_in%dz_decomp_sisl(id) - flux_lab_si(id) = days_per_sec * g_per_kg * & - flux_lab_si(id) / bc_in%dz_decomp_sisl(id) - end do + end do elemloop + + currentPatch => currentPatch%younger - end do ! do elements + end do fluxpatchloop ! If we are coupled with MIMICS, then we need some assessment of litter quality ! ie ligC/totalN. If we are not tracking N in the litter flux (ie C-only model) From d2184ee71a15148c506339662a358a8005cb1a02 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 1 Aug 2025 16:46:38 -0700 Subject: [PATCH 022/113] Update the mimics portion of the fluxintolitterpools code to be within the previous patch loop structure --- biogeochem/FatesSoilBGCFluxMod.F90 | 166 ++++++++++++++--------------- 1 file changed, 80 insertions(+), 86 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 98b69abc36..67990b2bc8 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -586,7 +586,7 @@ end subroutine EffluxIntoLitterPools ! ===================================================================================== - subroutine FluxIntoLitterPools(csite, bc_in, bc_out) + subroutine FluxIntoLitterPools(csite, bc_in) ! ----------------------------------------------------------------------------------- ! Created by Charlie Koven and Rosie Fisher, 2014-2015 @@ -822,102 +822,96 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) end do elemloop - currentPatch => currentPatch%younger - - end do fluxpatchloop - - ! If we are coupled with MIMICS, then we need some assessment of litter quality - ! ie ligC/totalN. If we are not tracking N in the litter flux (ie C-only model) - ! then we need to approximate this by estimating the mean C:N ratios of each - ! plant organ, and mulitplying that by the different C Fluxes to get a total - ! approximate N flux. Note, in C-only, we will not capture any re-absorption. + ! If we are coupled with MIMICS, then we need some assessment of litter quality + ! ie ligC/totalN. If we are not tracking N in the litter flux (ie C-only model) + ! then we need to approximate this by estimating the mean C:N ratios of each + ! plant organ, and mulitplying that by the different C Fluxes to get a total + ! approximate N flux. Note, in C-only, we will not capture any re-absorption. - if(trim(hlm_decomp).eq.'MIMICS') then + if(trim(hlm_decomp).eq.'MIMICS') then - ! If we track nitrogen (ie cnp or other) then - ! we diagnose the c-lig/n ratio directly from the pools - if(element_pos(nitrogen_element)>0) then - ! Sum totalN fluxes over depth [g/m2] - sum_N = sum((bc_out%litt_flux_cel_n_si(1:nlev_eff_soil) + & - bc_out%litt_flux_lig_n_si(1:nlev_eff_soil) + & - bc_out%litt_flux_lab_n_si(1:nlev_eff_soil)) * & - bc_in%dz_sisl(1:nlev_eff_soil)) - - else - - ! In this case (Carbon Only), we use the stoichiometry parameters to estimate - ! the C:N of live vegetation and the seedbank, and use that - ! as a proxy for the C:N of the litter flux + ! If we track nitrogen (ie cnp or other) then + ! we diagnose the c-lig/n ratio directly from the pools + if(element_pos(nitrogen_element)>0) then - sum_N = 0._r8 - - currentPatch => csite%oldest_patch - do while (associated(currentPatch)) + ! Sum totalN fluxes over depth [g/m2] + sum_N = sum((bc_out%litt_flux_cel_n_si(1:nlev_eff_soil) + & + bc_out%litt_flux_lig_n_si(1:nlev_eff_soil) + & + bc_out%litt_flux_lab_n_si(1:nlev_eff_soil)) * & + bc_in%dz_sisl(1:nlev_eff_soil)) - litt => currentPatch%litter(element_pos(carbon12_element)) - area_frac = currentPatch%area*area_inv - - tot_leaf_c = 0._r8 - tot_leaf_n = 0._r8 - tot_fnrt_c = 0._r8 - tot_fnrt_n = 0._r8 - tot_wood_c = 0._r8 - tot_wood_n = 0._r8 + else + + ! In this case (Carbon Only), we use the stoichiometry parameters to estimate + ! the C:N of live vegetation and the seedbank, and use that + ! as a proxy for the C:N of the litter flux - ccohort => currentPatch%tallest - do while (associated(ccohort)) - ipft = ccohort%pft - leaf_c = ccohort%n * area_inv * ccohort%prt%GetState(leaf_organ, carbon12_element) - sapw_c = ccohort%n * area_inv * ccohort%prt%GetState(sapw_organ, carbon12_element) - fnrt_c = ccohort%n * area_inv * ccohort%prt%GetState(fnrt_organ, carbon12_element) - struct_c = ccohort%n * area_inv * ccohort%prt%GetState(struct_organ, carbon12_element) - leaf_n = leaf_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(leaf_organ)) - sapw_n = sapw_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(sapw_organ)) - fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(fnrt_organ)) - struct_n = struct_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(struct_organ)) - tot_leaf_c = tot_leaf_c + leaf_c - tot_leaf_n = tot_leaf_n + leaf_n - tot_fnrt_c = tot_fnrt_c + fnrt_c - tot_fnrt_n = tot_fnrt_n + fnrt_n - tot_wood_c = tot_wood_c + sapw_c + struct_c - tot_wood_n = tot_wood_n + sapw_n + struct_n - ccohort => ccohort%shorter - end do + sum_N = 0._r8 + - if(tot_wood_c>nearzero) then - sum_N = sum_N + area_frac*sum(litt%ag_cwd_frag)*(tot_wood_n/tot_wood_c) - sum_N = sum_N + area_frac*sum(litt%bg_cwd_frag)*(tot_wood_n/tot_wood_c) - end if - if(tot_leaf_c>nearzero)then - sum_N = sum_N + area_frac*sum(litt%leaf_fines_frag)*(tot_leaf_n / tot_leaf_c) - end if - if(tot_fnrt_c>nearzero)then - sum_N = sum_N + area_frac*sum(litt%root_fines_frag)*(tot_fnrt_n / tot_fnrt_c) - end if - do ipft = 1,numpft - sum_N = sum_N + area_frac * currentPatch%nitr_repro_stoich(ipft) * & - (litt%seed_decay(ipft) + litt%seed_germ_decay(ipft)) - end do + tot_leaf_c = 0._r8 + tot_leaf_n = 0._r8 + tot_fnrt_c = 0._r8 + tot_fnrt_n = 0._r8 + tot_wood_c = 0._r8 + tot_wood_n = 0._r8 + + ccohort => currentPatch%tallest + do while (associated(ccohort)) + ipft = ccohort%pft + leaf_c = ccohort%n * area_inv * ccohort%prt%GetState(leaf_organ, carbon12_element) + sapw_c = ccohort%n * area_inv * ccohort%prt%GetState(sapw_organ, carbon12_element) + fnrt_c = ccohort%n * area_inv * ccohort%prt%GetState(fnrt_organ, carbon12_element) + struct_c = ccohort%n * area_inv * ccohort%prt%GetState(struct_organ, carbon12_element) + leaf_n = leaf_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(leaf_organ)) + sapw_n = sapw_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(sapw_organ)) + fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(fnrt_organ)) + struct_n = struct_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(struct_organ)) + tot_leaf_c = tot_leaf_c + leaf_c + tot_leaf_n = tot_leaf_n + leaf_n + tot_fnrt_c = tot_fnrt_c + fnrt_c + tot_fnrt_n = tot_fnrt_n + fnrt_n + tot_wood_c = tot_wood_c + sapw_c + struct_c + tot_wood_n = tot_wood_n + sapw_n + struct_n + ccohort => ccohort%shorter + end do + + if(tot_wood_c>nearzero) then + sum_N = sum_N + area_frac*sum(litt%ag_cwd_frag)*(tot_wood_n/tot_wood_c) + sum_N = sum_N + area_frac*sum(litt%bg_cwd_frag)*(tot_wood_n/tot_wood_c) + end if + if(tot_leaf_c>nearzero)then + sum_N = sum_N + area_frac*sum(litt%leaf_fines_frag)*(tot_leaf_n / tot_leaf_c) + end if + if(tot_fnrt_c>nearzero)then + sum_N = sum_N + area_frac*sum(litt%root_fines_frag)*(tot_fnrt_n / tot_fnrt_c) + end if + do ipft = 1,numpft + sum_N = sum_N + area_frac * currentPatch%nitr_repro_stoich(ipft) * & + (litt%seed_decay(ipft) + litt%seed_germ_decay(ipft)) + end do - currentPatch => currentPatch%younger - end do - - ! Convert from kg/m2/day -> g/m2/s - sum_N = sum_N * days_per_sec * g_per_kg - - end if + ! Convert from kg/m2/day -> g/m2/s + sum_N = sum_N * days_per_sec * g_per_kg + + end if - ! Sum over layers and multiply by depth g/m3/s * m -> g/m2/s - sum_ligC = sum(bc_out%litt_flux_lig_c_si(1:nlev_eff_soil) * bc_in%dz_sisl(1:nlev_eff_soil)) + ! Sum over layers and multiply by depth g/m3/s * m -> g/m2/s + sum_ligC = sum(bc_out%litt_flux_lig_c_si(1:nlev_eff_soil) * bc_in%dz_sisl(1:nlev_eff_soil)) - if(sum_N>nearzero)then - bc_out%litt_flux_ligc_per_n = sum_ligC / sum_N - else - bc_out%litt_flux_ligc_per_n = 0._r8 - end if + if(sum_N>nearzero)then + bc_out%litt_flux_ligc_per_n = sum_ligC / sum_N + else + bc_out%litt_flux_ligc_per_n = 0._r8 + end if + + end if ! MIMICS check + + currentPatch => currentPatch%younger + + end do fluxpatchloop - end if From 8f3192c5b66b0f75deedb97d0236cf4638543484 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 1 Aug 2025 16:48:01 -0700 Subject: [PATCH 023/113] whitespace clean up --- biogeochem/FatesSoilBGCFluxMod.F90 | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 67990b2bc8..3c4836f913 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -743,18 +743,15 @@ subroutine FluxIntoLitterPools(csite, bc_in) end select do ic = 1, ncwd - do id = 1,nlev_eff_decomp flux_cel_si(id) = flux_cel_si(id) + & litt%ag_cwd_frag(ic) * ED_val_cwd_fcel * area_frac * surface_prof(id) flux_lig_si(id) = flux_lig_si(id) + & litt%ag_cwd_frag(ic) * ED_val_cwd_flig * area_frac * surface_prof(id) - end do do j = 1, nlev_eff_soil - id = bc_in%decomp_id(j) ! Map from soil layer to decomp layer flux_cel_si(id) = flux_cel_si(id) + & @@ -762,13 +759,11 @@ subroutine FluxIntoLitterPools(csite, bc_in) flux_lig_si(id) = flux_lig_si(id) + & litt%bg_cwd_frag(ic,j) * ED_val_cwd_flig * area_frac - end do end do ! leaf and fine root fragmentation fluxes do id = 1,nlev_eff_decomp - flux_lab_si(id) = flux_lab_si(id) + & litt%leaf_fines_frag(ilabile) * area_frac* surface_prof(id) @@ -777,10 +772,8 @@ subroutine FluxIntoLitterPools(csite, bc_in) flux_lig_si(id) = flux_lig_si(id) + & litt%leaf_fines_frag(ilignin) * area_frac* surface_prof(id) - end do - ! decaying seeds from the litter pool do ipft = 1,numpft do id = 1,nlev_eff_decomp @@ -830,7 +823,6 @@ subroutine FluxIntoLitterPools(csite, bc_in) if(trim(hlm_decomp).eq.'MIMICS') then - ! If we track nitrogen (ie cnp or other) then ! we diagnose the c-lig/n ratio directly from the pools if(element_pos(nitrogen_element)>0) then @@ -849,7 +841,6 @@ subroutine FluxIntoLitterPools(csite, bc_in) sum_N = 0._r8 - tot_leaf_c = 0._r8 tot_leaf_n = 0._r8 tot_fnrt_c = 0._r8 @@ -911,10 +902,6 @@ subroutine FluxIntoLitterPools(csite, bc_in) currentPatch => currentPatch%younger end do fluxpatchloop - - - - return end subroutine FluxIntoLitterPools From f22552f4f438535f7ef33b1775e844e81c2aa0b6 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 12 Aug 2025 11:09:36 -0700 Subject: [PATCH 024/113] add transfer bc out subroutine --- main/EDTypesMod.F90 | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 3735c2de30..d851921284 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -916,5 +916,43 @@ subroutine TransferBCIn_2d(this, tag, data) end subroutine TransferBCIn_2d ! ====================================================================================== + + subroutine TransferBCOut(this, tag, data) + + class(ed_site_type), intent(inout) :: this + character(len=*), intent(in) :: tag + real(r8), pointer, intent(inout) :: data(:,:) + + type(fates_patch_type), pointer :: currentPatch + + ! LOCAL + integer :: c ! HLM column index + + currentPatch => this%oldest_patch + + do while (associated(currentPatch)) + + c = this%column_map(currentPatch%patchno) + + select case(trim(tag)) + + ! For the decomposition carbon pools, the host land model uses + ! a 3D array, where the third dimension signifies the litter type. + ! The HLM sets up a pointer to a 2D slice of the variable so we + ! don't have to worry about that here + case('decomp_cpools_met') + data(c,:) = data(c,:) + currentPatch%bc_out%litt_flux_lab_c_si + case('decomp_cpools_cel') + data(c,:) = data(c,:) + currentPatch%bc_out%litt_flux_cel_c_si + case('decomp_cpools_lig') + data(c,:) = data(c,:) + currentPatch%bc_out%litt_flux_lig_c_si + + end select + + currentPatch => currentPatch%younger + + end do + + end subroutine TransferBCOut end module EDTypesMod From 9832f64239219052f089f927ae6188a831750eda Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 12 Aug 2025 11:16:43 -0700 Subject: [PATCH 025/113] remove now unused bc_out from flux into litter pool procedure --- main/EDMainMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index c5b2cad8c9..c49c1be196 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -804,7 +804,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! can remove it completely if/when this call is added in ELM to ! subroutine UpdateLitterFluxes(this,bounds_clump) in elmfates_interfaceMod.F90 - call FluxIntoLitterPools(currentsite, bc_in, bc_out) + call FluxIntoLitterPools(currentsite, bc_in) ! Update cohort number. From 8fc0cb1e942c85b871c70687377d4224b67a47d3 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 12 Aug 2025 15:44:46 -0700 Subject: [PATCH 026/113] add time conversion argument for the bc out transfer --- main/EDTypesMod.F90 | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index d851921284..a184e92a4d 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -917,11 +917,13 @@ end subroutine TransferBCIn_2d ! ====================================================================================== - subroutine TransferBCOut(this, tag, data) + subroutine TransferBCOut(this, tag, data, dtime) class(ed_site_type), intent(inout) :: this - character(len=*), intent(in) :: tag - real(r8), pointer, intent(inout) :: data(:,:) + + character(len=*), intent(in) :: tag ! HLM-FATES common vocab string + real(r8), pointer, intent(inout) :: data(:,:) ! data pointer associated with tag + real(r8), intent(in) :: dtime ! HLM timestep size in seconds type(fates_patch_type), pointer :: currentPatch @@ -939,13 +941,14 @@ subroutine TransferBCOut(this, tag, data) ! For the decomposition carbon pools, the host land model uses ! a 3D array, where the third dimension signifies the litter type. ! The HLM sets up a pointer to a 2D slice of the variable so we - ! don't have to worry about that here + ! don't have to worry about that here. + ! We convert the bc_out from per second to per timestep case('decomp_cpools_met') - data(c,:) = data(c,:) + currentPatch%bc_out%litt_flux_lab_c_si + data(c,:) = data(c,:) + currentPatch%bc_out%litt_flux_lab_c_si * dtime case('decomp_cpools_cel') - data(c,:) = data(c,:) + currentPatch%bc_out%litt_flux_cel_c_si + data(c,:) = data(c,:) + currentPatch%bc_out%litt_flux_cel_c_si * dtime case('decomp_cpools_lig') - data(c,:) = data(c,:) + currentPatch%bc_out%litt_flux_lig_c_si + data(c,:) = data(c,:) + currentPatch%bc_out%litt_flux_lig_c_si * dtime end select From 11a697791d59a2e18a50b7b15683a1e931563844 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 21 Aug 2025 15:19:19 -0700 Subject: [PATCH 027/113] remove area fraction from flux into litter pools now that subroutine does not sum to the site level --- biogeochem/FatesSoilBGCFluxMod.F90 | 39 ++++++++++++++---------------- 1 file changed, 18 insertions(+), 21 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 3c4836f913..d4ba9e89fe 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -644,7 +644,6 @@ subroutine FluxIntoLitterPools(csite, bc_in) real(r8) :: surface_prof_tot ! normalizes the surface_prof array integer :: nlev_eff_soil ! number of effective soil layers integer :: nlev_eff_decomp ! number of effective decomp layers - real(r8) :: area_frac ! fraction of site's area of current patch real(r8) :: z_decomp ! Used for calculating depth midpoints of decomp layers integer :: el ! Element index (C,N,P,etc) integer :: j ! Soil layer index @@ -709,8 +708,6 @@ subroutine FluxIntoLitterPools(csite, bc_in) litt => currentPatch%litter(el) bc_out => currentPatch%bc_out - area_frac = currentPatch%area/area - ! Loop over the different elements. elemloop: do el = 1, num_elements @@ -745,33 +742,33 @@ subroutine FluxIntoLitterPools(csite, bc_in) do ic = 1, ncwd do id = 1,nlev_eff_decomp flux_cel_si(id) = flux_cel_si(id) + & - litt%ag_cwd_frag(ic) * ED_val_cwd_fcel * area_frac * surface_prof(id) + litt%ag_cwd_frag(ic) * ED_val_cwd_fcel * surface_prof(id) flux_lig_si(id) = flux_lig_si(id) + & - litt%ag_cwd_frag(ic) * ED_val_cwd_flig * area_frac * surface_prof(id) + litt%ag_cwd_frag(ic) * ED_val_cwd_flig * surface_prof(id) end do do j = 1, nlev_eff_soil id = bc_in%decomp_id(j) ! Map from soil layer to decomp layer flux_cel_si(id) = flux_cel_si(id) + & - litt%bg_cwd_frag(ic,j) * ED_val_cwd_fcel * area_frac + litt%bg_cwd_frag(ic,j) * ED_val_cwd_fcel flux_lig_si(id) = flux_lig_si(id) + & - litt%bg_cwd_frag(ic,j) * ED_val_cwd_flig * area_frac + litt%bg_cwd_frag(ic,j) * ED_val_cwd_flig end do end do ! leaf and fine root fragmentation fluxes do id = 1,nlev_eff_decomp flux_lab_si(id) = flux_lab_si(id) + & - litt%leaf_fines_frag(ilabile) * area_frac* surface_prof(id) + litt%leaf_fines_frag(ilabile) * surface_prof(id) flux_cel_si(id) = flux_cel_si(id) + & - litt%leaf_fines_frag(icellulose) * area_frac* surface_prof(id) + litt%leaf_fines_frag(icellulose) * surface_prof(id) flux_lig_si(id) = flux_lig_si(id) + & - litt%leaf_fines_frag(ilignin) * area_frac* surface_prof(id) + litt%leaf_fines_frag(ilignin) * surface_prof(id) end do ! decaying seeds from the litter pool @@ -779,26 +776,26 @@ subroutine FluxIntoLitterPools(csite, bc_in) do id = 1,nlev_eff_decomp flux_lab_si(id) = flux_lab_si(id) + & (litt%seed_decay(ipft) + litt%seed_germ_decay(ipft)) * & - EDPftvarcon_inst%lf_flab(ipft) * area_frac* surface_prof(id) + EDPftvarcon_inst%lf_flab(ipft) * surface_prof(id) flux_cel_si(id) = flux_cel_si(id) + & (litt%seed_decay(ipft) + litt%seed_germ_decay(ipft)) * & - EDPftvarcon_inst%lf_fcel(ipft) * area_frac* surface_prof(id) + EDPftvarcon_inst%lf_fcel(ipft) * surface_prof(id) flux_lig_si(id) = flux_lig_si(id) + & (litt%seed_decay(ipft) + litt%seed_germ_decay(ipft)) * & - EDPftvarcon_inst%lf_flig(ipft) * area_frac* surface_prof(id) + EDPftvarcon_inst%lf_flig(ipft) * surface_prof(id) end do end do do j = 1, nlev_eff_soil id = bc_in%decomp_id(j) flux_lab_si(id) = flux_lab_si(id) + & - litt%root_fines_frag(ilabile,j) * area_frac + litt%root_fines_frag(ilabile,j) flux_cel_si(id) = flux_cel_si(id) + & - litt%root_fines_frag(icellulose,j) * area_frac + litt%root_fines_frag(icellulose,j) flux_lig_si(id) = flux_lig_si(id) + & - litt%root_fines_frag(ilignin,j) * area_frac + litt%root_fines_frag(ilignin,j) enddo ! Normalize all masses over the decomposition layer's depth @@ -869,17 +866,17 @@ subroutine FluxIntoLitterPools(csite, bc_in) end do if(tot_wood_c>nearzero) then - sum_N = sum_N + area_frac*sum(litt%ag_cwd_frag)*(tot_wood_n/tot_wood_c) - sum_N = sum_N + area_frac*sum(litt%bg_cwd_frag)*(tot_wood_n/tot_wood_c) + sum_N = sum_N + sum(litt%ag_cwd_frag)*(tot_wood_n/tot_wood_c) + sum_N = sum_N + sum(litt%bg_cwd_frag)*(tot_wood_n/tot_wood_c) end if if(tot_leaf_c>nearzero)then - sum_N = sum_N + area_frac*sum(litt%leaf_fines_frag)*(tot_leaf_n / tot_leaf_c) + sum_N = sum_N + sum(litt%leaf_fines_frag)*(tot_leaf_n / tot_leaf_c) end if if(tot_fnrt_c>nearzero)then - sum_N = sum_N + area_frac*sum(litt%root_fines_frag)*(tot_fnrt_n / tot_fnrt_c) + sum_N = sum_N + sum(litt%root_fines_frag)*(tot_fnrt_n / tot_fnrt_c) end if do ipft = 1,numpft - sum_N = sum_N + area_frac * currentPatch%nitr_repro_stoich(ipft) * & + sum_N = sum_N + currentPatch%nitr_repro_stoich(ipft) * & (litt%seed_decay(ipft) + litt%seed_germ_decay(ipft)) end do From 0eed65c5fb3bcde3ebb81df8fd5fc902eb0acacb Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 21 Aug 2025 17:05:08 -0700 Subject: [PATCH 028/113] Add 1D bcout transfer subroutine and generic --- main/EDTypesMod.F90 | 48 +++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 46 insertions(+), 2 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index a184e92a4d..20e89c6fa5 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -577,6 +577,10 @@ module EDTypesMod procedure, private :: TransferBCIn_2d generic, public :: TransferBCIn => TransferBCIn_1d, TransferBCIn_2d + procedure, private :: TransferBCOut_1d + procedure, private :: TransferBCOut_2d + generic, public :: TransferBCOut => TransferBCOut_1d, TransferBCOut_2d + end type ed_site_type ! Make public necessary subroutines and functions @@ -917,7 +921,46 @@ end subroutine TransferBCIn_2d ! ====================================================================================== - subroutine TransferBCOut(this, tag, data, dtime) + subroutine TransferBCOut_1d(this, tag, data) + + class(ed_site_type), intent(inout) :: this + + character(len=*), intent(in) :: tag ! HLM-FATES common vocab string + real(r8), pointer, intent(inout) :: data(:,:) ! data pointer associated with tag + + type(fates_patch_type), pointer :: currentPatch + + ! LOCAL + integer :: c ! HLM column index + + currentPatch => this%oldest_patch + + do while (associated(currentPatch)) + + c = this%column_map(currentPatch%patchno) + + select case(trim(tag)) + + ! For the decomposition carbon pools, the host land model uses + ! a 3D array, where the third dimension signifies the litter type. + ! The HLM sets up a pointer to a 2D slice of the variable so we + ! don't have to worry about that here. + ! We convert the bc_out from per second to per timestep + case('litter_fall') + data(c) = data(c) + sum(currentPatch%bc_out%litt_flux_lab_c_si * currentPatch%bc_in%dz_decomp_sisl) & + + sum(currentPatch%bc_out%litt_flux_cel_c_si * currentPatch%bc_in%dz_decomp_sisl) & + + sum(currentPatch%bc_out%litt_flux_lig_c_si * currentPatch%bc_in%dz_decomp_sisl) + + end select + + currentPatch => currentPatch%younger + + end do + + end subroutine TransferBCOut_1d +! ====================================================================================== + + subroutine TransferBCOut_2d(this, tag, data, dtime) class(ed_site_type), intent(inout) :: this @@ -956,6 +999,7 @@ subroutine TransferBCOut(this, tag, data, dtime) end do - end subroutine TransferBCOut + end subroutine TransferBCOut_2d + end module EDTypesMod From d1c5baa2d04ce070ea7a68abbb7afda2ead11f13 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 22 Aug 2025 10:34:03 -0700 Subject: [PATCH 029/113] correct 1d bc out transfer definition --- main/EDTypesMod.F90 | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 20e89c6fa5..ea05b8fb1e 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -926,7 +926,7 @@ subroutine TransferBCOut_1d(this, tag, data) class(ed_site_type), intent(inout) :: this character(len=*), intent(in) :: tag ! HLM-FATES common vocab string - real(r8), pointer, intent(inout) :: data(:,:) ! data pointer associated with tag + real(r8), pointer, intent(inout) :: data(:) ! data pointer associated with tag type(fates_patch_type), pointer :: currentPatch @@ -941,11 +941,6 @@ subroutine TransferBCOut_1d(this, tag, data) select case(trim(tag)) - ! For the decomposition carbon pools, the host land model uses - ! a 3D array, where the third dimension signifies the litter type. - ! The HLM sets up a pointer to a 2D slice of the variable so we - ! don't have to worry about that here. - ! We convert the bc_out from per second to per timestep case('litter_fall') data(c) = data(c) + sum(currentPatch%bc_out%litt_flux_lab_c_si * currentPatch%bc_in%dz_decomp_sisl) & + sum(currentPatch%bc_out%litt_flux_cel_c_si * currentPatch%bc_in%dz_decomp_sisl) & @@ -958,6 +953,7 @@ subroutine TransferBCOut_1d(this, tag, data) end do end subroutine TransferBCOut_1d + ! ====================================================================================== subroutine TransferBCOut_2d(this, tag, data, dtime) From 64284bbe46600cc8697efcc2658c47bd7a984121 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 22 Aug 2025 10:45:14 -0700 Subject: [PATCH 030/113] align arguments for transfer bcout generics --- main/EDTypesMod.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index ea05b8fb1e..ca83aeb65b 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -921,12 +921,13 @@ end subroutine TransferBCIn_2d ! ====================================================================================== - subroutine TransferBCOut_1d(this, tag, data) + subroutine TransferBCOut_1d(this, tag, data, dtime) class(ed_site_type), intent(inout) :: this - character(len=*), intent(in) :: tag ! HLM-FATES common vocab string + character(len=*), intent(in) :: tag ! HLM-FATES common vocab string real(r8), pointer, intent(inout) :: data(:) ! data pointer associated with tag + real(r8), intent(in) :: dtime ! HLM timestep size in seconds type(fates_patch_type), pointer :: currentPatch From 16152e1e705f17c029ef4cf3fe123bdeebc1d0eb Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 22 Aug 2025 10:54:15 -0700 Subject: [PATCH 031/113] move litter pointer assignment inside element loop --- biogeochem/FatesSoilBGCFluxMod.F90 | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index d4ba9e89fe..1c0cb9954b 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -702,14 +702,16 @@ subroutine FluxIntoLitterPools(csite, bc_in) currentPatch => csite%oldest_patch fluxpatchloop: do while (associated(currentPatch)) - ! Set a pointer to the litter object - ! for the current element on the current - ! patch - litt => currentPatch%litter(el) - bc_out => currentPatch%bc_out + ! Set a pointer to the output boundary condition for the current patch + bc_out => currentPatch%bc_out ! Loop over the different elements. elemloop: do el = 1, num_elements + + ! Set a pointer to the litter object + ! for the current element on the current + ! patch + litt => currentPatch%litter(el) ! Zero out the boundary flux arrays ! Make a pointer to the cellulose, labile and lignin From 3353146ffe4875432073c565e8f5ac05a8edf944 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Sat, 23 Aug 2025 14:32:05 -0700 Subject: [PATCH 032/113] add litter fluxes bcs to the patch type along with the decomposition level --- biogeochem/FatesPatchMod.F90 | 5 ++++ main/EDTypesMod.F90 | 44 ++++++++++++++++++++++++++++++++++-- 2 files changed, 47 insertions(+), 2 deletions(-) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index 429666e062..75e825192c 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -279,6 +279,9 @@ subroutine Init(this, num_swb, num_levsoil) allocate(this%bc_in%w_scalar_sisl(num_levsoil)) allocate(this%bc_in%t_scalar_sisl(num_levsoil)) + allocate(this%bc_out%litt_flux_cel_c_si(this%bc_in%nlevdecomp)) + allocate(this%bc_out%litt_flux_lig_c_si(this%bc_in%nlevdecomp)) + allocate(this%bc_out%litt_flux_lab_c_si(this%bc_in%nlevdecomp)) ! initialize all values to nan call this%NanValues() @@ -521,6 +524,7 @@ subroutine NanValues(this) ! Boundary conditions this%bc_in%w_scalar_sisl(:) = nan this%bc_in%t_scalar_sisl(:) = nan + this%bc_in%nlevdecomp = nan end subroutine NanValues @@ -611,6 +615,7 @@ subroutine ZeroValues(this) ! 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 end subroutine ZeroValues diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index ca83aeb65b..b5001d97fc 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -573,9 +573,10 @@ module EDTypesMod procedure, public :: get_current_landuse_statevector procedure, public :: get_secondary_young_fraction + procedure, private :: TransferBCIn_0d procedure, private :: TransferBCIn_1d procedure, private :: TransferBCIn_2d - generic, public :: TransferBCIn => TransferBCIn_1d, TransferBCIn_2d + generic, public :: TransferBCIn => TransferBCIn_0d, TransferBCIn_1d, TransferBCIn_2d procedure, private :: TransferBCOut_1d procedure, private :: TransferBCOut_2d @@ -840,6 +841,46 @@ function get_secondary_young_fraction(this) result(secondary_young_fraction) end function get_secondary_young_fraction + ! ====================================================================================== + + subroutine TransferBCIn_0D(this, tag, data) + + class(ed_site_type), intent(inout) :: this + character(len=*), intent(in) :: tag + real(r8), pointer, intent(in) :: data + + type(fates_patch_type), pointer :: currentPatch + + ! LOCAL + integer :: p ! patch index + + currentPatch => this%oldest_patch + + do while (associated(currentPatch)) + + p = this%patch_map(currentPatch%patchno) + + select case(trim(tag)) + + case('nlevdecomp') + currentPatch%bc_in%nlevdecomp = data + + ! NOTE: should the patch level bc subtypes actually be pointers to the + ! input values instead of copies of the pointer data? Or is not a good idea + ! since the HLM runs on a different time step than fates? + ! If these are not pointers then we really don't have a good way to avoid + ! memory duplicity. + + end select + + currentPatch => currentPatch%younger + + end do + + end subroutine TransferBCIn_0d + + ! ====================================================================================== + ! ====================================================================================== subroutine TransferBCIn_1d(this, tag, data) @@ -863,7 +904,6 @@ subroutine TransferBCIn_1d(this, tag, data) case('leaf_area_index') currentPatch%bc_in%hlm_sp_tlai = data(p) - ! currentPatch%bc_in%w_scalar_sisl => transfer_array(ifp,:) ! NOTE: should the patch level bc subtypes actually be pointers to the ! input values instead of copies of the pointer data? Or is not a good idea From dd76c4cda6cbacdce7ebd840c16b9d303ecb7b70 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Sat, 23 Aug 2025 14:40:37 -0700 Subject: [PATCH 033/113] correct unset value for nlevdecomp --- biogeochem/FatesPatchMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index 75e825192c..f730191eb9 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -524,7 +524,7 @@ subroutine NanValues(this) ! Boundary conditions this%bc_in%w_scalar_sisl(:) = nan this%bc_in%t_scalar_sisl(:) = nan - this%bc_in%nlevdecomp = nan + this%bc_in%nlevdecomp = fates_unset_int end subroutine NanValues From 7367fd0dac5311f07dbe59d964392d910a70d683 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Sat, 23 Aug 2025 14:53:00 -0700 Subject: [PATCH 034/113] make the scalar bcin transfer subroutine generic to integers --- main/EDTypesMod.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index b5001d97fc..76914570ab 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -573,10 +573,10 @@ module EDTypesMod procedure, public :: get_current_landuse_statevector procedure, public :: get_secondary_young_fraction - procedure, private :: TransferBCIn_0d + procedure, private :: TransferBCIn_0d_int procedure, private :: TransferBCIn_1d procedure, private :: TransferBCIn_2d - generic, public :: TransferBCIn => TransferBCIn_0d, TransferBCIn_1d, TransferBCIn_2d + generic, public :: TransferBCIn => TransferBCIn_0d_int, TransferBCIn_1d, TransferBCIn_2d procedure, private :: TransferBCOut_1d procedure, private :: TransferBCOut_2d @@ -843,11 +843,11 @@ end function get_secondary_young_fraction ! ====================================================================================== - subroutine TransferBCIn_0D(this, tag, data) + subroutine TransferBCIn_0D_int(this, tag, data) class(ed_site_type), intent(inout) :: this character(len=*), intent(in) :: tag - real(r8), pointer, intent(in) :: data + integer, pointer, intent(in) :: data type(fates_patch_type), pointer :: currentPatch @@ -877,7 +877,7 @@ subroutine TransferBCIn_0D(this, tag, data) end do - end subroutine TransferBCIn_0d + end subroutine TransferBCIn_0d_int ! ====================================================================================== From 018dcdb429e7e968b8baf58dbe3cf27387e347de Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 26 Aug 2025 15:13:14 -0700 Subject: [PATCH 035/113] start adding an interface variable type inspired by the history interface indexing --- main/FatesInterfaceMod.F90 | 5 +++ main/FatesInterfaceVarTypeMod.F90 | 60 +++++++++++++++++++++++++++++++ 2 files changed, 65 insertions(+) create mode 100644 main/FatesInterfaceVarTypeMod.F90 diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 24f6931ee6..9f049c9697 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -114,6 +114,8 @@ module FatesInterfaceMod use FatesTwoStreamUtilsMod, only : TransferRadParams use LeafBiophysicsMod , only : lb_params use LeafBiophysicsMod , only : FvCB1980 + use FatesInterfaceVariableTypeMod, only : fates_interface_variable_type + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) @@ -160,6 +162,9 @@ module FatesInterfaceMod type(bc_pconst_type) :: bc_pconst + ! This is the + type(fates_interface_variable_type) :: api_vars + end type fates_interface_type diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 new file mode 100644 index 0000000000..38489a131a --- /dev/null +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -0,0 +1,60 @@ +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 FatesGlobals, only : fates_log + use FatesGlobals, only : endrun => fates_endrun + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : fates_long_string_length + + implicit none + private + + + type, public :: fates_interface_variable_type + + character(len=48) :: variable_name ! variable common reference name + character(len=fates_long_string_length) :: description ! variable description + + logical :: active = .false. ! true if the variable is used by the host land model + integer :: update_frequency ! this should facilitate a check that the update is being called in the correct subroutine + + ! pointers to data (only one of these to be allocated per variable) + ! TODO: make this polymorphic? + integer, pointer :: intscalar + integer, pointer :: int1d(:) + integer, pointer :: int2d(:,:) + integer, pointer :: int3d(:,:,:) + real(r8), pointer :: r8scalar + real(r8), pointer :: r81d(:) + real(r8), pointer :: r82d(:,:) + real(r8), pointer :: r83d(:,:,:) + + contains + procedure :: InitializeInterfaceVariables => Init + end type fates_interface_variable_type + + contains + + subroutine InitializeInterfaceVariables(this, variable_name, description, active, & + update_frequency) + + class(fates_interface_variable_type) :: this + + character(len=*), intent(in) :: variable_name + character(len=*), intent(in) :: description + logical, intent(in) :: active + integer, intent(in) :: update_frequency + + this%variable_name = variable_name + this%description = description + this%active = active + this%update_frequency = update_frequency + + end subroutine InitializeInterfaceVariables + +end module FatesInterfaceVariableTypeMod \ No newline at end of file From 943409cc6543d2a9d74259c337cbc6e3798c6751 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 27 Aug 2025 16:49:52 -0700 Subject: [PATCH 036/113] add registry and initialization procedures to the interface variable type --- main/FatesInterfaceVarTypeMod.F90 | 53 +++++++++++++++++++++---------- 1 file changed, 37 insertions(+), 16 deletions(-) diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index 38489a131a..1211acc396 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -35,26 +35,47 @@ module FatesInterfaceVariableTypeMod real(r8), pointer :: r83d(:,:,:) contains - procedure :: InitializeInterfaceVariables => Init + procedure :: InitializeInterfaceVariable => Init + procedure :: Register => RegisterInterfaceVariable_int_scalar + end type fates_interface_variable_type contains - subroutine InitializeInterfaceVariables(this, variable_name, description, active, & - update_frequency) - - class(fates_interface_variable_type) :: this - - character(len=*), intent(in) :: variable_name - character(len=*), intent(in) :: description - logical, intent(in) :: active - integer, intent(in) :: update_frequency - - this%variable_name = variable_name - this%description = description - this%active = active - this%update_frequency = update_frequency + ! ==================================================================================== + + subroutine InitializeInterfaceVariable(this, variable_name) + + class(fates_interface_variable_type) :: this + + character(len=*), intent(in) :: variable_name + + nullify(this%iscalar) + nullify(this%int1d) + nullify(this%int2d) + nullify(this%int3d) + nullify(this%rscalar) + nullify(this%r81d) + nullify(this%r82d) + nullify(this%r83d) + + this%variable_name = variable_name + this%active = .false. + + end subroutine InitializeInterfaceVariable + + ! ==================================================================================== - end subroutine InitializeInterfaceVariables + subroutine RegisterInterfaceVariable(this, data, active) + + class(fates_interface_variable_type) :: this + + class(*), pointer, intent(in) :: data + logical, intent(in) :: active + + this%data => data + this%active = active + + end subroutine RegisterInterfaceVariable end module FatesInterfaceVariableTypeMod \ No newline at end of file From 3fc08b7a63a1f212a5d026298b484faaa311a712 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 27 Aug 2025 16:50:12 -0700 Subject: [PATCH 037/113] simplify the interface variable type for now --- main/FatesInterfaceVarTypeMod.F90 | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index 1211acc396..6b2c67034d 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -13,23 +13,19 @@ module FatesInterfaceVariableTypeMod implicit none private - + ! Interface variable registry type type, public :: fates_interface_variable_type - character(len=48) :: variable_name ! variable common reference name - character(len=fates_long_string_length) :: description ! variable description - - logical :: active = .false. ! true if the variable is used by the host land model - integer :: update_frequency ! this should facilitate a check that the update is being called in the correct subroutine + character(len=48) :: variable_name ! variable common reference name + logical :: active ! true if the variable is used by the host land model ! pointers to data (only one of these to be allocated per variable) - ! TODO: make this polymorphic? - integer, pointer :: intscalar + integer, pointer :: iscalar integer, pointer :: int1d(:) integer, pointer :: int2d(:,:) integer, pointer :: int3d(:,:,:) - real(r8), pointer :: r8scalar + real(r8), pointer :: rscalar real(r8), pointer :: r81d(:) real(r8), pointer :: r82d(:,:) real(r8), pointer :: r83d(:,:,:) From 79bf5db2d1ada3ea2a7d0cc1aa1504049bba6d41 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 27 Aug 2025 16:54:52 -0700 Subject: [PATCH 038/113] Add procedure call chain to define the registry variable keys --- main/FatesInterfaceMod.F90 | 85 ++++++++++++++++++++++++++++++++++++-- 1 file changed, 82 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 9f049c9697..caba1ce100 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -162,9 +162,18 @@ module FatesInterfaceMod type(bc_pconst_type) :: bc_pconst - ! This is the - type(fates_interface_variable_type) :: api_vars + ! This is the interface registry which associates variables with a common keyword + type(fates_interface_variable_type) :: api_vars(:) + ! The number of variables in the registry + integer :: num_api_vars + + contains + + procedure :: InitializeInterfaceRegistry + + procedure, private :: DefineInterfaceRegistry + procedure, private :: SetInterfaceVariable end type fates_interface_type @@ -2692,7 +2701,77 @@ subroutine FatesReadParameters(param_reader) call fates_params%Destroy() deallocate(fates_params) + +end subroutine FatesReadParameters + +! ====================================================================================== + +subroutine InitializeInterfaceRegistry(this) + + ! This initializes the interface registry + + class(fates_interface_type) :: this + + logical :: initialize + + ! First count up the keys defined in the registry + call this%DefineInterfaceRegistry(initialize=.false.) + + ! Allocate the registry + allocate(this%api_vars(this%num_hlm_vars)) + + ! Now set up the registry keys + call this%DefineInterfaceRegistry(initialize=.true.) + +end subroutine InitializeInterfaceRegistry - end subroutine FatesReadParameters +! ====================================================================================== + +subroutine DefineInterfaceRegistry(this, initialize) + + ! This procedure defines the list of common names to be associated with FATES and HLM + ! variables. + + class(fates_interface_type) :: this + + logical, intent(in) :: initialize ! false = count up the keys in the registry + + integer :: ivar ! indices + + ! Set ivar to zero. This will be incremented via each call to SetInterfaceVariable + ivar = 0 + + ! Define the interface registry names and indices + call this%DefineInterfaceVariable(variable_name='decomp_frac_moisture', index=ivar, initialize=initialize) + call this%DefineInterfaceVariable(variable_name='decomp_frac_temperature', index=ivar, initialize=initialize) + + ! Set the registry size based on the final update of ivar + this%num_api_vars = ivar + + +end subroutine DefineInterfaceRegistry + +! ====================================================================================== + +subroutine DefineInterfaceVariable(this, variable_name, index, initialize) + + ! This procedure + class(fates_interface_type) :: this + + character(len=*), intent(in) :: variable_name + integer, intent(inout) :: index + logical, intent(in) :: initialize + + ! Increment the index to return count + index = index + 1 + + ! If we are initializing the + if (initialize) then + call this%api_vars(index)%Init(variable_name) + end if + +end subroutine DefineInterfaceVariable + +! ====================================================================================== end module FatesInterfaceMod From 4f5908ad26fee8a2a4f6adbe943fa9d0ac90e631 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 27 Aug 2025 16:55:25 -0700 Subject: [PATCH 039/113] add procedures to call in the host side that will call the initialization and registration --- main/FatesInterfaceMod.F90 | 40 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index caba1ce100..ac0c1f82cc 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -171,9 +171,11 @@ module FatesInterfaceMod contains procedure :: InitializeInterfaceRegistry + procedure :: RegisterInterfaceVariables => Register procedure, private :: DefineInterfaceRegistry procedure, private :: SetInterfaceVariable + procedure, private :: GetRegistryIndex end type fates_interface_type @@ -2772,6 +2774,44 @@ subroutine DefineInterfaceVariable(this, variable_name, index, initialize) end subroutine DefineInterfaceVariable +! ====================================================================================== + + subroutine RegisterInterfaceVariables(this, vname, data) + + ! This procedure is called by the host land model to associate a data variable + ! with a particular registry key + + class(fates_interface_type) :: this + + character(len=*), intent(in) :: vname ! variable registry key + class(*), pointer, intent(in) :: data ! data to be associated with key + + this%api_vars(GetRegistryIndex(vname))%Register(data, active=.true.) + + end subroutine RegisterInterfaceVariables + +! ====================================================================================== + +integer function GetRegistryIndex(this, key) result(index) + + ! This procedure returns the index associated with the key provided + + class(fates_interface_type) :: this + + integer, intent(in) :: key + + integer :: ivar ! Iterator + + ! Iterate over the registry until the associated key is found + do ivar = 1, this%num_api_vars + if (this%api_vars(ivar)%variable_name == key) then + index = ivar + return + end if + end do + +end function GetRegistryIndex + ! ====================================================================================== end module FatesInterfaceMod From fceba2152455dfe39a002a27a304907d2f3a6de0 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 28 Aug 2025 11:08:55 -0700 Subject: [PATCH 040/113] aligning argument names and comments to reflect registry key concept --- main/FatesInterfaceMod.F90 | 9 +++++---- main/FatesInterfaceVarTypeMod.F90 | 2 +- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index ac0c1f82cc..6c0492b326 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2776,17 +2776,18 @@ end subroutine DefineInterfaceVariable ! ====================================================================================== - subroutine RegisterInterfaceVariables(this, vname, data) + subroutine RegisterInterfaceVariables(this, key, data) ! This procedure is called by the host land model to associate a data variable ! with a particular registry key class(fates_interface_type) :: this - character(len=*), intent(in) :: vname ! variable registry key - class(*), pointer, intent(in) :: data ! data to be associated with key + character(len=*), intent(in) :: key ! variable registry key + class(*), pointer, intent(in) :: data ! data to be associated with key - this%api_vars(GetRegistryIndex(vname))%Register(data, active=.true.) + ! Get index from registry key and associate the given data pointer + this%api_vars(GetRegistryIndex(key))%Register(data, active=.true.) end subroutine RegisterInterfaceVariables diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index 6b2c67034d..c12c984f58 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -17,7 +17,7 @@ module FatesInterfaceVariableTypeMod ! Interface variable registry type type, public :: fates_interface_variable_type - character(len=48) :: variable_name ! variable common reference name + character(len=48) :: variable_name ! common registry key logical :: active ! true if the variable is used by the host land model ! pointers to data (only one of these to be allocated per variable) From 1fda3725825c96dc37565b93a3be361aefea2a40 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 29 Aug 2025 15:05:17 -0700 Subject: [PATCH 041/113] correct procedure pointer alias --- main/FatesInterfaceMod.F90 | 2 +- main/FatesInterfaceVarTypeMod.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 6c0492b326..5e9556fdff 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -171,7 +171,7 @@ module FatesInterfaceMod contains procedure :: InitializeInterfaceRegistry - procedure :: RegisterInterfaceVariables => Register + procedure :: Register => RegisterInterfaceVariables procedure, private :: DefineInterfaceRegistry procedure, private :: SetInterfaceVariable diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index c12c984f58..4232cece7b 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -31,7 +31,7 @@ module FatesInterfaceVariableTypeMod real(r8), pointer :: r83d(:,:,:) contains - procedure :: InitializeInterfaceVariable => Init + procedure :: Init => InitializeInterfaceVariable procedure :: Register => RegisterInterfaceVariable_int_scalar end type fates_interface_variable_type From 2a6e6c96191904944b125ccf3abf6d82f9793c6f Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 29 Aug 2025 15:15:48 -0700 Subject: [PATCH 042/113] correct regsiter procedure to set data as target --- main/FatesInterfaceMod.F90 | 4 ++-- main/FatesInterfaceVarTypeMod.F90 | 5 +++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 5e9556fdff..f162baca82 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2783,8 +2783,8 @@ subroutine RegisterInterfaceVariables(this, key, data) class(fates_interface_type) :: this - character(len=*), intent(in) :: key ! variable registry key - class(*), pointer, intent(in) :: data ! data to be associated with key + character(len=*), intent(in) :: key ! variable registry key + class(*), target, intent(in) :: data ! data to be associated with key ! Get index from registry key and associate the given data pointer this%api_vars(GetRegistryIndex(key))%Register(data, active=.true.) diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index 4232cece7b..7d2cd0982b 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -18,6 +18,7 @@ module FatesInterfaceVariableTypeMod type, public :: fates_interface_variable_type character(len=48) :: variable_name ! common registry key + class(*), pointer :: data ! unlimited polymorphic data pointer logical :: active ! true if the variable is used by the host land model ! pointers to data (only one of these to be allocated per variable) @@ -66,8 +67,8 @@ subroutine RegisterInterfaceVariable(this, data, active) class(fates_interface_variable_type) :: this - class(*), pointer, intent(in) :: data - logical, intent(in) :: active + class(*), target, intent(in) :: data + logical, intent(in) :: active this%data => data this%active = active From 4796055d3c2a3f48f4d84b23efecadb4bed04b02 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 29 Aug 2025 15:24:34 -0700 Subject: [PATCH 043/113] update interface variable type to remove old pointers --- main/FatesInterfaceVarTypeMod.F90 | 22 ++-------------------- 1 file changed, 2 insertions(+), 20 deletions(-) diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index 7d2cd0982b..6c571cd68d 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -20,17 +20,7 @@ module FatesInterfaceVariableTypeMod character(len=48) :: variable_name ! common registry key class(*), pointer :: data ! unlimited polymorphic data pointer logical :: active ! true if the variable is used by the host land model - - ! pointers to data (only one of these to be allocated per variable) - integer, pointer :: iscalar - integer, pointer :: int1d(:) - integer, pointer :: int2d(:,:) - integer, pointer :: int3d(:,:,:) - real(r8), pointer :: rscalar - real(r8), pointer :: r81d(:) - real(r8), pointer :: r82d(:,:) - real(r8), pointer :: r83d(:,:,:) - + contains procedure :: Init => InitializeInterfaceVariable procedure :: Register => RegisterInterfaceVariable_int_scalar @@ -47,15 +37,7 @@ subroutine InitializeInterfaceVariable(this, variable_name) character(len=*), intent(in) :: variable_name - nullify(this%iscalar) - nullify(this%int1d) - nullify(this%int2d) - nullify(this%int3d) - nullify(this%rscalar) - nullify(this%r81d) - nullify(this%r82d) - nullify(this%r83d) - + this%data => null() this%variable_name = variable_name this%active = .false. From 0c8af67cb06316bcfa797069584aee9e49b0b613 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 29 Aug 2025 15:37:21 -0700 Subject: [PATCH 044/113] align registry procedures to use key instead of variable name --- main/FatesInterfaceMod.F90 | 10 +++++----- main/FatesInterfaceVarTypeMod.F90 | 12 +++++++----- 2 files changed, 12 insertions(+), 10 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index f162baca82..f7f2f1b512 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2744,8 +2744,8 @@ subroutine DefineInterfaceRegistry(this, initialize) ivar = 0 ! Define the interface registry names and indices - call this%DefineInterfaceVariable(variable_name='decomp_frac_moisture', index=ivar, initialize=initialize) - call this%DefineInterfaceVariable(variable_name='decomp_frac_temperature', index=ivar, initialize=initialize) + call this%DefineInterfaceVariable(key='decomp_frac_moisture', index=ivar, initialize=initialize) + call this%DefineInterfaceVariable(key='decomp_frac_temperature', index=ivar, initialize=initialize) ! Set the registry size based on the final update of ivar this%num_api_vars = ivar @@ -2755,12 +2755,12 @@ end subroutine DefineInterfaceRegistry ! ====================================================================================== -subroutine DefineInterfaceVariable(this, variable_name, index, initialize) +subroutine DefineInterfaceVariable(this, key, index, initialize) ! This procedure class(fates_interface_type) :: this - character(len=*), intent(in) :: variable_name + character(len=*), intent(in) :: key integer, intent(inout) :: index logical, intent(in) :: initialize @@ -2769,7 +2769,7 @@ subroutine DefineInterfaceVariable(this, variable_name, index, initialize) ! If we are initializing the if (initialize) then - call this%api_vars(index)%Init(variable_name) + call this%api_vars(index)%Init(key) end if end subroutine DefineInterfaceVariable diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index 6c571cd68d..f834747d95 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -22,8 +22,8 @@ module FatesInterfaceVariableTypeMod logical :: active ! true if the variable is used by the host land model contains - procedure :: Init => InitializeInterfaceVariable - procedure :: Register => RegisterInterfaceVariable_int_scalar + procedure :: Initialize => InitializeInterfaceVariable + procedure :: Register => RegisterInterfaceVariable end type fates_interface_variable_type @@ -31,14 +31,14 @@ module FatesInterfaceVariableTypeMod ! ==================================================================================== - subroutine InitializeInterfaceVariable(this, variable_name) + subroutine InitializeInterfaceVariable(this, key) class(fates_interface_variable_type) :: this - character(len=*), intent(in) :: variable_name + character(len=*), intent(in) :: key this%data => null() - this%variable_name = variable_name + this%key = key this%active = .false. end subroutine InitializeInterfaceVariable @@ -57,4 +57,6 @@ subroutine RegisterInterfaceVariable(this, data, active) end subroutine RegisterInterfaceVariable + ! ==================================================================================== + end module FatesInterfaceVariableTypeMod \ No newline at end of file From a75a767eafb7131c937b23438737067b4f1773eb Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 29 Aug 2025 15:44:51 -0700 Subject: [PATCH 045/113] update interface var type with key name --- main/FatesInterfaceVarTypeMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index f834747d95..51b6717811 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -17,9 +17,9 @@ module FatesInterfaceVariableTypeMod ! Interface variable registry type type, public :: fates_interface_variable_type - character(len=48) :: variable_name ! common registry key - class(*), pointer :: data ! unlimited polymorphic data pointer - logical :: active ! true if the variable is used by the host land model + character(len=48) :: key ! common registry key + class(*), pointer :: data ! unlimited polymorphic data pointer + logical :: active ! true if the variable is used by the host land model contains procedure :: Initialize => InitializeInterfaceVariable From 84eef2d08048a5e9e83ad46da99129089d8c3453 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 29 Aug 2025 16:18:09 -0700 Subject: [PATCH 046/113] build error corrections for the registry --- main/FatesInterfaceMod.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index f7f2f1b512..b159653747 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -163,7 +163,7 @@ module FatesInterfaceMod type(bc_pconst_type) :: bc_pconst ! This is the interface registry which associates variables with a common keyword - type(fates_interface_variable_type) :: api_vars(:) + type(fates_interface_variable_type), allocatable :: api_vars(:) ! The number of variables in the registry integer :: num_api_vars @@ -174,7 +174,7 @@ module FatesInterfaceMod procedure :: Register => RegisterInterfaceVariables procedure, private :: DefineInterfaceRegistry - procedure, private :: SetInterfaceVariable + procedure, private :: DefineInterfaceVariable procedure, private :: GetRegistryIndex end type fates_interface_type @@ -2720,7 +2720,7 @@ subroutine InitializeInterfaceRegistry(this) call this%DefineInterfaceRegistry(initialize=.false.) ! Allocate the registry - allocate(this%api_vars(this%num_hlm_vars)) + allocate(this%api_vars(this%num_api_vars)) ! Now set up the registry keys call this%DefineInterfaceRegistry(initialize=.true.) @@ -2769,7 +2769,7 @@ subroutine DefineInterfaceVariable(this, key, index, initialize) ! If we are initializing the if (initialize) then - call this%api_vars(index)%Init(key) + call this%api_vars(index)%Initialize(key) end if end subroutine DefineInterfaceVariable @@ -2787,7 +2787,7 @@ subroutine RegisterInterfaceVariables(this, key, data) class(*), target, intent(in) :: data ! data to be associated with key ! Get index from registry key and associate the given data pointer - this%api_vars(GetRegistryIndex(key))%Register(data, active=.true.) + call this%api_vars(this%GetRegistryIndex(key))%Register(data, active=.true.) end subroutine RegisterInterfaceVariables @@ -2799,13 +2799,13 @@ integer function GetRegistryIndex(this, key) result(index) class(fates_interface_type) :: this - integer, intent(in) :: key + 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%api_vars(ivar)%variable_name == key) then + if (this%api_vars(ivar)%key == key) then index = ivar return end if From 5cf3b01b14c7fb2d70982649a5caecc912cadc2a Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 2 Sep 2025 12:35:58 -0700 Subject: [PATCH 047/113] Make 2d registration subroutine --- main/FatesInterfaceMod.F90 | 10 +++++----- main/FatesInterfaceVarTypeMod.F90 | 13 ++++++++----- 2 files changed, 13 insertions(+), 10 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index b159653747..2415c17ecd 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -171,7 +171,7 @@ module FatesInterfaceMod contains procedure :: InitializeInterfaceRegistry - procedure :: Register => RegisterInterfaceVariables + procedure :: Register => RegisterInterfaceVariables_2d procedure, private :: DefineInterfaceRegistry procedure, private :: DefineInterfaceVariable @@ -2776,20 +2776,20 @@ end subroutine DefineInterfaceVariable ! ====================================================================================== - subroutine RegisterInterfaceVariables(this, key, data) + subroutine RegisterInterfaceVariables_2d(this, key, data) ! This procedure is called by the host land model to associate a data variable ! with a particular registry key class(fates_interface_type) :: this - character(len=*), intent(in) :: key ! variable registry key - class(*), target, intent(in) :: data ! data to be associated with key + character(len=*), intent(in) :: key ! variable registry key + class(*), target, intent(in) :: data(:,:) ! data to be associated with key ! Get index from registry key and associate the given data pointer call this%api_vars(this%GetRegistryIndex(key))%Register(data, active=.true.) - end subroutine RegisterInterfaceVariables + end subroutine RegisterInterfaceVariables_2d ! ====================================================================================== diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index 51b6717811..26942da4ce 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -18,12 +18,12 @@ module FatesInterfaceVariableTypeMod type, public :: fates_interface_variable_type character(len=48) :: key ! common registry key - class(*), pointer :: data ! unlimited polymorphic data pointer + class(*), pointer :: data(:,:) ! unlimited polymorphic data pointer logical :: active ! true if the variable is used by the host land model contains procedure :: Initialize => InitializeInterfaceVariable - procedure :: Register => RegisterInterfaceVariable + procedure :: Register => RegisterInterfaceVariable_2d end type fates_interface_variable_type @@ -45,17 +45,20 @@ end subroutine InitializeInterfaceVariable ! ==================================================================================== - subroutine RegisterInterfaceVariable(this, data, active) + subroutine RegisterInterfaceVariable_2d(this, data, active) class(fates_interface_variable_type) :: this - class(*), target, intent(in) :: data + class(*), target, intent(in) :: data(:,:) logical, intent(in) :: active + ! TODO: add type check here to validate acceptable types? + this%data => data + ! allocate(this%data, source=data) this%active = active - end subroutine RegisterInterfaceVariable + end subroutine RegisterInterfaceVariable_2d ! ==================================================================================== From 9dee2e93288c20b63c8a5c9a53f16e29acee9d0f Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 2 Sep 2025 14:29:43 -0700 Subject: [PATCH 048/113] Revert "remove area fraction from flux into litter pools now that subroutine does not sum to the site level" This reverts commit 11a697791d59a2e18a50b7b15683a1e931563844. --- biogeochem/FatesSoilBGCFluxMod.F90 | 39 ++++++++++++++++-------------- 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 1c0cb9954b..5e5efcdac0 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -644,6 +644,7 @@ subroutine FluxIntoLitterPools(csite, bc_in) real(r8) :: surface_prof_tot ! normalizes the surface_prof array integer :: nlev_eff_soil ! number of effective soil layers integer :: nlev_eff_decomp ! number of effective decomp layers + real(r8) :: area_frac ! fraction of site's area of current patch real(r8) :: z_decomp ! Used for calculating depth midpoints of decomp layers integer :: el ! Element index (C,N,P,etc) integer :: j ! Soil layer index @@ -705,6 +706,8 @@ subroutine FluxIntoLitterPools(csite, bc_in) ! Set a pointer to the output boundary condition for the current patch bc_out => currentPatch%bc_out + area_frac = currentPatch%area/area + ! Loop over the different elements. elemloop: do el = 1, num_elements @@ -744,33 +747,33 @@ subroutine FluxIntoLitterPools(csite, bc_in) do ic = 1, ncwd do id = 1,nlev_eff_decomp flux_cel_si(id) = flux_cel_si(id) + & - litt%ag_cwd_frag(ic) * ED_val_cwd_fcel * surface_prof(id) + litt%ag_cwd_frag(ic) * ED_val_cwd_fcel * area_frac * surface_prof(id) flux_lig_si(id) = flux_lig_si(id) + & - litt%ag_cwd_frag(ic) * ED_val_cwd_flig * surface_prof(id) + litt%ag_cwd_frag(ic) * ED_val_cwd_flig * area_frac * surface_prof(id) end do do j = 1, nlev_eff_soil id = bc_in%decomp_id(j) ! Map from soil layer to decomp layer flux_cel_si(id) = flux_cel_si(id) + & - litt%bg_cwd_frag(ic,j) * ED_val_cwd_fcel + litt%bg_cwd_frag(ic,j) * ED_val_cwd_fcel * area_frac flux_lig_si(id) = flux_lig_si(id) + & - litt%bg_cwd_frag(ic,j) * ED_val_cwd_flig + litt%bg_cwd_frag(ic,j) * ED_val_cwd_flig * area_frac end do end do ! leaf and fine root fragmentation fluxes do id = 1,nlev_eff_decomp flux_lab_si(id) = flux_lab_si(id) + & - litt%leaf_fines_frag(ilabile) * surface_prof(id) + litt%leaf_fines_frag(ilabile) * area_frac* surface_prof(id) flux_cel_si(id) = flux_cel_si(id) + & - litt%leaf_fines_frag(icellulose) * surface_prof(id) + litt%leaf_fines_frag(icellulose) * area_frac* surface_prof(id) flux_lig_si(id) = flux_lig_si(id) + & - litt%leaf_fines_frag(ilignin) * surface_prof(id) + litt%leaf_fines_frag(ilignin) * area_frac* surface_prof(id) end do ! decaying seeds from the litter pool @@ -778,26 +781,26 @@ subroutine FluxIntoLitterPools(csite, bc_in) do id = 1,nlev_eff_decomp flux_lab_si(id) = flux_lab_si(id) + & (litt%seed_decay(ipft) + litt%seed_germ_decay(ipft)) * & - EDPftvarcon_inst%lf_flab(ipft) * surface_prof(id) + EDPftvarcon_inst%lf_flab(ipft) * area_frac* surface_prof(id) flux_cel_si(id) = flux_cel_si(id) + & (litt%seed_decay(ipft) + litt%seed_germ_decay(ipft)) * & - EDPftvarcon_inst%lf_fcel(ipft) * surface_prof(id) + EDPftvarcon_inst%lf_fcel(ipft) * area_frac* surface_prof(id) flux_lig_si(id) = flux_lig_si(id) + & (litt%seed_decay(ipft) + litt%seed_germ_decay(ipft)) * & - EDPftvarcon_inst%lf_flig(ipft) * surface_prof(id) + EDPftvarcon_inst%lf_flig(ipft) * area_frac* surface_prof(id) end do end do do j = 1, nlev_eff_soil id = bc_in%decomp_id(j) flux_lab_si(id) = flux_lab_si(id) + & - litt%root_fines_frag(ilabile,j) + litt%root_fines_frag(ilabile,j) * area_frac flux_cel_si(id) = flux_cel_si(id) + & - litt%root_fines_frag(icellulose,j) + litt%root_fines_frag(icellulose,j) * area_frac flux_lig_si(id) = flux_lig_si(id) + & - litt%root_fines_frag(ilignin,j) + litt%root_fines_frag(ilignin,j) * area_frac enddo ! Normalize all masses over the decomposition layer's depth @@ -868,17 +871,17 @@ subroutine FluxIntoLitterPools(csite, bc_in) end do if(tot_wood_c>nearzero) then - sum_N = sum_N + sum(litt%ag_cwd_frag)*(tot_wood_n/tot_wood_c) - sum_N = sum_N + sum(litt%bg_cwd_frag)*(tot_wood_n/tot_wood_c) + sum_N = sum_N + area_frac*sum(litt%ag_cwd_frag)*(tot_wood_n/tot_wood_c) + sum_N = sum_N + area_frac*sum(litt%bg_cwd_frag)*(tot_wood_n/tot_wood_c) end if if(tot_leaf_c>nearzero)then - sum_N = sum_N + sum(litt%leaf_fines_frag)*(tot_leaf_n / tot_leaf_c) + sum_N = sum_N + area_frac*sum(litt%leaf_fines_frag)*(tot_leaf_n / tot_leaf_c) end if if(tot_fnrt_c>nearzero)then - sum_N = sum_N + sum(litt%root_fines_frag)*(tot_fnrt_n / tot_fnrt_c) + sum_N = sum_N + area_frac*sum(litt%root_fines_frag)*(tot_fnrt_n / tot_fnrt_c) end if do ipft = 1,numpft - sum_N = sum_N + currentPatch%nitr_repro_stoich(ipft) * & + sum_N = sum_N + area_frac * currentPatch%nitr_repro_stoich(ipft) * & (litt%seed_decay(ipft) + litt%seed_germ_decay(ipft)) end do From ad86a87c079ba601a446d6cf0ac68c05b8bf1029 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 2 Sep 2025 14:33:07 -0700 Subject: [PATCH 049/113] Revert "move litter pointer assignment inside element loop" This reverts commit 16152e1e705f17c029ef4cf3fe123bdeebc1d0eb. --- biogeochem/FatesSoilBGCFluxMod.F90 | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 5e5efcdac0..3c4836f913 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -703,18 +703,16 @@ subroutine FluxIntoLitterPools(csite, bc_in) currentPatch => csite%oldest_patch fluxpatchloop: do while (associated(currentPatch)) - ! Set a pointer to the output boundary condition for the current patch - bc_out => currentPatch%bc_out + ! Set a pointer to the litter object + ! for the current element on the current + ! patch + litt => currentPatch%litter(el) + bc_out => currentPatch%bc_out area_frac = currentPatch%area/area ! Loop over the different elements. elemloop: do el = 1, num_elements - - ! Set a pointer to the litter object - ! for the current element on the current - ! patch - litt => currentPatch%litter(el) ! Zero out the boundary flux arrays ! Make a pointer to the cellulose, labile and lignin From 51f137b05e0b090f21b0e791e6c3076c51a3a1bd Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 2 Sep 2025 14:37:08 -0700 Subject: [PATCH 050/113] Revert "whitespace clean up" This reverts commit 8f3192c5b66b0f75deedb97d0236cf4638543484. --- biogeochem/FatesSoilBGCFluxMod.F90 | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 3c4836f913..67990b2bc8 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -743,15 +743,18 @@ subroutine FluxIntoLitterPools(csite, bc_in) end select do ic = 1, ncwd + do id = 1,nlev_eff_decomp flux_cel_si(id) = flux_cel_si(id) + & litt%ag_cwd_frag(ic) * ED_val_cwd_fcel * area_frac * surface_prof(id) flux_lig_si(id) = flux_lig_si(id) + & litt%ag_cwd_frag(ic) * ED_val_cwd_flig * area_frac * surface_prof(id) + end do do j = 1, nlev_eff_soil + id = bc_in%decomp_id(j) ! Map from soil layer to decomp layer flux_cel_si(id) = flux_cel_si(id) + & @@ -759,11 +762,13 @@ subroutine FluxIntoLitterPools(csite, bc_in) flux_lig_si(id) = flux_lig_si(id) + & litt%bg_cwd_frag(ic,j) * ED_val_cwd_flig * area_frac + end do end do ! leaf and fine root fragmentation fluxes do id = 1,nlev_eff_decomp + flux_lab_si(id) = flux_lab_si(id) + & litt%leaf_fines_frag(ilabile) * area_frac* surface_prof(id) @@ -772,8 +777,10 @@ subroutine FluxIntoLitterPools(csite, bc_in) flux_lig_si(id) = flux_lig_si(id) + & litt%leaf_fines_frag(ilignin) * area_frac* surface_prof(id) + end do + ! decaying seeds from the litter pool do ipft = 1,numpft do id = 1,nlev_eff_decomp @@ -823,6 +830,7 @@ subroutine FluxIntoLitterPools(csite, bc_in) if(trim(hlm_decomp).eq.'MIMICS') then + ! If we track nitrogen (ie cnp or other) then ! we diagnose the c-lig/n ratio directly from the pools if(element_pos(nitrogen_element)>0) then @@ -841,6 +849,7 @@ subroutine FluxIntoLitterPools(csite, bc_in) sum_N = 0._r8 + tot_leaf_c = 0._r8 tot_leaf_n = 0._r8 tot_fnrt_c = 0._r8 @@ -902,6 +911,10 @@ subroutine FluxIntoLitterPools(csite, bc_in) currentPatch => currentPatch%younger end do fluxpatchloop + + + + return end subroutine FluxIntoLitterPools From 67e5155c3cc743daa843f6849f77ddb76f3d8fac Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 2 Sep 2025 14:37:23 -0700 Subject: [PATCH 051/113] Revert "Update the mimics portion of the fluxintolitterpools code to be within the previous patch loop structure" This reverts commit d2184ee71a15148c506339662a358a8005cb1a02. --- biogeochem/FatesSoilBGCFluxMod.F90 | 166 +++++++++++++++-------------- 1 file changed, 86 insertions(+), 80 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 67990b2bc8..98b69abc36 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -586,7 +586,7 @@ end subroutine EffluxIntoLitterPools ! ===================================================================================== - subroutine FluxIntoLitterPools(csite, bc_in) + subroutine FluxIntoLitterPools(csite, bc_in, bc_out) ! ----------------------------------------------------------------------------------- ! Created by Charlie Koven and Rosie Fisher, 2014-2015 @@ -822,96 +822,102 @@ subroutine FluxIntoLitterPools(csite, bc_in) end do elemloop - ! If we are coupled with MIMICS, then we need some assessment of litter quality - ! ie ligC/totalN. If we are not tracking N in the litter flux (ie C-only model) - ! then we need to approximate this by estimating the mean C:N ratios of each - ! plant organ, and mulitplying that by the different C Fluxes to get a total - ! approximate N flux. Note, in C-only, we will not capture any re-absorption. - - if(trim(hlm_decomp).eq.'MIMICS') then - + currentPatch => currentPatch%younger - ! If we track nitrogen (ie cnp or other) then - ! we diagnose the c-lig/n ratio directly from the pools - if(element_pos(nitrogen_element)>0) then + end do fluxpatchloop - ! Sum totalN fluxes over depth [g/m2] - sum_N = sum((bc_out%litt_flux_cel_n_si(1:nlev_eff_soil) + & - bc_out%litt_flux_lig_n_si(1:nlev_eff_soil) + & - bc_out%litt_flux_lab_n_si(1:nlev_eff_soil)) * & - bc_in%dz_sisl(1:nlev_eff_soil)) - - else - - ! In this case (Carbon Only), we use the stoichiometry parameters to estimate - ! the C:N of live vegetation and the seedbank, and use that - ! as a proxy for the C:N of the litter flux + ! If we are coupled with MIMICS, then we need some assessment of litter quality + ! ie ligC/totalN. If we are not tracking N in the litter flux (ie C-only model) + ! then we need to approximate this by estimating the mean C:N ratios of each + ! plant organ, and mulitplying that by the different C Fluxes to get a total + ! approximate N flux. Note, in C-only, we will not capture any re-absorption. + + if(trim(hlm_decomp).eq.'MIMICS') then - sum_N = 0._r8 - + ! If we track nitrogen (ie cnp or other) then + ! we diagnose the c-lig/n ratio directly from the pools + if(element_pos(nitrogen_element)>0) then - tot_leaf_c = 0._r8 - tot_leaf_n = 0._r8 - tot_fnrt_c = 0._r8 - tot_fnrt_n = 0._r8 - tot_wood_c = 0._r8 - tot_wood_n = 0._r8 - - ccohort => currentPatch%tallest - do while (associated(ccohort)) - ipft = ccohort%pft - leaf_c = ccohort%n * area_inv * ccohort%prt%GetState(leaf_organ, carbon12_element) - sapw_c = ccohort%n * area_inv * ccohort%prt%GetState(sapw_organ, carbon12_element) - fnrt_c = ccohort%n * area_inv * ccohort%prt%GetState(fnrt_organ, carbon12_element) - struct_c = ccohort%n * area_inv * ccohort%prt%GetState(struct_organ, carbon12_element) - leaf_n = leaf_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(leaf_organ)) - sapw_n = sapw_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(sapw_organ)) - fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(fnrt_organ)) - struct_n = struct_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(struct_organ)) - tot_leaf_c = tot_leaf_c + leaf_c - tot_leaf_n = tot_leaf_n + leaf_n - tot_fnrt_c = tot_fnrt_c + fnrt_c - tot_fnrt_n = tot_fnrt_n + fnrt_n - tot_wood_c = tot_wood_c + sapw_c + struct_c - tot_wood_n = tot_wood_n + sapw_n + struct_n - ccohort => ccohort%shorter - end do - - if(tot_wood_c>nearzero) then - sum_N = sum_N + area_frac*sum(litt%ag_cwd_frag)*(tot_wood_n/tot_wood_c) - sum_N = sum_N + area_frac*sum(litt%bg_cwd_frag)*(tot_wood_n/tot_wood_c) - end if - if(tot_leaf_c>nearzero)then - sum_N = sum_N + area_frac*sum(litt%leaf_fines_frag)*(tot_leaf_n / tot_leaf_c) - end if - if(tot_fnrt_c>nearzero)then - sum_N = sum_N + area_frac*sum(litt%root_fines_frag)*(tot_fnrt_n / tot_fnrt_c) - end if - do ipft = 1,numpft - sum_N = sum_N + area_frac * currentPatch%nitr_repro_stoich(ipft) * & - (litt%seed_decay(ipft) + litt%seed_germ_decay(ipft)) - end do + ! Sum totalN fluxes over depth [g/m2] + sum_N = sum((bc_out%litt_flux_cel_n_si(1:nlev_eff_soil) + & + bc_out%litt_flux_lig_n_si(1:nlev_eff_soil) + & + bc_out%litt_flux_lab_n_si(1:nlev_eff_soil)) * & + bc_in%dz_sisl(1:nlev_eff_soil)) + + else + + ! In this case (Carbon Only), we use the stoichiometry parameters to estimate + ! the C:N of live vegetation and the seedbank, and use that + ! as a proxy for the C:N of the litter flux - ! Convert from kg/m2/day -> g/m2/s - sum_N = sum_N * days_per_sec * g_per_kg + sum_N = 0._r8 + + currentPatch => csite%oldest_patch + do while (associated(currentPatch)) - end if + litt => currentPatch%litter(element_pos(carbon12_element)) + area_frac = currentPatch%area*area_inv - ! Sum over layers and multiply by depth g/m3/s * m -> g/m2/s - sum_ligC = sum(bc_out%litt_flux_lig_c_si(1:nlev_eff_soil) * bc_in%dz_sisl(1:nlev_eff_soil)) - - if(sum_N>nearzero)then - bc_out%litt_flux_ligc_per_n = sum_ligC / sum_N - else - bc_out%litt_flux_ligc_per_n = 0._r8 - end if + tot_leaf_c = 0._r8 + tot_leaf_n = 0._r8 + tot_fnrt_c = 0._r8 + tot_fnrt_n = 0._r8 + tot_wood_c = 0._r8 + tot_wood_n = 0._r8 - end if ! MIMICS check + ccohort => currentPatch%tallest + do while (associated(ccohort)) + ipft = ccohort%pft + leaf_c = ccohort%n * area_inv * ccohort%prt%GetState(leaf_organ, carbon12_element) + sapw_c = ccohort%n * area_inv * ccohort%prt%GetState(sapw_organ, carbon12_element) + fnrt_c = ccohort%n * area_inv * ccohort%prt%GetState(fnrt_organ, carbon12_element) + struct_c = ccohort%n * area_inv * ccohort%prt%GetState(struct_organ, carbon12_element) + leaf_n = leaf_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(leaf_organ)) + sapw_n = sapw_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(sapw_organ)) + fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(fnrt_organ)) + struct_n = struct_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(struct_organ)) + tot_leaf_c = tot_leaf_c + leaf_c + tot_leaf_n = tot_leaf_n + leaf_n + tot_fnrt_c = tot_fnrt_c + fnrt_c + tot_fnrt_n = tot_fnrt_n + fnrt_n + tot_wood_c = tot_wood_c + sapw_c + struct_c + tot_wood_n = tot_wood_n + sapw_n + struct_n + ccohort => ccohort%shorter + end do - currentPatch => currentPatch%younger + if(tot_wood_c>nearzero) then + sum_N = sum_N + area_frac*sum(litt%ag_cwd_frag)*(tot_wood_n/tot_wood_c) + sum_N = sum_N + area_frac*sum(litt%bg_cwd_frag)*(tot_wood_n/tot_wood_c) + end if + if(tot_leaf_c>nearzero)then + sum_N = sum_N + area_frac*sum(litt%leaf_fines_frag)*(tot_leaf_n / tot_leaf_c) + end if + if(tot_fnrt_c>nearzero)then + sum_N = sum_N + area_frac*sum(litt%root_fines_frag)*(tot_fnrt_n / tot_fnrt_c) + end if + do ipft = 1,numpft + sum_N = sum_N + area_frac * currentPatch%nitr_repro_stoich(ipft) * & + (litt%seed_decay(ipft) + litt%seed_germ_decay(ipft)) + end do - end do fluxpatchloop + currentPatch => currentPatch%younger + end do + + ! Convert from kg/m2/day -> g/m2/s + sum_N = sum_N * days_per_sec * g_per_kg + + end if + ! Sum over layers and multiply by depth g/m3/s * m -> g/m2/s + sum_ligC = sum(bc_out%litt_flux_lig_c_si(1:nlev_eff_soil) * bc_in%dz_sisl(1:nlev_eff_soil)) + + if(sum_N>nearzero)then + bc_out%litt_flux_ligc_per_n = sum_ligC / sum_N + else + bc_out%litt_flux_ligc_per_n = 0._r8 + end if + + end if From 91d472e08bc72e8ed72631fce00786391b388bdd Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 2 Sep 2025 14:37:41 -0700 Subject: [PATCH 052/113] Revert "Update fluxintolitterpool non-mimics section to use the patch-level bc_out litter variables." This reverts commit aa269da3ec1d68fe1e159b2529872d9d29344f23. --- biogeochem/FatesSoilBGCFluxMod.F90 | 109 +++++++++++++++-------------- 1 file changed, 55 insertions(+), 54 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 98b69abc36..e0af2a9e0f 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -627,6 +627,7 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) ! !ARGUMENTS type(ed_site_type) , intent(inout) :: csite type(bc_in_type) , intent(in) :: bc_in + type(bc_out_type) , intent(inout),target :: bc_out ! !LOCAL VARIABLES: type (fates_patch_type), pointer :: currentPatch @@ -635,7 +636,6 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) real(r8), pointer :: flux_lab_si(:) real(r8), pointer :: flux_lig_si(:) type(litter_type), pointer :: litt - type(bc_out_type), pointer :: bc_out real(r8) :: surface_prof(bc_in%nlevsoil) ! this array is used to distribute ! fragmented litter on the surface @@ -700,48 +700,46 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) surface_prof(id) = surface_prof(id)/surface_prof_tot end do - currentPatch => csite%oldest_patch - fluxpatchloop: do while (associated(currentPatch)) + ! Loop over the different elements. + do el = 1, num_elements + + ! Zero out the boundary flux arrays + ! Make a pointer to the cellulose, labile and lignin + ! flux partitions. + + select case (element_list(el)) + case (carbon12_element) + bc_out%litt_flux_cel_c_si(:) = 0.0_r8 + bc_out%litt_flux_lig_c_si(:) = 0.0_r8 + bc_out%litt_flux_lab_c_si(:) = 0.0_r8 + flux_cel_si => bc_out%litt_flux_cel_c_si(:) + flux_lab_si => bc_out%litt_flux_lab_c_si(:) + flux_lig_si => bc_out%litt_flux_lig_c_si(:) + case (nitrogen_element) + bc_out%litt_flux_cel_n_si(:) = 0._r8 + bc_out%litt_flux_lig_n_si(:) = 0._r8 + bc_out%litt_flux_lab_n_si(:) = 0._r8 + flux_cel_si => bc_out%litt_flux_cel_n_si(:) + flux_lab_si => bc_out%litt_flux_lab_n_si(:) + flux_lig_si => bc_out%litt_flux_lig_n_si(:) + case (phosphorus_element) + bc_out%litt_flux_cel_p_si(:) = 0._r8 + bc_out%litt_flux_lig_p_si(:) = 0._r8 + bc_out%litt_flux_lab_p_si(:) = 0._r8 + flux_cel_si => bc_out%litt_flux_cel_p_si(:) + flux_lab_si => bc_out%litt_flux_lab_p_si(:) + flux_lig_si => bc_out%litt_flux_lig_p_si(:) + end select - ! Set a pointer to the litter object - ! for the current element on the current - ! patch - litt => currentPatch%litter(el) - bc_out => currentPatch%bc_out + currentPatch => csite%oldest_patch + do while (associated(currentPatch)) - area_frac = currentPatch%area/area - - ! Loop over the different elements. - elemloop: do el = 1, num_elements + ! Set a pointer to the litter object + ! for the current element on the current + ! patch + litt => currentPatch%litter(el) + area_frac = currentPatch%area/area - ! Zero out the boundary flux arrays - ! Make a pointer to the cellulose, labile and lignin - ! flux partitions. - - select case (element_list(el)) - case (carbon12_element) - bc_out%litt_flux_cel_c_si(:) = 0.0_r8 - bc_out%litt_flux_lig_c_si(:) = 0.0_r8 - bc_out%litt_flux_lab_c_si(:) = 0.0_r8 - flux_cel_si => bc_out%litt_flux_cel_c_si(:) - flux_lab_si => bc_out%litt_flux_lab_c_si(:) - flux_lig_si => bc_out%litt_flux_lig_c_si(:) - case (nitrogen_element) - bc_out%litt_flux_cel_n_si(:) = 0._r8 - bc_out%litt_flux_lig_n_si(:) = 0._r8 - bc_out%litt_flux_lab_n_si(:) = 0._r8 - flux_cel_si => bc_out%litt_flux_cel_n_si(:) - flux_lab_si => bc_out%litt_flux_lab_n_si(:) - flux_lig_si => bc_out%litt_flux_lig_n_si(:) - case (phosphorus_element) - bc_out%litt_flux_cel_p_si(:) = 0._r8 - bc_out%litt_flux_lig_p_si(:) = 0._r8 - bc_out%litt_flux_lab_p_si(:) = 0._r8 - flux_cel_si => bc_out%litt_flux_cel_p_si(:) - flux_lab_si => bc_out%litt_flux_lab_p_si(:) - flux_lig_si => bc_out%litt_flux_lig_p_si(:) - end select - do ic = 1, ncwd do id = 1,nlev_eff_decomp @@ -765,8 +763,12 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) end do end do + + + ! leaf and fine root fragmentation fluxes + do id = 1,nlev_eff_decomp flux_lab_si(id) = flux_lab_si(id) + & @@ -808,23 +810,22 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) litt%root_fines_frag(ilignin,j) * area_frac enddo - ! Normalize all masses over the decomposition layer's depth - ! Convert from kg/m2/day -> g/m3/s - - do id = 1,nlev_eff_decomp - flux_cel_si(id) = days_per_sec * g_per_kg * & - flux_cel_si(id) / bc_in%dz_decomp_sisl(id) - flux_lig_si(id) = days_per_sec * g_per_kg * & - flux_lig_si(id) / bc_in%dz_decomp_sisl(id) - flux_lab_si(id) = days_per_sec * g_per_kg * & - flux_lab_si(id) / bc_in%dz_decomp_sisl(id) - end do + currentPatch => currentPatch%younger + end do - end do elemloop + ! Normalize all masses over the decomposition layer's depth + ! Convert from kg/m2/day -> g/m3/s - currentPatch => currentPatch%younger + do id = 1,nlev_eff_decomp + flux_cel_si(id) = days_per_sec * g_per_kg * & + flux_cel_si(id) / bc_in%dz_decomp_sisl(id) + flux_lig_si(id) = days_per_sec * g_per_kg * & + flux_lig_si(id) / bc_in%dz_decomp_sisl(id) + flux_lab_si(id) = days_per_sec * g_per_kg * & + flux_lab_si(id) / bc_in%dz_decomp_sisl(id) + end do - end do fluxpatchloop + end do ! do elements ! If we are coupled with MIMICS, then we need some assessment of litter quality ! ie ligC/totalN. If we are not tracking N in the litter flux (ie C-only model) From dfc5624728e2a81fad144b20b80f70afff6004f5 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 2 Sep 2025 14:38:53 -0700 Subject: [PATCH 053/113] Revert "remove now unused bc_out from flux into litter pool procedure" This reverts commit 9832f64239219052f089f927ae6188a831750eda. --- main/EDMainMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index c49c1be196..c5b2cad8c9 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -804,7 +804,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! can remove it completely if/when this call is added in ELM to ! subroutine UpdateLitterFluxes(this,bounds_clump) in elmfates_interfaceMod.F90 - call FluxIntoLitterPools(currentsite, bc_in) + call FluxIntoLitterPools(currentsite, bc_in, bc_out) ! Update cohort number. From 669a8165d12a2d12b683b23fa0bfc36788caa9a5 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 3 Sep 2025 16:17:09 -0700 Subject: [PATCH 054/113] create interface registry type to be used by both fates_interface_type and fates_patch_type --- main/FatesInterfaceTypesMod.F90 | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 06cdb7c606..2836b9b442 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -8,6 +8,7 @@ module FatesInterfaceTypesMod use shr_log_mod , only : errMsg => shr_log_errMsg use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + implicit none private ! By default everything is private @@ -841,9 +842,29 @@ module FatesInterfaceTypesMod end type bc_pconst_type + ! Base type to be extended for the API registry + type, public :: fates_interface_registry_base_type + + integer :: num_api_vars + + ! container array of interface variables + type(fates_interface_variable_type), allocatable :: vars(:) + + contains + + procedure :: InitializeInterfaceRegistry + procedure :: Register => RegisterInterfaceVariables_1d, RegisterInterfaceVariables_2d + + procedure, private :: DefineInterfaceRegistry + procedure, private :: DefineInterfaceVariable + procedure, private :: GetRegistryIndex + + end type fates_interface_registry_base_type + public :: ZeroBCOutCarbonFluxes contains + ! ====================================================================================== From c04c59f5a9a36976306a7d149759748b3f902697 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 3 Sep 2025 16:18:19 -0700 Subject: [PATCH 055/113] move the registry type-bound procedures from fatesinterfacemod --- main/FatesInterfaceMod.F90 | 121 +---------------------------- main/FatesInterfaceTypesMod.F90 | 132 +++++++++++++++++++++++++++++++- 2 files changed, 130 insertions(+), 123 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 2415c17ecd..08470934e5 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -114,7 +114,6 @@ module FatesInterfaceMod use FatesTwoStreamUtilsMod, only : TransferRadParams use LeafBiophysicsMod , only : lb_params use LeafBiophysicsMod , only : FvCB1980 - use FatesInterfaceVariableTypeMod, only : fates_interface_variable_type ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -163,20 +162,9 @@ module FatesInterfaceMod type(bc_pconst_type) :: bc_pconst ! This is the interface registry which associates variables with a common keyword - type(fates_interface_variable_type), allocatable :: api_vars(:) + ! type(fates_interface_variable_type), allocatable :: api_vars(:) + type(fates_interface_registry_base_type) :: api - ! The number of variables in the registry - integer :: num_api_vars - - contains - - procedure :: InitializeInterfaceRegistry - procedure :: Register => RegisterInterfaceVariables_2d - - procedure, private :: DefineInterfaceRegistry - procedure, private :: DefineInterfaceVariable - procedure, private :: GetRegistryIndex - end type fates_interface_type character(len=*), parameter :: sourcefile = & @@ -2708,111 +2696,6 @@ end subroutine FatesReadParameters ! ====================================================================================== -subroutine InitializeInterfaceRegistry(this) - - ! This initializes the interface registry - - class(fates_interface_type) :: this - - logical :: initialize - - ! First count up the keys defined in the registry - call this%DefineInterfaceRegistry(initialize=.false.) - - ! Allocate the registry - allocate(this%api_vars(this%num_api_vars)) - - ! Now set up the registry keys - call this%DefineInterfaceRegistry(initialize=.true.) - -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_type) :: this - - logical, intent(in) :: initialize ! false = count up the keys in the registry - - integer :: ivar ! indices - - ! Set ivar to zero. This will be incremented via each call to SetInterfaceVariable - ivar = 0 - - ! Define the interface registry names and indices - call this%DefineInterfaceVariable(key='decomp_frac_moisture', index=ivar, initialize=initialize) - call this%DefineInterfaceVariable(key='decomp_frac_temperature', index=ivar, initialize=initialize) - - ! Set the registry size based on the final update of ivar - this%num_api_vars = ivar - - -end subroutine DefineInterfaceRegistry - -! ====================================================================================== - -subroutine DefineInterfaceVariable(this, key, index, initialize) - - ! This procedure - class(fates_interface_type) :: this - character(len=*), intent(in) :: key - integer, intent(inout) :: index - logical, intent(in) :: initialize - - ! Increment the index to return count - index = index + 1 - - ! If we are initializing the - if (initialize) then - call this%api_vars(index)%Initialize(key) - end if - -end subroutine DefineInterfaceVariable - -! ====================================================================================== - - subroutine RegisterInterfaceVariables_2d(this, key, data) - - ! This procedure is called by the host land model to associate a data variable - ! with a particular registry key - - class(fates_interface_type) :: this - - character(len=*), intent(in) :: key ! variable registry key - class(*), target, intent(in) :: data(:,:) ! data to be associated with key - - ! Get index from registry key and associate the given data pointer - call this%api_vars(this%GetRegistryIndex(key))%Register(data, active=.true.) - - end subroutine RegisterInterfaceVariables_2d - -! ====================================================================================== - -integer function GetRegistryIndex(this, key) result(index) - - ! This procedure returns the index associated with the key provided - - class(fates_interface_type) :: 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%api_vars(ivar)%key == key) then - index = ivar - return - end if - end do - -end function GetRegistryIndex - -! ====================================================================================== end module FatesInterfaceMod diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 2836b9b442..afa757feb6 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -7,7 +7,8 @@ module FatesInterfaceTypesMod 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 @@ -866,9 +867,9 @@ module FatesInterfaceTypesMod contains - ! ====================================================================================== + ! ====================================================================================== - subroutine ZeroBCOutCarbonFluxes(bc_out) + subroutine ZeroBCOutCarbonFluxes(bc_out) ! !ARGUMENTS type(bc_out_type), intent(inout) :: bc_out @@ -880,6 +881,129 @@ subroutine ZeroBCOutCarbonFluxes(bc_out) end subroutine ZeroBCOutCarbonFluxes - + ! ====================================================================================== + + subroutine InitializeInterfaceRegistry(this) + + ! This initializes the interface registry + + class(fates_interface_registry_base_type) :: this + + logical :: initialize + + ! First count up the keys defined in the registry + call this%DefineInterfaceRegistry(initialize=.false.) + + ! Allocate the registry + allocate(this%vars(this%num_api_vars)) + + ! Now set up the registry keys + call this%DefineInterfaceRegistry(initialize=.true.) + + 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) :: this + + logical, intent(in) :: initialize ! false = count up the keys in the registry + + integer :: ivar ! indices + + ! Set ivar to zero. This will be incremented via each call to SetInterfaceVariable + ivar = 0 + + ! Define the interface registry names and indices + call this%DefineInterfaceVariable(key='decomp_frac_moisture', index=ivar, initialize=initialize) + call this%DefineInterfaceVariable(key='decomp_frac_temperature', index=ivar, initialize=initialize) + + ! Set the registry size based on the final update of ivar + this%num_api_vars = ivar + + + end subroutine DefineInterfaceRegistry + + ! ====================================================================================== + + subroutine DefineInterfaceVariable(this, key, index, initialize) + + class(fates_interface_registry_base_type) :: this + + character(len=*), intent(in) :: key + integer, intent(inout) :: index + logical, intent(in) :: initialize + + ! Increment the index to return count + index = index + 1 + + ! If we are initializing the + if (initialize) then + call this%vars(index)%Initialize(key) + end if + + end subroutine DefineInterfaceVariable + + ! ====================================================================================== + + subroutine RegisterInterfaceVariables_1d(this, key, data) + + ! This procedure is called by the to associate a data variable + ! with a particular registry key + + class(fates_interface_registry_base_type) :: this + + character(len=*), intent(in) :: key ! variable registry key + class(*), target, intent(in) :: data(:) ! data to be associated with key + + ! Get index from registry key and associate the given data pointer + call this%vars(this%GetRegistryIndex(key))%Register(data, active=.true.) + + end subroutine RegisterInterfaceVariables_1d + + ! ====================================================================================== + + subroutine RegisterInterfaceVariables_2d(this, key, data) + + ! This procedure is called by the to associate a data variable + ! with a particular registry key + + class(fates_interface_registry_base_type) :: this + + character(len=*), intent(in) :: key ! variable registry key + class(*), target, intent(in) :: data(:,:) ! data to be associated with key + + ! Get index from registry key and associate the given data pointer + call this%vars(this%GetRegistryIndex(key))%Register(data, active=.true.) + + end subroutine RegisterInterfaceVariables_2d + + ! ====================================================================================== + + integer function GetRegistryIndex(this, key) result(index) + + ! This procedure returns the index associated with the key provided + + class(fates_interface_registry_base_type) :: 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 + + ! ====================================================================================== end module FatesInterfaceTypesMod From 9c2d367504f7101a9da3ccb32c2a68dcc0baa79c Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 3 Sep 2025 16:19:03 -0700 Subject: [PATCH 056/113] implement the interface registry type in the patch type --- biogeochem/FatesPatchMod.F90 | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index f730191eb9..ff42967099 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -34,6 +34,7 @@ module FatesPatchMod 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 @@ -55,6 +56,9 @@ module FatesPatchMod ! 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 !--------------------------------------------------------------------------- @@ -249,6 +253,8 @@ module FatesPatchMod procedure :: Dump procedure :: CheckVars + procedure, private :: RegisterFatesInterfaceVariables + end type fates_patch_type contains @@ -283,6 +289,9 @@ subroutine Init(this, num_swb, num_levsoil) allocate(this%bc_out%litt_flux_lig_c_si(this%bc_in%nlevdecomp)) allocate(this%bc_out%litt_flux_lab_c_si(this%bc_in%nlevdecomp)) + ! Allocate API registry + call this%RegisterFatesInterfaceVariables() + ! initialize all values to nan call this%NanValues() @@ -1311,4 +1320,19 @@ end subroutine CheckVars !=========================================================================== + subroutine RegisterFatesInterfaceVariables(this) + + class(fates_patch_type) :: this + + ! Initialize the HLM-FATES interface variable registry for the FATES-side + call this%api%InitializeInterfaceRegistry() + + ! Register the FATES boundary condition data variables + call this%api%Register('decomp_frac_moisture', this%bc_in%w_scalar_sisl) + call this%api%Register('decomp_frac_temperature', this%bc_in%t_scalar_sisl) + + end subroutine RegisterFatesInterfaceVariables + +! ====================================================================================== + end module FatesPatchMod From e1548805ffa2d42325138935ac73601997879e0f Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 3 Sep 2025 16:19:39 -0700 Subject: [PATCH 057/113] add a 1d variant of the register generic for the fates-side variables --- main/FatesInterfaceVarTypeMod.F90 | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index 26942da4ce..b83e05522b 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -18,12 +18,12 @@ module FatesInterfaceVariableTypeMod type, public :: fates_interface_variable_type character(len=48) :: key ! common registry key - class(*), pointer :: data(:,:) ! unlimited polymorphic data pointer + class(*), pointer :: data ! unlimited polymorphic data pointer logical :: active ! true if the variable is used by the host land model contains procedure :: Initialize => InitializeInterfaceVariable - procedure :: Register => RegisterInterfaceVariable_2d + procedure :: Register => RegisterInterfaceVariable_1d, RegisterInterfaceVariable_2d end type fates_interface_variable_type @@ -45,6 +45,21 @@ end subroutine InitializeInterfaceVariable ! ==================================================================================== + subroutine RegisterInterfaceVariable_1d(this, data, active) + + class(fates_interface_variable_type) :: this + + class(*), target, intent(in) :: data(:) + logical, intent(in) :: active + + this%data => data + this%active = active + + end subroutine RegisterInterfaceVariable_1d + + ! ==================================================================================== + + subroutine RegisterInterfaceVariable_2d(this, data, active) class(fates_interface_variable_type) :: this @@ -52,14 +67,10 @@ subroutine RegisterInterfaceVariable_2d(this, data, active) class(*), target, intent(in) :: data(:,:) logical, intent(in) :: active - ! TODO: add type check here to validate acceptable types? - this%data => data - ! allocate(this%data, source=data) this%active = active end subroutine RegisterInterfaceVariable_2d ! ==================================================================================== - end module FatesInterfaceVariableTypeMod \ No newline at end of file From 4f780370ac0f304f7ef5f42a572b12476ce45115 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 9 Sep 2025 11:44:48 -0700 Subject: [PATCH 058/113] add explicit polymorphic pointers in the var type to handle different ranks --- main/FatesInterfaceVarTypeMod.F90 | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index b83e05522b..dcacffec96 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -17,13 +17,19 @@ module FatesInterfaceVariableTypeMod ! Interface variable registry type type, public :: fates_interface_variable_type - character(len=48) :: key ! common registry key - class(*), pointer :: data ! unlimited polymorphic data pointer - logical :: active ! true if the variable is used by the host land model + 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 contains procedure :: Initialize => InitializeInterfaceVariable - procedure :: Register => RegisterInterfaceVariable_1d, RegisterInterfaceVariable_2d + generic :: Register => RegisterInterfaceVariable_1d, RegisterInterfaceVariable_2d + + procedure, private :: RegisterInterfaceVariable_1d + procedure, private :: RegisterInterfaceVariable_2d end type fates_interface_variable_type @@ -37,7 +43,10 @@ subroutine InitializeInterfaceVariable(this, key) character(len=*), intent(in) :: key - this%data => null() + this%data0d => null() + this%data1d => null() + this%data2d => null() + this%data3d => null() this%key = key this%active = .false. @@ -52,7 +61,7 @@ subroutine RegisterInterfaceVariable_1d(this, data, active) class(*), target, intent(in) :: data(:) logical, intent(in) :: active - this%data => data + this%data1d => data(:) this%active = active end subroutine RegisterInterfaceVariable_1d @@ -67,7 +76,7 @@ subroutine RegisterInterfaceVariable_2d(this, data, active) class(*), target, intent(in) :: data(:,:) logical, intent(in) :: active - this%data => data + this%data2d => data(:,:) this%active = active end subroutine RegisterInterfaceVariable_2d From 8a1873a8a6f925a5e3dc5c6ec485c5f7172bdd6f Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 9 Sep 2025 11:45:14 -0700 Subject: [PATCH 059/113] correct the definition of the generic registry procedure --- main/FatesInterfaceTypesMod.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index afa757feb6..b1c83fdd38 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -854,8 +854,10 @@ module FatesInterfaceTypesMod contains procedure :: InitializeInterfaceRegistry - procedure :: Register => RegisterInterfaceVariables_1d, RegisterInterfaceVariables_2d + generic :: Register => RegisterInterfaceVariables_1d, RegisterInterfaceVariables_2d + procedure, private :: RegisterInterfaceVariables_1d + procedure, private :: RegisterInterfaceVariables_2d procedure, private :: DefineInterfaceRegistry procedure, private :: DefineInterfaceVariable procedure, private :: GetRegistryIndex @@ -961,7 +963,7 @@ subroutine RegisterInterfaceVariables_1d(this, key, data) class(*), target, intent(in) :: data(:) ! data to be associated with key ! Get index from registry key and associate the given data pointer - call this%vars(this%GetRegistryIndex(key))%Register(data, active=.true.) + call this%vars(this%GetRegistryIndex(key))%Register(data(:), active=.true.) end subroutine RegisterInterfaceVariables_1d @@ -978,7 +980,7 @@ subroutine RegisterInterfaceVariables_2d(this, key, data) class(*), target, intent(in) :: data(:,:) ! data to be associated with key ! Get index from registry key and associate the given data pointer - call this%vars(this%GetRegistryIndex(key))%Register(data, active=.true.) + call this%vars(this%GetRegistryIndex(key))%Register(data(:,:), active=.true.) end subroutine RegisterInterfaceVariables_2d From adca88f3cbc6bad9817ff0a7f5034c30986e4695 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 9 Sep 2025 12:06:39 -0700 Subject: [PATCH 060/113] minor formatting update --- main/FatesInterfaceTypesMod.F90 | 4 ++-- main/FatesInterfaceVarTypeMod.F90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index b1c83fdd38..86d3872e15 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -856,11 +856,11 @@ module FatesInterfaceTypesMod procedure :: InitializeInterfaceRegistry generic :: Register => RegisterInterfaceVariables_1d, RegisterInterfaceVariables_2d - procedure, private :: RegisterInterfaceVariables_1d - procedure, private :: RegisterInterfaceVariables_2d procedure, private :: DefineInterfaceRegistry procedure, private :: DefineInterfaceVariable procedure, private :: GetRegistryIndex + procedure, private :: RegisterInterfaceVariables_1d + procedure, private :: RegisterInterfaceVariables_2d end type fates_interface_registry_base_type diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index dcacffec96..cedf770e5c 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -26,7 +26,7 @@ module FatesInterfaceVariableTypeMod contains procedure :: Initialize => InitializeInterfaceVariable - generic :: Register => RegisterInterfaceVariable_1d, RegisterInterfaceVariable_2d + generic :: Register => RegisterInterfaceVariable_1d, RegisterInterfaceVariable_2d procedure, private :: RegisterInterfaceVariable_1d procedure, private :: RegisterInterfaceVariable_2d From 50737d4bf89b86bc5a13003802264922de309423 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 9 Sep 2025 14:13:32 -0700 Subject: [PATCH 061/113] add function to get the registry key from the given index --- main/FatesInterfaceTypesMod.F90 | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 86d3872e15..d05382247c 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -859,6 +859,7 @@ module FatesInterfaceTypesMod procedure, private :: DefineInterfaceRegistry procedure, private :: DefineInterfaceVariable procedure, private :: GetRegistryIndex + procedure, private :: GetRegistryKey procedure, private :: RegisterInterfaceVariables_1d procedure, private :: RegisterInterfaceVariables_2d @@ -1007,5 +1008,36 @@ integer function GetRegistryIndex(this, key) result(index) end function GetRegistryIndex ! ====================================================================================== + + character(len=*) function GetRegistryKey(this, index) result(key) + + ! This procedure returns the index associated with the key provided + + class(fates_interface_registry_base_type) :: this + + integer, intent(in) :: index ! variable registry index + + key = this%vars(index)%key + + end function GetRegistryIndex + + ! ====================================================================================== + + subroutine UpdateInterfaceVariables(this) + + class(fates_interface_registry_base_type) :: this + + integer :: ivar ! Iterator + + ! Iterate over the registry and update all active variables + do ivar = 1, this%num_api_vars + if (this%vars(ivar)%active) then + call this%vars(ivar)%Update() + end if + end do + + end subroutine UpdateInterfaceVariables + + ! ====================================================================================== end module FatesInterfaceTypesMod From f862536602d8d371abf93f93993c0af617b8c8f8 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 9 Sep 2025 14:26:28 -0700 Subject: [PATCH 062/113] start adding the interface update call for the hlm-fates interface during the dynamics update --- main/FatesInterfaceMod.F90 | 37 ++++++++++++++++++++++++++++++++++++- 1 file changed, 36 insertions(+), 1 deletion(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 08470934e5..6105d4c549 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -162,7 +162,6 @@ module FatesInterfaceMod type(bc_pconst_type) :: bc_pconst ! This is the interface registry which associates variables with a common keyword - ! type(fates_interface_variable_type), allocatable :: api_vars(:) type(fates_interface_registry_base_type) :: api end type fates_interface_type @@ -185,6 +184,7 @@ module FatesInterfaceMod public :: set_bcs public :: UpdateFatesRMeansTStep public :: InitTimeAveragingGlobals + public :: UpdateInterfaceVariables private :: FatesReadParameters public :: DetermineGridCellNeighbors @@ -2696,6 +2696,41 @@ end subroutine FatesReadParameters ! ====================================================================================== +subroutine UpdateFatesInterfaceVariables(this) + + class(fates_interface_type), intent(inout) :: this + + class(fates_registry_base_type), pointer :: patch_api + class(fates_patch_type), pointer :: currentPatch + + integer :: s ! site index + integer :: i ! HLM registry index + integer :: j ! FATES registry index + + do s = 1, this%nsites + currentPatch => this%sites(s)%oldest_patch + patch_api => currentPatch%api + do while (associated(currentPatch)) + do i = 1, this%num_api_vars + + ! Don't assume the index in the registry is the same as in the interface + j = patch_api%GetRegistryIndex(patch_api%GetRegistryKey(i)) + + ! TODO: we need meta data here to correctly associate the right slice of data + + ! Update the patch boundary condition via the data pointer + patch_api%vars(j)%data = this%api%vars(i)%data(c,:) + + end do + currentPatch => currentPatch%younger + end do + end do + +end subroutine UpdateFatesInterfaceVariables + + +! ====================================================================================== + end module FatesInterfaceMod From 276c7ba92e80424f1ddf99c577e8037d8ea237a5 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 9 Sep 2025 14:35:18 -0700 Subject: [PATCH 063/113] removed unused update subroutine --- main/FatesInterfaceTypesMod.F90 | 17 ----------------- 1 file changed, 17 deletions(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index d05382247c..81d812a2c6 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -1023,21 +1023,4 @@ end function GetRegistryIndex ! ====================================================================================== - subroutine UpdateInterfaceVariables(this) - - class(fates_interface_registry_base_type) :: this - - integer :: ivar ! Iterator - - ! Iterate over the registry and update all active variables - do ivar = 1, this%num_api_vars - if (this%vars(ivar)%active) then - call this%vars(ivar)%Update() - end if - end do - - end subroutine UpdateInterfaceVariables - - ! ====================================================================================== - end module FatesInterfaceTypesMod From d950a6d9cfda4fe891d66a14529c63ad0d23f8bd Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 9 Sep 2025 14:36:21 -0700 Subject: [PATCH 064/113] correct end function name --- main/FatesInterfaceTypesMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 81d812a2c6..da6d3e0886 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -1019,7 +1019,7 @@ character(len=*) function GetRegistryKey(this, index) result(key) key = this%vars(index)%key - end function GetRegistryIndex + end function GetRegistryKey ! ====================================================================================== From 332d1a436a0c4c4c9d77b79fb66b17f192b09f6b Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 9 Sep 2025 14:37:22 -0700 Subject: [PATCH 065/113] minor white space changes --- main/FatesInterfaceVarTypeMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index cedf770e5c..bacb2aafea 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -67,7 +67,6 @@ subroutine RegisterInterfaceVariable_1d(this, data, active) end subroutine RegisterInterfaceVariable_1d ! ==================================================================================== - subroutine RegisterInterfaceVariable_2d(this, data, active) @@ -82,4 +81,5 @@ subroutine RegisterInterfaceVariable_2d(this, data, active) end subroutine RegisterInterfaceVariable_2d ! ==================================================================================== + end module FatesInterfaceVariableTypeMod \ No newline at end of file From bb677cd8b9eace53934950551c26915320db86a4 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 9 Sep 2025 15:37:51 -0700 Subject: [PATCH 066/113] simplify the call to update the data via the api pointers by passing the registry --- main/FatesInterfaceMod.F90 | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 6105d4c549..1a42c89f59 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2700,28 +2700,23 @@ subroutine UpdateFatesInterfaceVariables(this) class(fates_interface_type), intent(inout) :: this - class(fates_registry_base_type), pointer :: patch_api + class(fates_interface_registry_base_type), pointer :: patch_api class(fates_patch_type), pointer :: currentPatch integer :: s ! site index integer :: i ! HLM registry index integer :: j ! FATES registry index + integer :: c = 1 ! column index, TODO: update do s = 1, this%nsites currentPatch => this%sites(s)%oldest_patch patch_api => currentPatch%api do while (associated(currentPatch)) - do i = 1, this%num_api_vars - - ! Don't assume the index in the registry is the same as in the interface - j = patch_api%GetRegistryIndex(patch_api%GetRegistryKey(i)) - ! TODO: we need meta data here to correctly associate the right slice of data - - ! Update the patch boundary condition via the data pointer - patch_api%vars(j)%data = this%api%vars(i)%data(c,:) + ! TODO: we need meta data here to correctly associate the right slice of data + ! Update the patch boundary condition via the data pointer + call patch_api%Update(this%api) - end do currentPatch => currentPatch%younger end do end do From e8338518f4cbd61cbdace786382d2d41f5f41c59 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 9 Sep 2025 15:38:39 -0700 Subject: [PATCH 067/113] fix getregistrykey output definition --- main/FatesInterfaceTypesMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index da6d3e0886..842d783dd0 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -1009,13 +1009,14 @@ end function GetRegistryIndex ! ====================================================================================== - character(len=*) function GetRegistryKey(this, index) result(key) + function GetRegistryKey(this, index) result(key) ! This procedure returns the index associated with the key provided class(fates_interface_registry_base_type) :: this integer, intent(in) :: index ! variable registry index + character(len=:), allocatable :: key key = this%vars(index)%key From b2bdbef0ed4170a1539eac43707ca08a8599840f Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 9 Sep 2025 15:40:13 -0700 Subject: [PATCH 068/113] Add the api update procedure. Now that the api type has been passed, make the GetRegistry functions private again --- main/FatesInterfaceTypesMod.F90 | 27 +++++++++++++++++++++++++-- 1 file changed, 25 insertions(+), 2 deletions(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 842d783dd0..09cf328c07 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -854,14 +854,16 @@ module FatesInterfaceTypesMod contains procedure :: InitializeInterfaceRegistry + procedure :: Update => UpdateInterfaceVariables + generic :: Register => RegisterInterfaceVariables_1d, RegisterInterfaceVariables_2d procedure, private :: DefineInterfaceRegistry procedure, private :: DefineInterfaceVariable - procedure, private :: GetRegistryIndex - procedure, private :: GetRegistryKey procedure, private :: RegisterInterfaceVariables_1d procedure, private :: RegisterInterfaceVariables_2d + procedure, private :: GetRegistryIndex + procedure, private :: GetRegistryKey end type fates_interface_registry_base_type @@ -987,6 +989,27 @@ end subroutine RegisterInterfaceVariables_2d ! ====================================================================================== + subroutine UpdateInterfaceVariables(this, api) + + class(fates_interface_registry_base_type) :: this + + class(fates_interface_registry_base_type), intent(in) pointer :: api + + integer :: i + integer :: j + + do i = 1, this%num_api_vars + + ! Don't assume the index in the registry is the same as in the interface + j = api%GetRegistryIndex(api%GetRegistryKey(i)) + + call this%vars(i)%Update(api%vars(j)) + end do + + end subroutine UpdateInterfaceVariables + + ! ====================================================================================== + integer function GetRegistryIndex(this, key) result(index) ! This procedure returns the index associated with the key provided From 7feb582350ea11439d2a8f80eb381346d4aef47c Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 9 Sep 2025 15:52:42 -0700 Subject: [PATCH 069/113] Start sketch of update variable This will need new type data to appropriately update the values --- main/FatesInterfaceVarTypeMod.F90 | 31 ++++++++++++++++++++++++++++++- 1 file changed, 30 insertions(+), 1 deletion(-) diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index bacb2aafea..f7936fa393 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -26,7 +26,9 @@ module FatesInterfaceVariableTypeMod contains procedure :: Initialize => InitializeInterfaceVariable - generic :: Register => RegisterInterfaceVariable_1d, RegisterInterfaceVariable_2d + procedure :: Update => UpdateInterfaceVariable + + generic :: Register => RegisterInterfaceVariable_1d, RegisterInterfaceVariable_2d procedure, private :: RegisterInterfaceVariable_1d procedure, private :: RegisterInterfaceVariable_2d @@ -80,6 +82,33 @@ subroutine RegisterInterfaceVariable_2d(this, data, active) end subroutine RegisterInterfaceVariable_2d + ! ==================================================================================== + + subroutine UpdateInterfaceVariable(this, var) + + class(fates_interface_variable_type) :: this + + class(fates_interface_variable_type), intent(in) :: var + + ! TODO: add column index to the interface variable type to allow + ! for appropriate slicing of input pointer array + ! e.g. + ! if (this%rank == 1)) then + ! data_this => this%data1d + ! else if (this%rank == 2) then + ! data_this => this%data2d + ! end if + ! if (var%rank == 1)) then + ! data_var => var%data1d + ! else if (this%rank == 2) then + ! data_var => var%data2d(this%col,:) + ! end if + ! data_this = data_var + ! This isn't exactly right, but you get the idea + + + end subroutine UpdateInterfaceVariable + ! ==================================================================================== end module FatesInterfaceVariableTypeMod \ No newline at end of file From 264412e906c36047c80c04cf21b9e9d215bdb8c7 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 10 Sep 2025 00:04:41 -0700 Subject: [PATCH 070/113] add subgrid heirarchy index variables in the registry type --- main/FatesInterfaceTypesMod.F90 | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 09cf328c07..a8dc2dc630 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -846,7 +846,11 @@ module FatesInterfaceTypesMod ! Base type to be extended for the API registry type, public :: fates_interface_registry_base_type - integer :: num_api_vars + integer :: num_api_vars ! number of variables in the registry + + integer :: patch_id ! HLM patch ID associated with this patch + integer :: column_id ! HLM column ID associated with this patch + integer :: landunit_id ! HLM landunit ID associated with this patch ! container array of interface variables type(fates_interface_variable_type), allocatable :: vars(:) @@ -896,6 +900,12 @@ subroutine InitializeInterfaceRegistry(this) logical :: initialize + ! unset registry integers + this%num_api_vars = unset_int + this%patch_id = unset_int + this%column_id = unset_int + this%landunit_id = unset_int + ! First count up the keys defined in the registry call this%DefineInterfaceRegistry(initialize=.false.) From 61fd96b26f5b571744a522b92923251c98a4532c Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 10 Sep 2025 00:05:20 -0700 Subject: [PATCH 071/113] update the current patch registry column index via the site column_map --- main/FatesInterfaceMod.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 1a42c89f59..95a5257435 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2713,6 +2713,11 @@ subroutine UpdateFatesInterfaceVariables(this) patch_api => currentPatch%api do while (associated(currentPatch)) + ! Transfer the column index to the patch registry + ! While this may be duplicative for older patches, we need + ! to ensure that the new patches are provided with the column index + patch_api%column_id = this%sites(s)%column_map(currentPatch%patchno) + ! TODO: we need meta data here to correctly associate the right slice of data ! Update the patch boundary condition via the data pointer call patch_api%Update(this%api) @@ -2723,9 +2728,6 @@ subroutine UpdateFatesInterfaceVariables(this) end subroutine UpdateFatesInterfaceVariables - ! ====================================================================================== - - end module FatesInterfaceMod From b7789ccd282ade7046c2cc2b0a9262ba95a0347f Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 10 Sep 2025 00:06:13 -0700 Subject: [PATCH 072/113] add variables to hold information about the ordering of the input data and associated dimensionality --- main/FatesInterfaceVarTypeMod.F90 | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index f7936fa393..8b85f469b6 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -14,6 +14,11 @@ module FatesInterfaceVariableTypeMod implicit none private + integer, parameter :: subgrid_gridcell = 0 + integer, parameter :: subgrid_landunit = 1 + integer, parameter :: subgrid_column = 2 + integer, parameter :: subgrid_patch = 3 + ! Interface variable registry type type, public :: fates_interface_variable_type @@ -23,6 +28,9 @@ module FatesInterfaceVariableTypeMod 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 :: rank ! rank of the variable (0, 1, 2, or 3) + integer :: rank_dimension ! index of the rank dimension for the given subgrid + integer :: subgrid ! subgrid level (0 = gridcell, 1 = landunit, 2 = column, 3 = patch) contains procedure :: Initialize => InitializeInterfaceVariable @@ -103,7 +111,7 @@ subroutine UpdateInterfaceVariable(this, var) ! else if (this%rank == 2) then ! data_var => var%data2d(this%col,:) ! end if - ! data_this = data_var + ! data_this = data_var() ! This isn't exactly right, but you get the idea From 6bc9f34cdc3eee7a88dd0cdf658879ddec89e5eb Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 10 Sep 2025 15:25:27 -0700 Subject: [PATCH 073/113] correct usage of unset integer constant --- main/FatesInterfaceTypesMod.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index a8dc2dc630..687d7198c6 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -2,6 +2,7 @@ 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 @@ -901,10 +902,10 @@ subroutine InitializeInterfaceRegistry(this) logical :: initialize ! unset registry integers - this%num_api_vars = unset_int - this%patch_id = unset_int - this%column_id = unset_int - this%landunit_id = unset_int + this%num_api_vars = fates_unset_int + this%patch_id = fates_unset_int + this%column_id = fates_unset_int + this%landunit_id = fates_unset_int ! First count up the keys defined in the registry call this%DefineInterfaceRegistry(initialize=.false.) @@ -1002,8 +1003,7 @@ end subroutine RegisterInterfaceVariables_2d subroutine UpdateInterfaceVariables(this, api) class(fates_interface_registry_base_type) :: this - - class(fates_interface_registry_base_type), intent(in) pointer :: api + class(fates_interface_registry_base_type), intent(in) :: api integer :: i integer :: j From cc260f3970237449dcb3c6a1b3618d9461d7b0ac Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 10 Sep 2025 15:25:45 -0700 Subject: [PATCH 074/113] make update interface a type-bound procedure --- main/FatesInterfaceMod.F90 | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 95a5257435..79a546a967 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -164,6 +164,10 @@ module FatesInterfaceMod ! This is the interface registry which associates variables with a common keyword type(fates_interface_registry_base_type) :: api + contains + + procedure, public :: UpdateInterfaceVariables + end type fates_interface_type character(len=*), parameter :: sourcefile = & @@ -184,7 +188,6 @@ module FatesInterfaceMod public :: set_bcs public :: UpdateFatesRMeansTStep public :: InitTimeAveragingGlobals - public :: UpdateInterfaceVariables private :: FatesReadParameters public :: DetermineGridCellNeighbors @@ -2696,7 +2699,7 @@ end subroutine FatesReadParameters ! ====================================================================================== -subroutine UpdateFatesInterfaceVariables(this) +subroutine UpdateInterfaceVariables(this) class(fates_interface_type), intent(inout) :: this @@ -2726,7 +2729,7 @@ subroutine UpdateFatesInterfaceVariables(this) end do end do -end subroutine UpdateFatesInterfaceVariables +end subroutine UpdateInterfaceVariables ! ====================================================================================== From 54c276fc88cd74d64bae5199ae72135e54e62a01 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 10 Sep 2025 15:55:45 -0700 Subject: [PATCH 075/113] removing the rank dimension integer as we are going to hold that the first dimension in the hlm arrays must be the subgrid index --- main/FatesInterfaceVarTypeMod.F90 | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index 8b85f469b6..e65acccf31 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -29,7 +29,6 @@ module FatesInterfaceVariableTypeMod class(*), pointer :: data3d(:,:,:) ! 3D polymorphic data pointer logical :: active ! true if the variable is used by the host land model integer :: rank ! rank of the variable (0, 1, 2, or 3) - integer :: rank_dimension ! index of the rank dimension for the given subgrid integer :: subgrid ! subgrid level (0 = gridcell, 1 = landunit, 2 = column, 3 = patch) contains @@ -97,6 +96,13 @@ subroutine UpdateInterfaceVariable(this, var) class(fates_interface_variable_type) :: this class(fates_interface_variable_type), intent(in) :: var + + ! 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 rank is the column index. + ! TODO: This should be held in an interface requirements document. + + ! TODO: add column index to the interface variable type to allow ! for appropriate slicing of input pointer array From df6397daaebb965bff70452e31436f7091dc23ff Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 10 Sep 2025 17:21:02 -0700 Subject: [PATCH 076/113] add subgrid parameter index values --- main/FatesInterfaceVarTypeMod.F90 | 33 ++++++++++++++++++------------- 1 file changed, 19 insertions(+), 14 deletions(-) diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index e65acccf31..e4bc8f259c 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -14,10 +14,11 @@ module FatesInterfaceVariableTypeMod implicit none private - integer, parameter :: subgrid_gridcell = 0 - integer, parameter :: subgrid_landunit = 1 - integer, parameter :: subgrid_column = 2 - integer, parameter :: subgrid_patch = 3 + integer, parameter, public :: subgrid_gridcell = 5 + integer, parameter, public :: subgrid_topounit = 4 + integer, parameter, public :: subgrid_landunit = 3 + integer, parameter, public :: subgrid_column = 2 + integer, parameter, public :: subgrid_patch = 1 ! Interface variable registry type type, public :: fates_interface_variable_type @@ -63,46 +64,50 @@ end subroutine InitializeInterfaceVariable ! ==================================================================================== - subroutine RegisterInterfaceVariable_1d(this, data, active) + subroutine RegisterInterfaceVariable_1d(this, data, active, subgrid_index) class(fates_interface_variable_type) :: 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 + end subroutine RegisterInterfaceVariable_1d ! ==================================================================================== - subroutine RegisterInterfaceVariable_2d(this, data, active) + subroutine RegisterInterfaceVariable_2d(this, data, active, subgrid_index) class(fates_interface_variable_type) :: this - class(*), target, intent(in) :: data(:,:) - logical, intent(in) :: active - + class(*), target, intent(in) :: data(:,:) + logical, intent(in) :: active + integer, intent(in) :: subgrid_index + this%data2d => data(:,:) this%active = active + this%subgrid = subgrid_index end subroutine RegisterInterfaceVariable_2d ! ==================================================================================== - subroutine UpdateInterfaceVariable(this, var) + subroutine UpdateInterfaceVariable(this, var, subgrid_indices) class(fates_interface_variable_type) :: this class(fates_interface_variable_type), intent(in) :: var - + integer, intent(in) :: subgrid_indices(:) + ! 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 rank is the column index. ! TODO: This should be held in an interface requirements document. - ! TODO: add column index to the interface variable type to allow ! for appropriate slicing of input pointer array From e990d4cf94f9846c3e7d8f44b050e61869b078dc Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 10 Sep 2025 17:21:52 -0700 Subject: [PATCH 077/113] update the api registration procedure to pass in the subgrid index for the given variable --- main/FatesInterfaceTypesMod.F90 | 51 +++++++++++++++++++++++---------- 1 file changed, 36 insertions(+), 15 deletions(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 687d7198c6..6ca9cf1316 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -284,6 +284,9 @@ 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 + ! ------------------------------------------------------------------------------------- ! These vectors are used for history output mapping ! CLM/ALM have limited support for multi-dimensional history output arrays. @@ -847,11 +850,9 @@ module FatesInterfaceTypesMod ! Base type to be extended for the API registry type, public :: fates_interface_registry_base_type - integer :: num_api_vars ! number of variables in the registry - - integer :: patch_id ! HLM patch ID associated with this patch - integer :: column_id ! HLM column ID associated with this patch - integer :: landunit_id ! HLM landunit ID associated with this patch + integer :: num_api_vars ! number of variables in the registry + integer :: subgrid_indices(hlm_subgrid_levels) ! HLM patch ID associated with this patch + ! 1 = patch, 2 = column, 3 = landunit, 4 = topounit, 5 = gridcell ! container array of interface variables type(fates_interface_variable_type), allocatable :: vars(:) @@ -966,35 +967,55 @@ end subroutine DefineInterfaceVariable ! ====================================================================================== - subroutine RegisterInterfaceVariables_1d(this, key, data) + 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) :: this + use FatesInterfaceVariableTypeMod, only : subgrid_patch + + class(fates_interface_registry_base_type) :: thisA - character(len=*), intent(in) :: key ! variable registry key - class(*), target, intent(in) :: data(:) ! data to be associated with key + character(len=*), intent(in) :: key ! variable registry key + class(*), target, intent(in) :: data(:) ! data to be associated with 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 + end if ! Get index from registry key and associate the given data pointer - call this%vars(this%GetRegistryIndex(key))%Register(data(:), active=.true.) + call this%vars(this%GetRegistryIndex(key))%Register(data(:), active=.true., subgrid_index_use) end subroutine RegisterInterfaceVariables_1d ! ====================================================================================== - subroutine RegisterInterfaceVariables_2d(this, key, data) + 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) :: this - character(len=*), intent(in) :: key ! variable registry key - class(*), target, intent(in) :: data(:,:) ! data to be associated with key + character(len=*), intent(in) :: key ! variable registry key + class(*), target, intent(in) :: data(:,:) ! data to be associated with 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 + end if ! Get index from registry key and associate the given data pointer - call this%vars(this%GetRegistryIndex(key))%Register(data(:,:), active=.true.) + call this%vars(this%GetRegistryIndex(key))%Register(data(:,:), active=.true., subgrid_index_use) end subroutine RegisterInterfaceVariables_2d @@ -1013,7 +1034,7 @@ subroutine UpdateInterfaceVariables(this, api) ! Don't assume the index in the registry is the same as in the interface j = api%GetRegistryIndex(api%GetRegistryKey(i)) - call this%vars(i)%Update(api%vars(j)) + call this%vars(i)%Update(api%vars(j), api%subgrid_indices) end do end subroutine UpdateInterfaceVariables From f08972a2d59279dc4756e3c0736c81e7c6569838 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 10 Sep 2025 17:22:45 -0700 Subject: [PATCH 078/113] implement the updated api registry assignment of the column index --- main/FatesInterfaceMod.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 79a546a967..e0bbe514a6 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2701,6 +2701,8 @@ end subroutine FatesReadParameters subroutine UpdateInterfaceVariables(this) + use FatesInterfaceVariableTypeMod, only : subgrid_column + class(fates_interface_type), intent(inout) :: this class(fates_interface_registry_base_type), pointer :: patch_api @@ -2719,7 +2721,7 @@ subroutine UpdateInterfaceVariables(this) ! Transfer the column index to the patch registry ! While this may be duplicative for older patches, we need ! to ensure that the new patches are provided with the column index - patch_api%column_id = this%sites(s)%column_map(currentPatch%patchno) + patch_api%subgrid_indices(subgrid_column) = this%sites(s)%column_map(currentPatch%patchno) ! TODO: we need meta data here to correctly associate the right slice of data ! Update the patch boundary condition via the data pointer From 76f9bd77199110345258d68f795e4ccc36a6e11e Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 10 Sep 2025 17:22:58 -0700 Subject: [PATCH 079/113] whitespace --- biogeochem/FatesPatchMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index ff42967099..ae31e8f5e8 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -1323,7 +1323,7 @@ end subroutine CheckVars subroutine RegisterFatesInterfaceVariables(this) class(fates_patch_type) :: this - + ! Initialize the HLM-FATES interface variable registry for the FATES-side call this%api%InitializeInterfaceRegistry() From 995841656841ebdcb7fcf50267d1ba7bbfffacd7 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 11 Sep 2025 11:28:17 -0700 Subject: [PATCH 080/113] adding comments and whitespace adjustments --- main/FatesInterfaceTypesMod.F90 | 21 ++++++++++++--------- main/FatesInterfaceVarTypeMod.F90 | 3 ++- 2 files changed, 14 insertions(+), 10 deletions(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 6ca9cf1316..034de5ff95 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -1000,6 +1000,8 @@ subroutine RegisterInterfaceVariables_2d(this, key, data, subgrid_index) ! This procedure is called by the to associate a data variable ! with a particular registry key + use FatesInterfaceVariableTypeMod, only : subgrid_patch + class(fates_interface_registry_base_type) :: this character(len=*), intent(in) :: key ! variable registry key @@ -1023,18 +1025,19 @@ end subroutine RegisterInterfaceVariables_2d subroutine UpdateInterfaceVariables(this, api) - class(fates_interface_registry_base_type) :: this - class(fates_interface_registry_base_type), intent(in) :: api + class(fates_interface_registry_base_type) :: this ! registry being updated + class(fates_interface_registry_base_type), intent(in) :: api ! registry update source integer :: i integer :: j do i = 1, this%num_api_vars - ! Don't assume the index in the registry is the same as in the interface - j = api%GetRegistryIndex(api%GetRegistryKey(i)) + ! Don't assume the index in the registry is the same as in the interface + j = api%GetRegistryIndex(api%GetRegistryKey(i)) - call this%vars(i)%Update(api%vars(j), api%subgrid_indices) + ! 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 @@ -1053,10 +1056,10 @@ integer function GetRegistryIndex(this, key) result(index) ! 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 + if (this%vars(ivar)%key == key) then + index = ivar + return + end if end do end function GetRegistryIndex diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index e4bc8f259c..9bf4e6867e 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -20,7 +20,7 @@ module FatesInterfaceVariableTypeMod integer, parameter, public :: subgrid_column = 2 integer, parameter, public :: subgrid_patch = 1 - ! Interface variable registry type + ! Interface registry variable type type, public :: fates_interface_variable_type character(len=48) :: key ! common registry key @@ -109,6 +109,7 @@ subroutine UpdateInterfaceVariable(this, var, subgrid_indices) ! TODO: This should be held in an interface requirements document. + ! TODO: add column index to the interface variable type to allow ! for appropriate slicing of input pointer array ! e.g. From 0d95ee2eb5f27000d8671d11fa9c96930b615669 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 11 Sep 2025 11:33:32 -0700 Subject: [PATCH 081/113] update the registry initialization to reflect the change to the subgrid index information --- main/FatesInterfaceTypesMod.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 034de5ff95..65b87fe851 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -904,9 +904,7 @@ subroutine InitializeInterfaceRegistry(this) ! unset registry integers this%num_api_vars = fates_unset_int - this%patch_id = fates_unset_int - this%column_id = fates_unset_int - this%landunit_id = fates_unset_int + this%subgrid_indices = fates_unset_int ! First count up the keys defined in the registry call this%DefineInterfaceRegistry(initialize=.false.) From 1d5878ff4ef359a23f353a2427c8bc466ea150d5 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 11 Sep 2025 11:56:30 -0700 Subject: [PATCH 082/113] add missing rank update --- main/FatesInterfaceVarTypeMod.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index 9bf4e6867e..fdde8a48bd 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -75,6 +75,7 @@ subroutine RegisterInterfaceVariable_1d(this, data, active, subgrid_index) this%data1d => data(:) this%active = active this%subgrid = subgrid_index + this%rank = rank(data) end subroutine RegisterInterfaceVariable_1d @@ -91,6 +92,7 @@ subroutine RegisterInterfaceVariable_2d(this, data, active, subgrid_index) this%data2d => data(:,:) this%active = active this%subgrid = subgrid_index + this%rank = rank(data) end subroutine RegisterInterfaceVariable_2d From cff1e3b5f22ae2723b0c890e91409ec111c6cced Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 11 Sep 2025 11:57:11 -0700 Subject: [PATCH 083/113] add case select logic and pointers to index into the source data pointer --- main/FatesInterfaceVarTypeMod.F90 | 60 ++++++++++++++++++++----------- 1 file changed, 39 insertions(+), 21 deletions(-) diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index fdde8a48bd..496aa12c29 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -100,34 +100,52 @@ end subroutine RegisterInterfaceVariable_2d subroutine UpdateInterfaceVariable(this, var, subgrid_indices) - class(fates_interface_variable_type) :: this + class(fates_interface_variable_type) :: 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() - class(fates_interface_variable_type), intent(in) :: var - integer, intent(in) :: subgrid_indices(:) + integer :: index ! index for the subgrid level of the input interface variable ! 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 rank is the column index. ! TODO: This should be held in an interface requirements document. - - - - ! TODO: add column index to the interface variable type to allow - ! for appropriate slicing of input pointer array - ! e.g. - ! if (this%rank == 1)) then - ! data_this => this%data1d - ! else if (this%rank == 2) then - ! data_this => this%data2d - ! end if - ! if (var%rank == 1)) then - ! data_var => var%data1d - ! else if (this%rank == 2) then - ! data_var => var%data2d(this%col,:) - ! end if - ! data_this = data_var() - ! This isn't exactly right, but you get the idea + ! Get the subgrid index for the updating variable + index = subgrid_indices(var%subgrid_index) + + ! 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%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 + call endrun(fates_log, 'FATES ERROR: Unsupported interface variable source rank in UpdateInterfaceVariable') + end select + + ! Update the data pointer of the target variable based on its rank + select case (this%rank) + case(0) + this%data0d = data_var0d + case(1) + this%data1d = data_var1d + case(2) + this%data2d = data_var2d + case default + call endrun(fates_log, 'FATES ERROR: Unsupported interface variable input rank in UpdateInterfaceVariable') + end select end subroutine UpdateInterfaceVariable From d89ae39b8c8368b71edaa7823543183995ee2457 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 11 Sep 2025 13:06:04 -0700 Subject: [PATCH 084/113] add type-safe selection constructs to the update interface variable procedure --- main/FatesInterfaceVarTypeMod.F90 | 87 ++++++++++++++++++++++++++++--- 1 file changed, 79 insertions(+), 8 deletions(-) diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index 496aa12c29..8cf29b202c 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -4,7 +4,9 @@ module FatesInterfaceVariableTypeMod ! 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 @@ -110,6 +112,7 @@ subroutine UpdateInterfaceVariable(this, var, subgrid_indices) 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. @@ -117,7 +120,7 @@ subroutine UpdateInterfaceVariable(this, var, subgrid_indices) ! TODO: This should be held in an interface requirements document. ! Get the subgrid index for the updating variable - index = subgrid_indices(var%subgrid_index) + index = subgrid_indices(var%subgrid) ! Update the data pointer based on the rank of the source variable while indexing ! into the appropriate subgrid level @@ -132,19 +135,87 @@ subroutine UpdateInterfaceVariable(this, var, subgrid_indices) case(3) data_var2d => var%data3d(index,:,:) case default - call endrun(fates_log, 'FATES ERROR: Unsupported interface variable source rank in UpdateInterfaceVariable') + write(fates_log(),*) 'FATES ERROR: Unsupported interface variable input rank in UpdateInterfaceVariable' + call endrun(msg=errMsg(__FILE__, __LINE__)) end select - ! Update the data pointer of the target variable based on its rank + ! 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%rank) case(0) - this%data0d = data_var0d + 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) - this%data1d = data_var1d + 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) - this%data2d = data_var2d + 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 - call endrun(fates_log, 'FATES ERROR: Unsupported interface variable input rank in UpdateInterfaceVariable') + write(fates_log(),*) 'FATES ERROR: Unsupported interface variable target rank in UpdateInterfaceVariable' + call endrun(msg=errMsg(__FILE__, __LINE__)) end select end subroutine UpdateInterfaceVariable From 5d629696179a589a9060d27262cc1644c2b269fa Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 11 Sep 2025 22:52:17 -0700 Subject: [PATCH 085/113] move subgrid heirarchy values into fates interface types mod --- main/FatesInterfaceMod.F90 | 1 - main/FatesInterfaceTypesMod.F90 | 14 +++++++++++--- 2 files changed, 11 insertions(+), 4 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index e0bbe514a6..8212f8a205 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2723,7 +2723,6 @@ subroutine UpdateInterfaceVariables(this) ! to ensure that the new patches are provided with the column index patch_api%subgrid_indices(subgrid_column) = this%sites(s)%column_map(currentPatch%patchno) - ! TODO: we need meta data here to correctly associate the right slice of data ! Update the patch boundary condition via the data pointer call patch_api%Update(this%api) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 65b87fe851..21ff916900 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -286,6 +286,14 @@ module FatesInterfaceTypesMod 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 = 5 + integer, parameter, public :: subgrid_topounit = 4 + integer, parameter, public :: subgrid_landunit = 3 + integer, parameter, public :: subgrid_column = 2 + integer, parameter, public :: subgrid_patch = 1 + ! ------------------------------------------------------------------------------------- ! These vectors are used for history output mapping @@ -972,7 +980,7 @@ subroutine RegisterInterfaceVariables_1d(this, key, data, subgrid_index) use FatesInterfaceVariableTypeMod, only : subgrid_patch - class(fates_interface_registry_base_type) :: thisA + class(fates_interface_registry_base_type) :: this character(len=*), intent(in) :: key ! variable registry key class(*), target, intent(in) :: data(:) ! data to be associated with key @@ -987,7 +995,7 @@ subroutine RegisterInterfaceVariables_1d(this, key, data, subgrid_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_use) + call this%vars(this%GetRegistryIndex(key))%Register(data(:), active=.true., subgrid_index=subgrid_index_use) end subroutine RegisterInterfaceVariables_1d @@ -1015,7 +1023,7 @@ subroutine RegisterInterfaceVariables_2d(this, key, data, subgrid_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_use) + call this%vars(this%GetRegistryIndex(key))%Register(data(:,:), active=.true., subgrid_index=subgrid_index_use) end subroutine RegisterInterfaceVariables_2d From 1ead8124bafd9450a2c1135d05a302f2d1505c9a Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 11 Sep 2025 23:11:34 -0700 Subject: [PATCH 086/113] remove superseded transfer bc procedures --- main/EDTypesMod.F90 | 198 -------------------------------------------- 1 file changed, 198 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 76914570ab..1499449eb6 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -841,202 +841,4 @@ function get_secondary_young_fraction(this) result(secondary_young_fraction) end function get_secondary_young_fraction - ! ====================================================================================== - - subroutine TransferBCIn_0D_int(this, tag, data) - - class(ed_site_type), intent(inout) :: this - character(len=*), intent(in) :: tag - integer, pointer, intent(in) :: data - - type(fates_patch_type), pointer :: currentPatch - - ! LOCAL - integer :: p ! patch index - - currentPatch => this%oldest_patch - - do while (associated(currentPatch)) - - p = this%patch_map(currentPatch%patchno) - - select case(trim(tag)) - - case('nlevdecomp') - currentPatch%bc_in%nlevdecomp = data - - ! NOTE: should the patch level bc subtypes actually be pointers to the - ! input values instead of copies of the pointer data? Or is not a good idea - ! since the HLM runs on a different time step than fates? - ! If these are not pointers then we really don't have a good way to avoid - ! memory duplicity. - - end select - - currentPatch => currentPatch%younger - - end do - - end subroutine TransferBCIn_0d_int - - ! ====================================================================================== - - ! ====================================================================================== - - subroutine TransferBCIn_1d(this, tag, data) - - class(ed_site_type), intent(inout) :: this - character(len=*), intent(in) :: tag - real(r8), pointer, intent(in) :: data(:) - - type(fates_patch_type), pointer :: currentPatch - - ! LOCAL - integer :: p ! patch index - - currentPatch => this%oldest_patch - - do while (associated(currentPatch)) - - p = this%patch_map(currentPatch%patchno) - - select case(trim(tag)) - - case('leaf_area_index') - currentPatch%bc_in%hlm_sp_tlai = data(p) - - ! NOTE: should the patch level bc subtypes actually be pointers to the - ! input values instead of copies of the pointer data? Or is not a good idea - ! since the HLM runs on a different time step than fates? - ! If these are not pointers then we really don't have a good way to avoid - ! memory duplicity. - - end select - - currentPatch => currentPatch%younger - - end do - - end subroutine TransferBCIn_1d - - ! ====================================================================================== - - subroutine TransferBCIn_2d(this, tag, data) - - class(ed_site_type), intent(inout) :: this - character(len=*), intent(in) :: tag - real(r8), pointer, intent(in) :: data(:,:) - - type(fates_patch_type), pointer :: currentPatch - - ! LOCAL - integer :: c ! HLM column index - - currentPatch => this%oldest_patch - - do while (associated(currentPatch)) - - c = this%column_map(currentPatch%patchno) - - select case(trim(tag)) - - case('decomp_frac_moisture') - currentPatch%bc_in%w_scalar_sisl = data(c,:) - case('decomp_frac_temperature') - currentPatch%bc_in%t_scalar_sisl = data(c,:) - - ! NOTE: should the patch level bc subtypes actually be pointers to the - ! input values instead of copies of the pointer data? Or is not a good idea - ! since the HLM runs on a different time step than fates? - ! If these are not pointers then we really don't have a good way to avoid - ! memory duplicity. - - end select - - currentPatch => currentPatch%younger - - end do - - end subroutine TransferBCIn_2d - -! ====================================================================================== - - subroutine TransferBCOut_1d(this, tag, data, dtime) - - class(ed_site_type), intent(inout) :: this - - character(len=*), intent(in) :: tag ! HLM-FATES common vocab string - real(r8), pointer, intent(inout) :: data(:) ! data pointer associated with tag - real(r8), intent(in) :: dtime ! HLM timestep size in seconds - - type(fates_patch_type), pointer :: currentPatch - - ! LOCAL - integer :: c ! HLM column index - - currentPatch => this%oldest_patch - - do while (associated(currentPatch)) - - c = this%column_map(currentPatch%patchno) - - select case(trim(tag)) - - case('litter_fall') - data(c) = data(c) + sum(currentPatch%bc_out%litt_flux_lab_c_si * currentPatch%bc_in%dz_decomp_sisl) & - + sum(currentPatch%bc_out%litt_flux_cel_c_si * currentPatch%bc_in%dz_decomp_sisl) & - + sum(currentPatch%bc_out%litt_flux_lig_c_si * currentPatch%bc_in%dz_decomp_sisl) - - end select - - currentPatch => currentPatch%younger - - end do - - end subroutine TransferBCOut_1d - -! ====================================================================================== - - subroutine TransferBCOut_2d(this, tag, data, dtime) - - class(ed_site_type), intent(inout) :: this - - character(len=*), intent(in) :: tag ! HLM-FATES common vocab string - real(r8), pointer, intent(inout) :: data(:,:) ! data pointer associated with tag - real(r8), intent(in) :: dtime ! HLM timestep size in seconds - - type(fates_patch_type), pointer :: currentPatch - - ! LOCAL - integer :: c ! HLM column index - - currentPatch => this%oldest_patch - - do while (associated(currentPatch)) - - c = this%column_map(currentPatch%patchno) - - select case(trim(tag)) - - ! For the decomposition carbon pools, the host land model uses - ! a 3D array, where the third dimension signifies the litter type. - ! The HLM sets up a pointer to a 2D slice of the variable so we - ! don't have to worry about that here. - ! We convert the bc_out from per second to per timestep - case('decomp_cpools_met') - data(c,:) = data(c,:) + currentPatch%bc_out%litt_flux_lab_c_si * dtime - case('decomp_cpools_cel') - data(c,:) = data(c,:) + currentPatch%bc_out%litt_flux_cel_c_si * dtime - case('decomp_cpools_lig') - data(c,:) = data(c,:) + currentPatch%bc_out%litt_flux_lig_c_si * dtime - - end select - - currentPatch => currentPatch%younger - - end do - - end subroutine TransferBCOut_2d - - end module EDTypesMod From 1746c0c31d884eea35c628966e37a7587f51d3bf Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 12 Sep 2025 10:22:09 -0700 Subject: [PATCH 087/113] add intent in to all registry subroutines --- biogeochem/FatesPatchMod.F90 | 2 +- main/FatesInterfaceTypesMod.F90 | 18 +++++++++--------- main/FatesInterfaceVarTypeMod.F90 | 18 +++++++++--------- 3 files changed, 19 insertions(+), 19 deletions(-) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index ae31e8f5e8..716a649223 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -1322,7 +1322,7 @@ end subroutine CheckVars subroutine RegisterFatesInterfaceVariables(this) - class(fates_patch_type) :: this + class(fates_patch_type), intent(inout) :: this ! Initialize the HLM-FATES interface variable registry for the FATES-side call this%api%InitializeInterfaceRegistry() diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 21ff916900..d7b2302fab 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -906,7 +906,7 @@ subroutine InitializeInterfaceRegistry(this) ! This initializes the interface registry - class(fates_interface_registry_base_type) :: this + class(fates_interface_registry_base_type), intent(inout) :: this logical :: initialize @@ -932,7 +932,7 @@ 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) :: this + class(fates_interface_registry_base_type), intent(inout) :: this logical, intent(in) :: initialize ! false = count up the keys in the registry @@ -955,7 +955,7 @@ end subroutine DefineInterfaceRegistry subroutine DefineInterfaceVariable(this, key, index, initialize) - class(fates_interface_registry_base_type) :: this + class(fates_interface_registry_base_type), intent(inout) :: this character(len=*), intent(in) :: key integer, intent(inout) :: index @@ -980,7 +980,7 @@ subroutine RegisterInterfaceVariables_1d(this, key, data, subgrid_index) use FatesInterfaceVariableTypeMod, only : subgrid_patch - class(fates_interface_registry_base_type) :: this + class(fates_interface_registry_base_type), intent(inout) :: this character(len=*), intent(in) :: key ! variable registry key class(*), target, intent(in) :: data(:) ! data to be associated with key @@ -1008,7 +1008,7 @@ subroutine RegisterInterfaceVariables_2d(this, key, data, subgrid_index) use FatesInterfaceVariableTypeMod, only : subgrid_patch - class(fates_interface_registry_base_type) :: this + class(fates_interface_registry_base_type), intent(inout) :: this character(len=*), intent(in) :: key ! variable registry key class(*), target, intent(in) :: data(:,:) ! data to be associated with key @@ -1031,8 +1031,8 @@ end subroutine RegisterInterfaceVariables_2d subroutine UpdateInterfaceVariables(this, api) - class(fates_interface_registry_base_type) :: this ! registry being updated - class(fates_interface_registry_base_type), intent(in) :: api ! registry update source + 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 @@ -1054,7 +1054,7 @@ integer function GetRegistryIndex(this, key) result(index) ! This procedure returns the index associated with the key provided - class(fates_interface_registry_base_type) :: this + class(fates_interface_registry_base_type), intent(in) :: this character(len=*), intent(in) :: key ! variable registry key to search @@ -1076,7 +1076,7 @@ function GetRegistryKey(this, index) result(key) ! This procedure returns the index associated with the key provided - class(fates_interface_registry_base_type) :: this + class(fates_interface_registry_base_type), intent(in) :: this integer, intent(in) :: index ! variable registry index character(len=:), allocatable :: key diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index 8cf29b202c..7c543aa6dc 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -51,7 +51,7 @@ module FatesInterfaceVariableTypeMod subroutine InitializeInterfaceVariable(this, key) - class(fates_interface_variable_type) :: this + class(fates_interface_variable_type), intent(inout) :: this character(len=*), intent(in) :: key @@ -67,8 +67,8 @@ end subroutine InitializeInterfaceVariable ! ==================================================================================== subroutine RegisterInterfaceVariable_1d(this, data, active, subgrid_index) - - class(fates_interface_variable_type) :: this + + class(fates_interface_variable_type), intent(inout) :: this class(*), target, intent(in) :: data(:) logical, intent(in) :: active @@ -84,8 +84,8 @@ end subroutine RegisterInterfaceVariable_1d ! ==================================================================================== subroutine RegisterInterfaceVariable_2d(this, data, active, subgrid_index) - - class(fates_interface_variable_type) :: this + + class(fates_interface_variable_type), intent(inout) :: this class(*), target, intent(in) :: data(:,:) logical, intent(in) :: active @@ -101,10 +101,10 @@ end subroutine RegisterInterfaceVariable_2d ! ==================================================================================== subroutine UpdateInterfaceVariable(this, var, subgrid_indices) - - class(fates_interface_variable_type) :: 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(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() From bf6999ff95b5d15ebe089b5e86f994ccb6816c49 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 12 Sep 2025 10:22:39 -0700 Subject: [PATCH 088/113] remove defunct transferbcin/out procedures in patch type --- main/EDTypesMod.F90 | 9 --------- 1 file changed, 9 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 1499449eb6..853fc85cd6 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -573,15 +573,6 @@ module EDTypesMod procedure, public :: get_current_landuse_statevector procedure, public :: get_secondary_young_fraction - procedure, private :: TransferBCIn_0d_int - procedure, private :: TransferBCIn_1d - procedure, private :: TransferBCIn_2d - generic, public :: TransferBCIn => TransferBCIn_0d_int, TransferBCIn_1d, TransferBCIn_2d - - procedure, private :: TransferBCOut_1d - procedure, private :: TransferBCOut_2d - generic, public :: TransferBCOut => TransferBCOut_1d, TransferBCOut_2d - end type ed_site_type ! Make public necessary subroutines and functions From 0792e906a5d60e24c570f75dd6f937457edf8715 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 12 Sep 2025 10:46:33 -0700 Subject: [PATCH 089/113] add data size to the var type --- main/FatesInterfaceVarTypeMod.F90 | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index 7c543aa6dc..b9a8b1fc42 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -12,6 +12,7 @@ module FatesInterfaceVariableTypeMod use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : fates_long_string_length + use FatesConstantsMod, only : fates_unset_int implicit none private @@ -31,8 +32,9 @@ module FatesInterfaceVariableTypeMod 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 :: rank ! rank of the variable (0, 1, 2, or 3) + integer :: data_rank ! rank of the variable (0, 1, 2, or 3) integer :: subgrid ! subgrid level (0 = gridcell, 1 = landunit, 2 = column, 3 = patch) + integer, allocatable :: data_size(:) ! size of the first dimension of the variable contains procedure :: Initialize => InitializeInterfaceVariable @@ -55,13 +57,17 @@ subroutine InitializeInterfaceVariable(this, key) character(len=*), intent(in) :: key + allocate(this%data_size(3)) + + 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%key = key this%active = .false. - + end subroutine InitializeInterfaceVariable ! ==================================================================================== @@ -77,7 +83,8 @@ subroutine RegisterInterfaceVariable_1d(this, data, active, subgrid_index) this%data1d => data(:) this%active = active this%subgrid = subgrid_index - this%rank = rank(data) + this%data_rank = rank(data) + this%data_size(1) = size(data, dim=1) end subroutine RegisterInterfaceVariable_1d @@ -94,8 +101,10 @@ subroutine RegisterInterfaceVariable_2d(this, data, active, subgrid_index) this%data2d => data(:,:) this%active = active this%subgrid = subgrid_index - this%rank = rank(data) - + 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 ! ==================================================================================== @@ -116,7 +125,7 @@ subroutine UpdateInterfaceVariable(this, var, subgrid_indices) ! 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 rank is the column index. + ! 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 @@ -125,7 +134,7 @@ subroutine UpdateInterfaceVariable(this, var, subgrid_indices) ! 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%rank) + select case (var%data_rank) case(0) data_var0d => var%data0d case(1) @@ -146,7 +155,7 @@ subroutine UpdateInterfaceVariable(this, var, subgrid_indices) ! 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%rank) + select case (this%data_rank) case(0) select type(dest => this%data0d) type is (real(r8)) From 6bbce25d396b9b0b262687624f9ad267146acd49 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 12 Sep 2025 11:08:26 -0700 Subject: [PATCH 090/113] add dimension error diagnostics to the var type --- main/FatesInterfaceVarTypeMod.F90 | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index b9a8b1fc42..bc9569601e 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -178,7 +178,17 @@ subroutine UpdateInterfaceVariable(this, var, subgrid_indices) 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 + if (this%data_size(1) /= size(data_var1d)) then + write(fates_log(),*) 'FATES ERROR: Mismatched interface variable sizes in UpdateInterfaceVariable' + write(fates_log(),*) ' Target, size: ', this%key, this%data_size(1) + write(fates_log(),*) ' Source, size: ', var%key, var%data_size(1) + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + select type(dest => this%data1d) type is (real(r8)) select type(source => data_var1d) @@ -201,6 +211,16 @@ subroutine UpdateInterfaceVariable(this, var, subgrid_indices) call endrun(msg=errMsg(__FILE__, __LINE__)) end select case(2) + + ! Check that the dimensions of the source and target match + if (this%data_size(1) /= size(data_var2d) .or. & + this%data_size(2) /= size(data_var2d, 2)) then + write(fates_log(),*) 'FATES ERROR: Mismatched interface variable sizes in UpdateInterfaceVariable' + 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) + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + select type(dest => this%data2d) type is (real(r8)) select type(source => data_var2d) From 1420ec38b70d60d2f1869d8f2c698b7a2f4f3187 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 12 Sep 2025 11:32:28 -0700 Subject: [PATCH 091/113] convert variable size comparison error checking to a subroutine --- main/FatesInterfaceVarTypeMod.F90 | 49 ++++++++++++++++++++++--------- 1 file changed, 35 insertions(+), 14 deletions(-) diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index bc9569601e..709cb845ce 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -41,9 +41,10 @@ module FatesInterfaceVariableTypeMod procedure :: Update => UpdateInterfaceVariable generic :: Register => RegisterInterfaceVariable_1d, RegisterInterfaceVariable_2d - procedure, private :: RegisterInterfaceVariable_1d procedure, private :: RegisterInterfaceVariable_2d + + procedure, private :: CompareRegistryVariableSizes end type fates_interface_variable_type @@ -182,12 +183,7 @@ subroutine UpdateInterfaceVariable(this, var, subgrid_indices) case(1) ! Check that the dimensions of the source and target match - if (this%data_size(1) /= size(data_var1d)) then - write(fates_log(),*) 'FATES ERROR: Mismatched interface variable sizes in UpdateInterfaceVariable' - write(fates_log(),*) ' Target, size: ', this%key, this%data_size(1) - write(fates_log(),*) ' Source, size: ', var%key, var%data_size(1) - call endrun(msg=errMsg(__FILE__, __LINE__)) - end if + call this%CompareRegistryVariableSizes(var) select type(dest => this%data1d) type is (real(r8)) @@ -213,13 +209,7 @@ subroutine UpdateInterfaceVariable(this, var, subgrid_indices) case(2) ! Check that the dimensions of the source and target match - if (this%data_size(1) /= size(data_var2d) .or. & - this%data_size(2) /= size(data_var2d, 2)) then - write(fates_log(),*) 'FATES ERROR: Mismatched interface variable sizes in UpdateInterfaceVariable' - 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) - call endrun(msg=errMsg(__FILE__, __LINE__)) - end if + call this%CompareRegistryVariableSizes(var) select type(dest => this%data2d) type is (real(r8)) @@ -249,6 +239,37 @@ subroutine UpdateInterfaceVariable(this, var, subgrid_indices) 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 From 9f098a5db39cfe1081024f2ef52c0c9971fa1fdb Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 12 Sep 2025 11:57:05 -0700 Subject: [PATCH 092/113] add scalar interface register subroutine --- main/FatesInterfaceTypesMod.F90 | 37 ++++++++++++++++++++++++++++--- main/FatesInterfaceVarTypeMod.F90 | 22 +++++++++++++++++- 2 files changed, 55 insertions(+), 4 deletions(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index d7b2302fab..ea42bcb2b3 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -870,12 +870,15 @@ module FatesInterfaceTypesMod procedure :: InitializeInterfaceRegistry procedure :: Update => UpdateInterfaceVariables - generic :: Register => RegisterInterfaceVariables_1d, RegisterInterfaceVariables_2d + 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 :: RegisterInterfaceVariables_1d - procedure, private :: RegisterInterfaceVariables_2d procedure, private :: GetRegistryIndex procedure, private :: GetRegistryKey @@ -973,6 +976,34 @@ end subroutine DefineInterfaceVariable ! ====================================================================================== + subroutine RegisterInterfaceVariables_0d(this, key, data, subgrid_index) + + ! This procedure is called by the to associate a data variable + ! with a particular registry key + + use FatesInterfaceVariableTypeMod, only : subgrid_patch + + class(fates_interface_registry_base_type), intent(inout) :: this + + character(len=*), intent(in) :: key ! variable registry key + class(*), target, intent(in) :: data ! data to be associated with 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 + 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 diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index 709cb845ce..ec5844aa7d 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -40,7 +40,10 @@ module FatesInterfaceVariableTypeMod procedure :: Initialize => InitializeInterfaceVariable procedure :: Update => UpdateInterfaceVariable - generic :: Register => RegisterInterfaceVariable_1d, RegisterInterfaceVariable_2d + generic :: Register => RegisterInterfaceVariable_0d, & + RegisterInterfaceVariable_1d, & + RegisterInterfaceVariable_2d + procedure, private :: RegisterInterfaceVariable_0d procedure, private :: RegisterInterfaceVariable_1d procedure, private :: RegisterInterfaceVariable_2d @@ -71,6 +74,23 @@ subroutine InitializeInterfaceVariable(this, key) 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) From 688305062fe8b41f06bf4cfe2f8f006d3a6d6ce7 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 12 Sep 2025 12:05:21 -0700 Subject: [PATCH 093/113] add nlevsoil to patch-level bcin --- biogeochem/FatesPatchMod.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index 716a649223..11a2651659 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -282,6 +282,7 @@ subroutine Init(this, num_swb, num_levsoil) allocate(this%sabs_dir(num_swb)) allocate(this%sabs_dif(num_swb)) allocate(this%fragmentation_scaler(num_levsoil)) + allocate(this%bc_in%w_scalar_sisl(num_levsoil)) allocate(this%bc_in%t_scalar_sisl(num_levsoil)) @@ -534,6 +535,7 @@ subroutine NanValues(this) 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 @@ -625,6 +627,7 @@ subroutine ZeroValues(this) 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 @@ -1328,6 +1331,7 @@ subroutine RegisterFatesInterfaceVariables(this) call this%api%InitializeInterfaceRegistry() ! Register the FATES boundary condition data variables + call this%api%Register('soil_level_number', this%bc_in%nlevsoil) call this%api%Register('decomp_frac_moisture', this%bc_in%w_scalar_sisl) call this%api%Register('decomp_frac_temperature', this%bc_in%t_scalar_sisl) From 203d584fe1311d7f0f47c7797e8f1d0644ccaf5d Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 12 Sep 2025 14:37:48 -0700 Subject: [PATCH 094/113] add interface key names as parameter variables --- biogeochem/FatesPatchMod.F90 | 10 +++++++--- main/FatesInterfaceTypesMod.F90 | 15 +++++++-------- 2 files changed, 14 insertions(+), 11 deletions(-) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index 11a2651659..757b37a461 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -1325,15 +1325,19 @@ end subroutine CheckVars subroutine RegisterFatesInterfaceVariables(this) + use FatesInterfaceTypesMod, only: hlm_fates_soil_level + use FatesInterfaceTypesMod, only: hlm_fates_decomp_frac_moisture + use FatesInterfaceTypesMod, only: hlm_fates_decomp_frac_temperature + class(fates_patch_type), intent(inout) :: this ! Initialize the HLM-FATES interface variable registry for the FATES-side call this%api%InitializeInterfaceRegistry() ! Register the FATES boundary condition data variables - call this%api%Register('soil_level_number', this%bc_in%nlevsoil) - call this%api%Register('decomp_frac_moisture', this%bc_in%w_scalar_sisl) - call this%api%Register('decomp_frac_temperature', this%bc_in%t_scalar_sisl) + call this%api%Register(hlm_fates_soil_level, this%bc_in%nlevsoil) + 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 RegisterFatesInterfaceVariables diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index ea42bcb2b3..c049cc389e 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -288,12 +288,10 @@ module FatesInterfaceTypesMod ! Including the gridcell level, ELM = 5, CLM = 4 ! Subgrid levels for HLM-FATES interface variable - integer, parameter, public :: subgrid_gridcell = 5 - integer, parameter, public :: subgrid_topounit = 4 - integer, parameter, public :: subgrid_landunit = 3 - integer, parameter, public :: subgrid_column = 2 - integer, parameter, public :: subgrid_patch = 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' ! ------------------------------------------------------------------------------------- ! These vectors are used for history output mapping @@ -945,8 +943,9 @@ subroutine DefineInterfaceRegistry(this, initialize) ivar = 0 ! Define the interface registry names and indices - call this%DefineInterfaceVariable(key='decomp_frac_moisture', index=ivar, initialize=initialize) - call this%DefineInterfaceVariable(key='decomp_frac_temperature', index=ivar, initialize=initialize) + call this%DefineInterfaceVariable(key=hlm_fates_soil_level, index=ivar, initialize=initialize) + call this%DefineInterfaceVariable(key=hlm_fates_decomp_frac_moisture, index=ivar, initialize=initialize) + call this%DefineInterfaceVariable(key=hlm_fates_decomp_frac_temperature, index=ivar, initialize=initialize) ! Set the registry size based on the final update of ivar this%num_api_vars = ivar From 6cbc78356e560b2ea0f7794fcb0f13ce95d55881 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 12 Sep 2025 14:38:53 -0700 Subject: [PATCH 095/113] move subgrid index types into fatesinterfacetypesmod --- main/FatesInterfaceMod.F90 | 4 ++-- main/FatesInterfaceTypesMod.F90 | 33 +++++++++++++++++-------------- main/FatesInterfaceVarTypeMod.F90 | 16 ++++++++------- 3 files changed, 29 insertions(+), 24 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 8212f8a205..4dacd64e87 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2701,7 +2701,7 @@ end subroutine FatesReadParameters subroutine UpdateInterfaceVariables(this) - use FatesInterfaceVariableTypeMod, only : subgrid_column + use FatesInterfaceTypesMod, only : subgrid_column_index class(fates_interface_type), intent(inout) :: this @@ -2721,7 +2721,7 @@ subroutine UpdateInterfaceVariables(this) ! Transfer the column index to the patch registry ! While this may be duplicative for older patches, we need ! to ensure that the new patches are provided with the column index - patch_api%subgrid_indices(subgrid_column) = this%sites(s)%column_map(currentPatch%patchno) + patch_api%subgrid_indices(subgrid_column_index) = this%sites(s)%column_map(currentPatch%patchno) ! Update the patch boundary condition via the data pointer call patch_api%Update(this%api) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index c049cc389e..1801c32ea6 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -288,6 +288,12 @@ module FatesInterfaceTypesMod ! 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' @@ -856,12 +862,14 @@ module FatesInterfaceTypesMod ! 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 integer :: num_api_vars ! number of variables in the registry integer :: subgrid_indices(hlm_subgrid_levels) ! HLM patch ID associated with this patch ! 1 = patch, 2 = column, 3 = landunit, 4 = topounit, 5 = gridcell - ! container array of interface variables - type(fates_interface_variable_type), allocatable :: vars(:) contains @@ -980,12 +988,10 @@ subroutine RegisterInterfaceVariables_0d(this, key, data, subgrid_index) ! This procedure is called by the to associate a data variable ! with a particular registry key - use FatesInterfaceVariableTypeMod, only : subgrid_patch - class(fates_interface_registry_base_type), intent(inout) :: this - character(len=*), intent(in) :: key ! variable registry key 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 @@ -993,7 +999,7 @@ subroutine RegisterInterfaceVariables_0d(this, key, data, subgrid_index) if (present(subgrid_index)) then subgrid_index_use = subgrid_index else - subgrid_index_use = subgrid_patch + subgrid_index_use = subgrid_patch_index end if ! Get index from registry key and associate the given data pointer @@ -1008,12 +1014,10 @@ subroutine RegisterInterfaceVariables_1d(this, key, data, subgrid_index) ! This procedure is called by the to associate a data variable ! with a particular registry key - use FatesInterfaceVariableTypeMod, only : subgrid_patch - class(fates_interface_registry_base_type), intent(inout) :: this - character(len=*), intent(in) :: key ! variable registry key 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 @@ -1021,7 +1025,7 @@ subroutine RegisterInterfaceVariables_1d(this, key, data, subgrid_index) if (present(subgrid_index)) then subgrid_index_use = subgrid_index else - subgrid_index_use = subgrid_patch + subgrid_index_use = subgrid_patch_index end if ! Get index from registry key and associate the given data pointer @@ -1036,12 +1040,10 @@ subroutine RegisterInterfaceVariables_2d(this, key, data, subgrid_index) ! This procedure is called by the to associate a data variable ! with a particular registry key - use FatesInterfaceVariableTypeMod, only : subgrid_patch - class(fates_interface_registry_base_type), intent(inout) :: this - character(len=*), intent(in) :: key ! variable registry key 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 @@ -1049,7 +1051,7 @@ subroutine RegisterInterfaceVariables_2d(this, key, data, subgrid_index) if (present(subgrid_index)) then subgrid_index_use = subgrid_index else - subgrid_index_use = subgrid_patch + subgrid_index_use = subgrid_patch_index end if ! Get index from registry key and associate the given data pointer @@ -1067,9 +1069,10 @@ subroutine UpdateInterfaceVariables(this, api) integer :: i integer :: j + ! Iterate over all registered variables do i = 1, this%num_api_vars - ! Don't assume the index in the registry is the same as in the interface + ! 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 diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index ec5844aa7d..dc49697e93 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -17,12 +17,6 @@ module FatesInterfaceVariableTypeMod implicit none private - integer, parameter, public :: subgrid_gridcell = 5 - integer, parameter, public :: subgrid_topounit = 4 - integer, parameter, public :: subgrid_landunit = 3 - integer, parameter, public :: subgrid_column = 2 - integer, parameter, public :: subgrid_patch = 1 - ! Interface registry variable type type, public :: fates_interface_variable_type @@ -32,8 +26,8 @@ module FatesInterfaceVariableTypeMod 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 :: data_rank ! rank of the variable (0, 1, 2, or 3) 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, allocatable :: data_size(:) ! size of the first dimension of the variable contains @@ -151,6 +145,14 @@ subroutine UpdateInterfaceVariable(this, var, subgrid_indices) ! 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 From 68ff7a86aa726565c23b3b91ebaef932835916b5 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 12 Sep 2025 15:50:37 -0700 Subject: [PATCH 096/113] move patch_api pointer update inside the do while --- main/FatesInterfaceMod.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 4dacd64e87..d08805e4df 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2715,10 +2715,11 @@ subroutine UpdateInterfaceVariables(this) do s = 1, this%nsites currentPatch => this%sites(s)%oldest_patch - patch_api => currentPatch%api do while (associated(currentPatch)) - ! Transfer the column index to the patch registry + 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 patch_api%subgrid_indices(subgrid_column_index) = this%sites(s)%column_map(currentPatch%patchno) From 28f629eabb95b21086ec56356fa3dc5d42dc83c0 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 12 Sep 2025 15:51:27 -0700 Subject: [PATCH 097/113] todo comment updates --- main/FatesInterfaceMod.F90 | 6 ++++-- main/FatesInterfaceTypesMod.F90 | 1 + 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index d08805e4df..5d0f035f85 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2724,9 +2724,11 @@ subroutine UpdateInterfaceVariables(this) ! to ensure that the new patches are provided with the column index patch_api%subgrid_indices(subgrid_column_index) = this%sites(s)%column_map(currentPatch%patchno) - ! Update the patch boundary condition via the data pointer + ! 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 diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 1801c32ea6..a6a45db7ed 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -866,6 +866,7 @@ module FatesInterfaceTypesMod 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 :: subgrid_indices(hlm_subgrid_levels) ! HLM patch ID associated with this patch ! 1 = patch, 2 = column, 3 = landunit, 4 = topounit, 5 = gridcell From 274c6fe90a5029fd09208a6d2b6fea4d2b277507 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 12 Sep 2025 15:51:42 -0700 Subject: [PATCH 098/113] removed unused indexers --- main/FatesInterfaceMod.F90 | 3 --- 1 file changed, 3 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 5d0f035f85..c67ea54894 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2709,9 +2709,6 @@ subroutine UpdateInterfaceVariables(this) class(fates_patch_type), pointer :: currentPatch integer :: s ! site index - integer :: i ! HLM registry index - integer :: j ! FATES registry index - integer :: c = 1 ! column index, TODO: update do s = 1, this%nsites currentPatch => this%sites(s)%oldest_patch From 65d967b8eafc9508becb075c882ba60cef406bd1 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 12 Sep 2025 15:53:28 -0700 Subject: [PATCH 099/113] Correct which api has the subgrid indice update. Technically we don't really need a subgrid_indices array for the patch-side currently. --- main/FatesInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index c67ea54894..a2b57576c2 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -2719,7 +2719,7 @@ subroutine UpdateInterfaceVariables(this) ! 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 - patch_api%subgrid_indices(subgrid_column_index) = this%sites(s)%column_map(currentPatch%patchno) + 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) From 64128baf169b617da11fd9b88c98f9e889d4f711 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 12 Sep 2025 16:27:20 -0700 Subject: [PATCH 100/113] adding comments for next steps --- biogeochem/FatesPatchMod.F90 | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index 757b37a461..83d3b39fcc 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -283,6 +283,17 @@ subroutine Init(this, num_swb, num_levsoil) allocate(this%sabs_dif(num_swb)) allocate(this%fragmentation_scaler(num_levsoil)) + ! Allocate API registry + call this%RegisterFatesInterfaceVariables() + + ! TODO: Create subroutine to update a subset of interface variables here + ! Problem: How do we get the HLM interface registry pointer? + ! Possible solution: move the boundary condition initialization into a different + ! procedure? Also have a separate registry for the scalars that are used for + ! allocations? + ! call this%InitializeInterfaceVariables() + + ! Allocate BC arrays. This must be done after the API registry is updated. allocate(this%bc_in%w_scalar_sisl(num_levsoil)) allocate(this%bc_in%t_scalar_sisl(num_levsoil)) @@ -290,9 +301,6 @@ subroutine Init(this, num_swb, num_levsoil) allocate(this%bc_out%litt_flux_lig_c_si(this%bc_in%nlevdecomp)) allocate(this%bc_out%litt_flux_lab_c_si(this%bc_in%nlevdecomp)) - ! Allocate API registry - call this%RegisterFatesInterfaceVariables() - ! initialize all values to nan call this%NanValues() From c4956f26b08e5b9380a70a022c15568ba7f30a06 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 17 Sep 2025 10:37:02 -0700 Subject: [PATCH 101/113] add update frequency to the registry variable type and and counters to the api registry type This will help next development steps in which the update of certain variables will be conducted prior to others --- main/FatesInterfaceTypesMod.F90 | 86 ++++++++++++++++++++++++++----- main/FatesInterfaceVarTypeMod.F90 | 12 +++-- 2 files changed, 82 insertions(+), 16 deletions(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index a6a45db7ed..edda2104c3 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -298,7 +298,13 @@ module FatesInterfaceTypesMod 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. @@ -868,6 +874,9 @@ module FatesInterfaceTypesMod ! 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 @@ -920,17 +929,23 @@ subroutine InitializeInterfaceRegistry(this) logical :: initialize - ! unset registry integers - this%num_api_vars = fates_unset_int + ! 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 + ! 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 set up the registry keys + ! Now initialize the registry keys call this%DefineInterfaceRegistry(initialize=.true.) end subroutine InitializeInterfaceRegistry @@ -964,20 +979,65 @@ end subroutine DefineInterfaceRegistry ! ====================================================================================== - subroutine DefineInterfaceVariable(this, key, index, initialize) + subroutine DefineInterfaceVariable(this, key, initialize, index, update_frequency) class(fates_interface_registry_base_type), intent(inout) :: this - character(len=*), intent(in) :: key - integer, intent(inout) :: index - logical, intent(in) :: initialize + character(len=*), intent(in) :: key + logical, intent(in) :: initialize + integer, intent(inout) :: index + integer, intent(in), optional :: update_frequency - ! Increment the index to return count - index = index + 1 + ! Local variables + integer :: index_type + integer :: update_frequency_local + + ! Increment the index + index = index + 1 - ! If we are initializing the + ! If not initializing, increment the registry count variables, otherwise initialize the variable at the correct index if (initialize) then - call this%vars(index)%Initialize(key) + + ! 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 diff --git a/main/FatesInterfaceVarTypeMod.F90 b/main/FatesInterfaceVarTypeMod.F90 index dc49697e93..9c21f21b69 100644 --- a/main/FatesInterfaceVarTypeMod.F90 +++ b/main/FatesInterfaceVarTypeMod.F90 @@ -28,6 +28,7 @@ module FatesInterfaceVariableTypeMod 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 @@ -49,23 +50,28 @@ module FatesInterfaceVariableTypeMod ! ==================================================================================== - subroutine InitializeInterfaceVariable(this, key) + 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%key = key this%active = .false. + ! Initialize registry variable components that are updated at initialization + this%key = key + this%update_frequency = update_frequency + end subroutine InitializeInterfaceVariable ! ==================================================================================== From f33b34bb6a6daca5ea279aeac3e5050dd2891e73 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 17 Sep 2025 10:38:26 -0700 Subject: [PATCH 102/113] add filters to the registry api type to provide shorter loops during update calls --- main/FatesInterfaceTypesMod.F90 | 50 +++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index edda2104c3..6b89e4d8c0 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -879,6 +879,11 @@ module FatesInterfaceTypesMod 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 @@ -895,6 +900,7 @@ module FatesInterfaceTypesMod procedure, private :: DefineInterfaceRegistry procedure, private :: DefineInterfaceVariable + procedure, private :: SetFilterMapArrays procedure, private :: GetRegistryIndex procedure, private :: GetRegistryKey @@ -947,6 +953,9 @@ subroutine InitializeInterfaceRegistry(this) ! Now initialize the registry keys call this%DefineInterfaceRegistry(initialize=.true.) + + ! Set filter map arrays + call this%SetFilterMapArrays() end subroutine InitializeInterfaceRegistry @@ -1042,6 +1051,47 @@ subroutine DefineInterfaceVariable(this, key, initialize, index, update_frequenc 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) From 849b23d92c0bcdb3b7b60476eaafec59e326228e Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 17 Sep 2025 10:39:21 -0700 Subject: [PATCH 103/113] update the definteinterface call to pass initialization update frequency for the soil level --- main/FatesInterfaceTypesMod.F90 | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 6b89e4d8c0..e143931cef 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -976,13 +976,14 @@ subroutine DefineInterfaceRegistry(this, initialize) ivar = 0 ! Define the interface registry names and indices - call this%DefineInterfaceVariable(key=hlm_fates_soil_level, index=ivar, initialize=initialize) - call this%DefineInterfaceVariable(key=hlm_fates_decomp_frac_moisture, index=ivar, initialize=initialize) - call this%DefineInterfaceVariable(key=hlm_fates_decomp_frac_temperature, index=ivar, initialize=initialize) - - ! Set the registry size based on the final update of ivar - this%num_api_vars = ivar - + ! Variables that only need to be updated during initialization, such as dimensions + call this%DefineInterfaceVariable(key=hlm_fates_soil_level, initialize=initialize, index = ivar, & + update_frequency=registry_update_init) + + + ! Variables that need to be updated daily + call this%DefineInterfaceVariable(key=hlm_fates_decomp_frac_moisture, initialize=initialize, index = ivar) + call this%DefineInterfaceVariable(key=hlm_fates_decomp_frac_temperature, initialize=initialize, index = ivar) end subroutine DefineInterfaceRegistry From 8d191e619a7b312d9ba1db87185ec6cb1b7e1c72 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 17 Sep 2025 10:39:56 -0700 Subject: [PATCH 104/113] minor formatting changes --- main/FatesInterfaceTypesMod.F90 | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index e143931cef..6bb45f0cec 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -891,9 +891,9 @@ module FatesInterfaceTypesMod procedure :: InitializeInterfaceRegistry procedure :: Update => UpdateInterfaceVariables - generic :: Register => RegisterInterfaceVariables_0d, & - RegisterInterfaceVariables_1d, & - RegisterInterfaceVariables_2d + generic :: Register => RegisterInterfaceVariables_0d, & + RegisterInterfaceVariables_1d, & + RegisterInterfaceVariables_2d procedure, private :: RegisterInterfaceVariables_0d procedure, private :: RegisterInterfaceVariables_1d procedure, private :: RegisterInterfaceVariables_2d @@ -970,10 +970,7 @@ subroutine DefineInterfaceRegistry(this, initialize) logical, intent(in) :: initialize ! false = count up the keys in the registry - integer :: ivar ! indices - - ! Set ivar to zero. This will be incremented via each call to SetInterfaceVariable - ivar = 0 + integer :: ivar = 0 ! Index to be incremented for each call to DefineInterfaceVariable() ! Define the interface registry names and indices ! Variables that only need to be updated during initialization, such as dimensions @@ -1131,7 +1128,7 @@ subroutine RegisterInterfaceVariables_1d(this, key, data, subgrid_index) 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 @@ -1139,7 +1136,7 @@ subroutine RegisterInterfaceVariables_1d(this, key, data, 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) From d7ca3f8f103ae0d7945b0e751759ef28529419a1 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 17 Sep 2025 10:47:43 -0700 Subject: [PATCH 105/113] initialize local variable to avoid implicit save --- main/FatesInterfaceTypesMod.F90 | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 6bb45f0cec..e4f7ae6647 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -970,17 +970,20 @@ subroutine DefineInterfaceRegistry(this, initialize) logical, intent(in) :: initialize ! false = count up the keys in the registry - integer :: ivar = 0 ! Index to be incremented for each call to DefineInterfaceVariable() + 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 = ivar, & + 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 = ivar) - call this%DefineInterfaceVariable(key=hlm_fates_decomp_frac_temperature, initialize=initialize, index = ivar) + 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 From b49b055a9fcbd841ff1bdf91dd3923fc2b43fcf1 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 17 Sep 2025 11:29:52 -0700 Subject: [PATCH 106/113] add registry procedure to update on the variables during initialization --- main/FatesInterfaceTypesMod.F90 | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index e4f7ae6647..e7b235ef1a 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -889,6 +889,7 @@ module FatesInterfaceTypesMod contains procedure :: InitializeInterfaceRegistry + procedure :: InitializeInterfaceVariables procedure :: Update => UpdateInterfaceVariables generic :: Register => RegisterInterfaceVariables_0d, & @@ -1171,6 +1172,33 @@ subroutine RegisterInterfaceVariables_2d(this, key, data, subgrid_index) 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) From cb192a8d8b4572d6a4e8a7da7aac584cb389883a Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 18 Sep 2025 16:46:23 -0700 Subject: [PATCH 107/113] minor move of use statment --- main/EDTypesMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 853fc85cd6..0d8896a9a2 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,7 +30,6 @@ 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 FatesCohortMod, only : fates_cohort_type use FatesPatchMod, only : fates_patch_type From 7baefc58cfce50fc9fa710984ffa8d9e7a1b9375 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 18 Sep 2025 16:47:03 -0700 Subject: [PATCH 108/113] add api registry pointer in the site type to point back to the interface api registry --- main/EDTypesMod.F90 | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 0d8896a9a2..a37a169fc4 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -31,6 +31,7 @@ module EDTypesMod use FatesInterfaceTypesMod,only : bc_in_type use FatesInterfaceTypesMod,only : bc_out_type 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,7 @@ 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(:) From 2e6fdcfaf594d2e36f7219592ecd257bde490c2d Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 18 Sep 2025 16:47:45 -0700 Subject: [PATCH 109/113] make the fates interface registry a pointer so that we can point the site api pointer at it --- main/FatesInterfaceMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index a2b57576c2..6c3ad56c90 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -162,7 +162,8 @@ module FatesInterfaceMod type(bc_pconst_type) :: bc_pconst ! This is the interface registry which associates variables with a common keyword - type(fates_interface_registry_base_type) :: api + ! FATES sites have a pointer to this, hence the "target" attribute + type(fates_interface_registry_base_type), pointer :: api contains From 44a5f8b86dffba5de188ab3067360355adef8b13 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 18 Sep 2025 16:49:53 -0700 Subject: [PATCH 110/113] Rename the patch level type bound registry initialization subroutine --- biogeochem/FatesPatchMod.F90 | 5 +++-- main/FatesInterfaceTypesMod.F90 | 2 +- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index 83d3b39fcc..a75f60c27a 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -253,7 +253,7 @@ module FatesPatchMod procedure :: Dump procedure :: CheckVars - procedure, private :: RegisterFatesInterfaceVariables + procedure, private :: InitializeInterfaceRegistry end type fates_patch_type @@ -1331,7 +1331,7 @@ end subroutine CheckVars !=========================================================================== - subroutine RegisterFatesInterfaceVariables(this) + subroutine InitializeInterfaceRegistry(this) use FatesInterfaceTypesMod, only: hlm_fates_soil_level use FatesInterfaceTypesMod, only: hlm_fates_decomp_frac_moisture @@ -1344,6 +1344,7 @@ subroutine RegisterFatesInterfaceVariables(this) ! Register the FATES boundary condition data variables call this%api%Register(hlm_fates_soil_level, this%bc_in%nlevsoil) + end subroutine InitializeInterfaceRegistry 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) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index e7b235ef1a..64c555799c 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -1181,7 +1181,7 @@ subroutine InitializeInterfaceVariables(this, api) 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 From 8732a906b041858abbea6bf04cad1cb4ee238f1d Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 18 Sep 2025 16:51:18 -0700 Subject: [PATCH 111/113] Add patch level type bound procedure to initialize the interface variables and allocate patch bcs --- biogeochem/FatesPatchMod.F90 | 32 ++++++++++++++++++++++++++------ 1 file changed, 26 insertions(+), 6 deletions(-) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index a75f60c27a..9583f51c32 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -254,6 +254,7 @@ module FatesPatchMod procedure :: CheckVars procedure, private :: InitializeInterfaceRegistry + procedure, private :: InitializeInterfaceVariables end type fates_patch_type @@ -1334,22 +1335,41 @@ end subroutine CheckVars subroutine InitializeInterfaceRegistry(this) use FatesInterfaceTypesMod, only: hlm_fates_soil_level - use FatesInterfaceTypesMod, only: hlm_fates_decomp_frac_moisture - use FatesInterfaceTypesMod, only: hlm_fates_decomp_frac_temperature class(fates_patch_type), intent(inout) :: this - ! Initialize the HLM-FATES interface variable registry for the FATES-side + ! Initialize the patch-level interface variable registry for the FATES-side call this%api%InitializeInterfaceRegistry() - ! Register the FATES boundary condition data variables + ! 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 subroutine RegisterFatesInterfaceVariables - ! ====================================================================================== end module FatesPatchMod From 15f9f8db75d92820e69fdb1c061cd0785a2beec4 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 18 Sep 2025 16:52:29 -0700 Subject: [PATCH 112/113] update the create and init patch subroutines to take in the api pointer from the site This could also site be pointers at the patch level, instead of the site level. --- biogeochem/FatesPatchMod.F90 | 36 ++++++++++++++---------------------- 1 file changed, 14 insertions(+), 22 deletions(-) diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index 9583f51c32..0e2e8a15ab 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -262,7 +262,7 @@ module FatesPatchMod !=========================================================================== - 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 @@ -272,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)) @@ -284,24 +285,13 @@ subroutine Init(this, num_swb, num_levsoil) allocate(this%sabs_dif(num_swb)) allocate(this%fragmentation_scaler(num_levsoil)) - ! Allocate API registry - call this%RegisterFatesInterfaceVariables() - - ! TODO: Create subroutine to update a subset of interface variables here - ! Problem: How do we get the HLM interface registry pointer? - ! Possible solution: move the boundary condition initialization into a different - ! procedure? Also have a separate registry for the scalars that are used for - ! allocations? - ! call this%InitializeInterfaceVariables() - - ! Allocate BC arrays. This must be done after the API registry is updated. - allocate(this%bc_in%w_scalar_sisl(num_levsoil)) - allocate(this%bc_in%t_scalar_sisl(num_levsoil)) - - allocate(this%bc_out%litt_flux_cel_c_si(this%bc_in%nlevdecomp)) - allocate(this%bc_out%litt_flux_lig_c_si(this%bc_in%nlevdecomp)) - allocate(this%bc_out%litt_flux_lab_c_si(this%bc_in%nlevdecomp)) + ! 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() @@ -730,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 @@ -747,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) From 01e37e20debb810d2f1495f33c381b2b3e416f09 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 18 Sep 2025 16:53:45 -0700 Subject: [PATCH 113/113] Update all patch create calls with new site api pointer argument --- biogeochem/EDPatchDynamicsMod.F90 | 6 +++--- main/EDInitMod.F90 | 4 ++-- main/FatesInventoryInitMod.F90 | 2 +- main/FatesRestartInterfaceMod.F90 | 2 +- 4 files changed, 7 insertions(+), 7 deletions(-) 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/main/EDInitMod.F90 b/main/EDInitMod.F90 index b12044bb8e..83027b65d7 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -783,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 @@ -862,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/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 9d9d83f34f..6f99b9c07e 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -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