From 86d8f3eba1fc53bf8eef4b41f6b34cc2bb88c4c7 Mon Sep 17 00:00:00 2001 From: mvdebolskiy Date: Thu, 2 Jul 2026 19:25:54 +0200 Subject: [PATCH 1/2] temp fixes for patches --- biogeochem/EDCohortDynamicsMod.F90 | 13 ----------- biogeochem/EDPatchDynamicsMod.F90 | 36 +++++++++++++++++++++++++++++- biogeophys/EDBtranMod.F90 | 7 ++++-- 3 files changed, 40 insertions(+), 16 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index f8436b4d4f..3aa36f020c 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -355,19 +355,6 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ endif endif - - - ! The rest of these are biological starvation checks, only allowed if we - ! are not dealing with a recruit (level 2) - if (currentcohort%n < min_n_safemath .and. level == 1) then - terminate = itrue - termination_type = i_term_mort_type_numdens - if ( debug ) then - write(fates_log(),*) 'terminating cohorts 0',currentCohort%n/currentPatch%area, & - currentCohort%dbh,currentCohort%pft,call_index - endif - endif - ! The rest of these are only allowed if we are not dealing with a recruit (level 2) if_level_2: if (.not.currentCohort%isnew .and. level == 2) then diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index a916caca44..f7c36b2fb3 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -3553,10 +3553,12 @@ subroutine terminate_patches(currentSite, bc_in) type(fates_patch_type), pointer :: youngerPatch type(fates_patch_type), pointer :: patchpointer type(fates_patch_type), pointer :: largest_patch + type(fates_patch_type), pointer :: orphan_lu_patch integer, parameter :: max_cycles = 10 ! After 10 loops through ! You should had fused integer :: count_cycles logical :: gotfused + logical :: current_patch_is_youngest_lutype integer :: i_landuse, i_pft integer :: land_use_type_to_remove @@ -3569,7 +3571,7 @@ subroutine terminate_patches(currentSite, bc_in) ! Initialize the count cycles count_cycles = 0 - + orphan_lu_patch => null() ! Start at the youngest patch in the list and assume that the largest patch is this patch currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) @@ -3641,6 +3643,7 @@ subroutine terminate_patches(currentSite, bc_in) 'lu label: '//trim(I2S(currentPatch%land_use_label))// & 'area: '//trim(N2S(currentPatch%area)) call FatesWarn(warn_msg,index=5) + orphan_lu_patch => currentPatch endif endif @@ -3728,6 +3731,37 @@ subroutine terminate_patches(currentSite, bc_in) endif nocomp_if endif lessthan_min_patcharea_if ! very small patch + if (associated(orphan_lu_patch)) then + if (.not. associated(orphan_lu_patch,currentSite%youngest_patch) & + .and. orphan_lu_patch%area < min_patch_area_forced) then + ! This is the only patch in this landuse label when running with nocomp. It will cause numerical instability. + ! We will terminate + warn_msg = 'This is an orphah patch with '// & + 'nocomp pft: '//trim(I2S(currentPatch%nocomp_pft_label))// & + 'lu label: '//trim(I2S(currentPatch%land_use_label))// & + 'area: '//trim(N2S(currentPatch%area))// 'sending to bareground.' + call FatesWarn(warn_msg,index=5) + patchpointer => currentSite%youngest_patch + do while(associated(patchpointer)) + if (patchpointer%nocomp_pft_label == nocomp_bareground) exit + patchpointer => patchpointer%older + end do + + if (associated(patchpointer)) then + if (.not. associated(orphan_lu_patch,orphan_lu_patch)) then + orphan_lu_patch%nocomp_pft_label = nocomp_bareground + orphan_lu_patch%land_use_label = nocomp_bareground_land + call fuse_2_patches(currentSite, orphan_lu_patch, patchpointer) + call terminate_cohorts(currentSite, currentPatch, 4,30,bc_in) + call currentPatch%SortCohorts() + call currentPatch%ValidateCohorts() + call currentPatch%CheckCohortsPfts(1) + endif + endif + ! if there is no bareground patch -> this orphan patch should be fused later. + end if + currentPatch => currentSite%youngest_patch + end if ! It is possible that an incredibly small patch just fused into another incredibly ! small patch, resulting in an incredibly small patch. It is also possible that this ! resulting incredibly small patch is the oldest patch. If this was true than diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index c02ea3bc60..1fc4ad93a9 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -20,6 +20,7 @@ module EDBtranMod bc_out_type, & numpft use FatesInterfaceTypesMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_use_nocomp use FatesGlobals , only : fates_log use FatesAllometryMod , only : set_root_fraction use shr_log_mod , only : errMsg => shr_log_errMsg @@ -30,7 +31,7 @@ module EDBtranMod private - logical, parameter :: debug = .true. + logical, parameter :: debug = .false. character(len=*), parameter :: sourcefile = __FILE__ public :: btran_ed @@ -176,7 +177,9 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) pftgs(ft) = 0._r8 endif end do - + + + ! THIS SHOULD REALLY BE A COHORT LOOP ONCE WE HAVE rootfr_ft FOR COHORTS (RGK) cpatch%btran_ft(:) = 0.0_r8 root_resis(:,:) = 0.0_r8 From 8f1c30528d5d8558a649110bcb5690038759f2e3 Mon Sep 17 00:00:00 2001 From: mvdebolskiy Date: Fri, 3 Jul 2026 05:26:09 +0200 Subject: [PATCH 2/2] put fuse in correct place to avoid infinite loop --- biogeochem/EDPatchDynamicsMod.F90 | 75 +++++++++++++------------------ 1 file changed, 31 insertions(+), 44 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index f7c36b2fb3..967c80f0a3 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -3571,14 +3571,13 @@ subroutine terminate_patches(currentSite, bc_in) ! Initialize the count cycles count_cycles = 0 - orphan_lu_patch => null() + ! Start at the youngest patch in the list and assume that the largest patch is this patch currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) lessthan_min_patcharea_if: if(currentPatch%area <= min_patch_area)then nocomp_if: if (hlm_use_nocomp .eq. itrue) then - gotfused = .false. patchpointer => currentSite%youngest_patch do while(associated(patchpointer)) @@ -3636,17 +3635,36 @@ subroutine terminate_patches(currentSite, bc_in) call fuse_2_patches(currentSite, largest_patch, currentPatch) gotfused = .true. else - !! truly nothing else in this land-use label to fuse into; warn as before - warn_msg = 'small nocomp patch wasnt able to find '// & - 'another patch to fuse with. '// & - 'nocomp pft: '//trim(I2S(currentPatch%nocomp_pft_label))// & - 'lu label: '//trim(I2S(currentPatch%land_use_label))// & - 'area: '//trim(N2S(currentPatch%area)) - call FatesWarn(warn_msg,index=5) - orphan_lu_patch => currentPatch - endif - endif - + !! truly nothing else in this land-use label to fuse into; + if (.not. associated(currentPatch,currentSite%youngest_patch) & + .and. currentPatch%area < min_patch_area_forced) then + ! This is the only patch in this landuse label when running with nocomp. It will cause numerical instability. + ! We will terminate + warn_msg = 'This is an orphah patch with '// & + 'nocomp pft: '//trim(I2S(currentPatch%nocomp_pft_label))// & + 'lu label: '//trim(I2S(currentPatch%land_use_label))// & + 'area: '//trim(N2S(currentPatch%area))// 'sending to bareground.' + call FatesWarn(warn_msg,index=5) + patchpointer => currentSite%youngest_patch + do while(associated(patchpointer)) + if (patchpointer%nocomp_pft_label == nocomp_bareground) exit + patchpointer => patchpointer%older + end do + if (associated(patchpointer)) then + currentPatch%nocomp_pft_label = nocomp_bareground + currentPatch%land_use_label = nocomp_bareground_land + call fuse_2_patches(currentSite, currentPatch, patchpointer) + call terminate_cohorts(currentSite, patchpointer, 4,30,bc_in) + call patchpointer%SortCohorts() + call patchpointer%ValidateCohorts() + call patchpointer%CheckCohortsPfts(1) + ! go back to youngest + currentPatch => currentSite%youngest_patch + gotfused = .true. + end if + end if + end if + end if else nocomp_if ! Even if the patch area is small, avoid fusing it into its neighbor @@ -3731,37 +3749,6 @@ subroutine terminate_patches(currentSite, bc_in) endif nocomp_if endif lessthan_min_patcharea_if ! very small patch - if (associated(orphan_lu_patch)) then - if (.not. associated(orphan_lu_patch,currentSite%youngest_patch) & - .and. orphan_lu_patch%area < min_patch_area_forced) then - ! This is the only patch in this landuse label when running with nocomp. It will cause numerical instability. - ! We will terminate - warn_msg = 'This is an orphah patch with '// & - 'nocomp pft: '//trim(I2S(currentPatch%nocomp_pft_label))// & - 'lu label: '//trim(I2S(currentPatch%land_use_label))// & - 'area: '//trim(N2S(currentPatch%area))// 'sending to bareground.' - call FatesWarn(warn_msg,index=5) - patchpointer => currentSite%youngest_patch - do while(associated(patchpointer)) - if (patchpointer%nocomp_pft_label == nocomp_bareground) exit - patchpointer => patchpointer%older - end do - - if (associated(patchpointer)) then - if (.not. associated(orphan_lu_patch,orphan_lu_patch)) then - orphan_lu_patch%nocomp_pft_label = nocomp_bareground - orphan_lu_patch%land_use_label = nocomp_bareground_land - call fuse_2_patches(currentSite, orphan_lu_patch, patchpointer) - call terminate_cohorts(currentSite, currentPatch, 4,30,bc_in) - call currentPatch%SortCohorts() - call currentPatch%ValidateCohorts() - call currentPatch%CheckCohortsPfts(1) - endif - endif - ! if there is no bareground patch -> this orphan patch should be fused later. - end if - currentPatch => currentSite%youngest_patch - end if ! It is possible that an incredibly small patch just fused into another incredibly ! small patch, resulting in an incredibly small patch. It is also possible that this ! resulting incredibly small patch is the oldest patch. If this was true than