diff --git a/biogeochem/CMakeLists.txt b/biogeochem/CMakeLists.txt index 7a10c1fa9b..ab1bc69840 100644 --- a/biogeochem/CMakeLists.txt +++ b/biogeochem/CMakeLists.txt @@ -4,6 +4,7 @@ list(APPEND fates_sources FatesCohortMod.F90 FatesAllometryMod.F90 DamageMainMod.F90 + EDCohortDynamicsMod.F90 FatesPatchMod.F90) sourcelist_to_parent(fates_sources) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index bdb7cee9cf..6d9f8cbcb5 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -7,26 +7,19 @@ Module EDCohortDynamicsMod ! USES: use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : fates_log - use FatesInterfaceTypesMod , only : hlm_freq_day use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_use_planthydro - use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking - use FatesInterfaceTypesMod , only : hlm_use_tree_damage - use FatesInterfaceTypesMod , only : hlm_is_restart use FatesConstantsMod , only : r8 => fates_r8 - use FatesConstantsMod , only : fates_unset_int use FatesConstantsMod , only : itrue,ifalse use FatesConstantsMod , only : fates_unset_r8 use FatesConstantsMod , only : nearzero use FatesConstantsMod , only : calloc_abs_error - use FatesInterfaceTypesMod , only : hlm_days_per_year use FatesInterfaceTypesMod , only : nleafage use SFParamsMod , only : SF_val_CWD_frac use EDPftvarcon , only : EDPftvarcon_inst use EDPftvarcon , only : GetDecompyFrac use PRTParametersMod , only : prt_params - use FatesParameterDerivedMod, only : param_derived use EDTypesMod , only : ed_site_type use FatesPatchMod, only : fates_patch_type use FatesCohortMod , only : fates_cohort_type @@ -38,16 +31,12 @@ Module EDCohortDynamicsMod use FatesLitterMod , only : litter_type use FatesLitterMod , only : adjust_SF_CWD_frac use EDParamsMod , only : max_cohort_per_patch - use EDTypesMod , only : AREA use EDTypesMod , only : min_npm2, min_nppatch use EDTypesMod , only : min_n_safemath use EDParamsMod , only : nlevleaf - use PRTGenericMod , only : max_nleafage use FatesConstantsMod , only : ican_upper - use EDTypesMod , only : site_fluxdiags_type use EDTypesMod , only : elem_diag_type use PRTGenericMod , only : num_elements - use FatesConstantsMod , only : leaves_on use FatesConstantsMod , only : leaves_off use FatesConstantsMod , only : leaves_shedding use FatesConstantsMod , only : ihard_stress_decid @@ -59,7 +48,6 @@ Module EDCohortDynamicsMod use FatesPlantHydraulicsMod, only : UpdateSizeDepPlantHydProps use FatesPlantHydraulicsMod, only : InitPlantHydStates use FatesPlantHydraulicsMod, only : InitHydrCohort - use FatesPlantHydraulicsMod, only : DeallocateHydrCohort use FatesPlantHydraulicsMod, only : AccumulateMortalityWaterStorage use FatesPlantHydraulicsMod, only : UpdatePlantHydrNodes use FatesPlantHydraulicsMod, only : UpdatePlantHydrLenVol @@ -91,36 +79,9 @@ Module EDCohortDynamicsMod use PRTGenericMod, only : store_organ use PRTGenericMod, only : repro_organ use PRTGenericMod, only : struct_organ - use PRTGenericMod, only : SetState use PRTAllometricCarbonMod, only : callom_prt_vartypes - use PRTAllometricCarbonMod, only : ac_bc_inout_id_netdc - use PRTAllometricCarbonMod, only : ac_bc_in_id_pft - use PRTAllometricCarbonMod, only : ac_bc_in_id_ctrim - use PRTAllometricCarbonMod, only : ac_bc_inout_id_dbh - use PRTAllometricCarbonMod, only : ac_bc_in_id_lstat - use PRTAllometricCarbonMod, only : ac_bc_in_id_cdamage - use PRTAllometricCarbonMod, only : ac_bc_in_id_efleaf - use PRTAllometricCarbonMod, only : ac_bc_in_id_effnrt - use PRTAllometricCarbonMod, only : ac_bc_in_id_efstem use PRTAllometricCNPMod, only : cnp_allom_prt_vartypes - use PRTAllometricCNPMod, only : acnp_bc_in_id_pft, acnp_bc_in_id_ctrim - use PRTAllometricCNPMod, only : acnp_bc_in_id_lstat, acnp_bc_inout_id_dbh - use PRTAllometricCNPMod, only : acnp_bc_in_id_efleaf - use PRTAllometricCNPMod, only : acnp_bc_in_id_effnrt - use PRTAllometricCNPMod, only : acnp_bc_in_id_efstem - use PRTAllometricCNPMod, only : acnp_bc_inout_id_l2fr - use PRTAllometricCNPMod, only : acnp_bc_inout_id_cx_int - use PRTAllometricCNPMod, only : acnp_bc_inout_id_cx0 - use PRTAllometricCNPMod, only : acnp_bc_inout_id_emadcxdt - use PRTAllometricCNPMod, only : acnp_bc_in_id_nc_repro - use PRTAllometricCNPMod, only : acnp_bc_in_id_pc_repro - use PRTAllometricCNPMod, only : acnp_bc_inout_id_resp_excess, acnp_bc_in_id_netdc - use PRTAllometricCNPMod, only : acnp_bc_inout_id_netdn, acnp_bc_inout_id_netdp - use PRTAllometricCNPMod, only : acnp_bc_out_id_cefflux, acnp_bc_out_id_nefflux - use PRTAllometricCNPMod, only : acnp_bc_out_id_pefflux, acnp_bc_out_id_limiter - use PRTAllometricCNPMod, only : acnp_bc_in_id_cdamage use DamageMainMod, only : undamaged_class - use FatesConstantsMod, only : n_term_mort_types use FatesConstantsMod, only : i_term_mort_type_cstarv use FatesConstantsMod, only : i_term_mort_type_canlev use FatesConstantsMod, only : i_term_mort_type_numdens @@ -136,9 +97,6 @@ Module EDCohortDynamicsMod public :: terminate_cohorts public :: terminate_cohort public :: fuse_cohorts - public :: insert_cohort - public :: sort_cohorts - public :: count_cohorts public :: InitPRTObject public :: SendCohortToLitter public :: EvaluateAndCorrectDBH @@ -161,138 +119,112 @@ Module EDCohortDynamicsMod contains !-------------------------------------------------------------------------------------! -subroutine create_cohort(currentSite, patchptr, pft, nn, height, coage, dbh, & - prt, elongf_leaf, elongf_fnrt, elongf_stem, status, recruitstatus, ctrim, & - carea, clayer, crowndamage, spread, bc_in) - -! -! DESCRIPTION: -! create new cohort -! There are 4 places this is called -! 1) Initializing new cohorts at the beginning of a cold-start simulation -! 2) Initializing new recruits during dynamics -! 3) Initializing new cohorts at the beginning of a inventory read -! 4) Initializing new cohorts during restart -! -! It is assumed that in the first 3, this is called with a reasonable amount of starter information. -! - -! ARGUMENTS: -type(ed_site_type), intent(inout), target :: currentSite ! site object -type(fates_patch_type), intent(inout), pointer :: patchptr ! pointer to patch object -integer, intent(in) :: pft ! cohort Plant Functional Type -integer, intent(in) :: crowndamage ! cohort damage class -integer, intent(in) :: clayer ! canopy status of cohort [1=canopy; 2=understorey] -integer, intent(in) :: status ! growth status of plant [1=leaves off; 2=leaves on] -integer, intent(in) :: recruitstatus ! recruit status of plant [1 = recruitment , 0 = other] -real(r8), intent(in) :: nn ! number of individuals in cohort [/m2] -real(r8), intent(in) :: height ! cohort height [m] -real(r8), intent(in) :: coage ! cohort age [m] -real(r8), intent(in) :: dbh ! cohort diameter at breast height [cm] -real(r8), intent(in) :: elongf_leaf ! leaf elongation factor [fraction] - 0: fully abscissed; 1: fully flushed -real(r8), intent(in) :: elongf_fnrt ! fine-root "elongation factor" [fraction] -real(r8), intent(in) :: elongf_stem ! stem "elongation factor" [fraction] -class(prt_vartypes), intent(inout), pointer :: prt ! allocated PARTEH object -real(r8), intent(in) :: ctrim ! fraction of the maximum leaf biomass we are targeting -real(r8), intent(in) :: spread ! how spread crowns are in horizontal space -real(r8), intent(in) :: carea ! area of cohort - ONLY USED IN SP MODE [m2] -type(bc_in_type), intent(in) :: bc_in ! external boundary conditions - -! LOCAL VARIABLES: -type(fates_cohort_type), pointer :: newCohort ! pointer to New Cohort structure. -type(fates_cohort_type), pointer :: storesmallcohort -type(fates_cohort_type), pointer :: storebigcohort -real(r8) :: rmean_temp ! running mean temperature -integer :: tnull, snull ! are the tallest and shortest cohorts allocate -integer :: nlevrhiz ! number of rhizosphere layers - -!---------------------------------------------------------------------- - -! create new cohort -allocate(newCohort) -call newCohort%Create(prt, pft, nn, height, coage, dbh, status, ctrim, carea, & - clayer, crowndamage, spread, patchptr%canopy_layer_tlai, elongf_leaf, elongf_fnrt, & - elongf_stem) - - -! Put cohort at the right place in the linked list -storebigcohort => patchptr%tallest -storesmallcohort => patchptr%shortest - -if (associated(patchptr%tallest)) then - tnull = 0 -else - tnull = 1 - patchptr%tallest => newCohort -endif - -if (associated(patchptr%shortest)) then - snull = 0 -else - snull = 1 - patchptr%shortest => newCohort -endif - -! Allocate running mean functions - -! (Keeping as an example) -!! allocate(newCohort%tveg_lpa) -!! call newCohort%tveg_lpa%InitRMean(ema_lpa,init_value=patchptr%tveg_lpa%GetMean()) - -if (hlm_use_planthydro .eq. itrue) then - - nlevrhiz = currentSite%si_hydr%nlevrhiz - - ! This allocates array spaces - call InitHydrCohort(currentSite, newCohort) - - ! zero out the water balance error - newCohort%co_hydr%errh2o = 0._r8 - - ! This calculates node heights - call UpdatePlantHydrNodes(newCohort, newCohort%pft, & - newCohort%height,currentSite%si_hydr) - - ! This calculates volumes and lengths - call UpdatePlantHydrLenVol(newCohort,currentSite%si_hydr) - - ! This updates the Kmax's of the plant's compartments - call UpdatePlantKmax(newCohort%co_hydr,newCohort,currentSite%si_hydr) - - ! Since this is a newly initialized plant, we set the previous compartment-size - ! equal to the ones we just calculated. - call SavePreviousCompartmentVolumes(newCohort%co_hydr) - - ! This comes up with starter suctions and then water contents - ! based on the soil values - call InitPlantHydStates(currentSite,newCohort) - - if(recruitstatus==1)then - - newCohort%co_hydr%is_newly_recruited = .true. - - ! If plant hydraulics is active, we must constrain the - ! number density of the new recruits based on the moisture - ! available to be subsumed in the new plant tissues. - ! So we go through the process of pre-initializing the hydraulic - ! states in the temporary cohort, to calculate this new number density - rmean_temp = patchptr%tveg24%GetMean() - call ConstrainRecruitNumber(currentSite, newCohort, patchptr, & - bc_in, rmean_temp) + subroutine create_cohort(currentSite, patchptr, pft, nn, height, coage, dbh, & + prt, elongf_leaf, elongf_fnrt, elongf_stem, status, recruitstatus, ctrim, & + carea, clayer, crowndamage, spread, bc_in) - endif + ! + ! DESCRIPTION: + ! create new cohort + ! There are 4 places this is called + ! 1) Initializing new cohorts at the beginning of a cold-start simulation + ! 2) Initializing new recruits during dynamics + ! 3) Initializing new cohorts at the beginning of a inventory read + ! 4) Initializing new cohorts during restart + ! + ! It is assumed that in the first 3, this is called with a reasonable amount of starter information. + ! + + ! ARGUMENTS: + type(ed_site_type), intent(inout), target :: currentSite ! site object + type(fates_patch_type), intent(inout), pointer :: patchptr ! pointer to patch object + integer, intent(in) :: pft ! cohort Plant Functional Type + integer, intent(in) :: crowndamage ! cohort damage class + integer, intent(in) :: clayer ! canopy status of cohort [1=canopy; 2=understorey] + integer, intent(in) :: status ! growth status of plant [1=leaves off; 2=leaves on] + integer, intent(in) :: recruitstatus ! recruit status of plant [1 = recruitment , 0 = other] + real(r8), intent(in) :: nn ! number of individuals in cohort [/m2] + real(r8), intent(in) :: height ! cohort height [m] + real(r8), intent(in) :: coage ! cohort age [m] + real(r8), intent(in) :: dbh ! cohort diameter at breast height [cm] + real(r8), intent(in) :: elongf_leaf ! leaf elongation factor [fraction] - 0: fully abscissed; 1: fully flushed + real(r8), intent(in) :: elongf_fnrt ! fine-root "elongation factor" [fraction] + real(r8), intent(in) :: elongf_stem ! stem "elongation factor" [fraction] + class(prt_vartypes), intent(inout), pointer :: prt ! allocated PARTEH object + real(r8), intent(in) :: ctrim ! fraction of the maximum leaf biomass we are targeting + real(r8), intent(in) :: spread ! how spread crowns are in horizontal space + real(r8), intent(in) :: carea ! area of cohort - ONLY USED IN SP MODE [m2] + type(bc_in_type), intent(in) :: bc_in ! external boundary conditions + + ! LOCAL VARIABLES: + type(fates_cohort_type), pointer :: newCohort ! pointer to New Cohort structure. + real(r8) :: rmean_temp ! running mean temperature + integer :: nlevrhiz ! number of rhizosphere layers + + !---------------------------------------------------------------------- + + ! create new cohort + allocate(newCohort) + call newCohort%Create(prt, pft, nn, height, coage, dbh, status, ctrim, carea, & + clayer, crowndamage, spread, patchptr%canopy_layer_tlai, elongf_leaf, elongf_fnrt, & + elongf_stem) + + ! Allocate running mean functions + + ! (Keeping as an example) + !! allocate(newCohort%tveg_lpa) + !! call newCohort%tveg_lpa%InitRMean(ema_lpa,init_value=patchptr%tveg_lpa%GetMean()) + + if (hlm_use_planthydro .eq. itrue) then + + nlevrhiz = currentSite%si_hydr%nlevrhiz + + ! This allocates array spaces + call InitHydrCohort(currentSite, newCohort) -endif + ! zero out the water balance error + newCohort%co_hydr%errh2o = 0._r8 -call insert_cohort(patchptr, newCohort, patchptr%tallest, patchptr%shortest, tnull, snull, & - storebigcohort, storesmallcohort) + ! This calculates node heights + call UpdatePlantHydrNodes(newCohort, newCohort%pft, & + newCohort%height,currentSite%si_hydr) -patchptr%tallest => storebigcohort -patchptr%shortest => storesmallcohort + ! This calculates volumes and lengths + call UpdatePlantHydrLenVol(newCohort,currentSite%si_hydr) -end subroutine create_cohort + ! This updates the Kmax's of the plant's compartments + call UpdatePlantKmax(newCohort%co_hydr,newCohort,currentSite%si_hydr) -! ------------------------------------------------------------------------------------! + ! Since this is a newly initialized plant, we set the previous compartment-size + ! equal to the ones we just calculated. + call SavePreviousCompartmentVolumes(newCohort%co_hydr) + + ! This comes up with starter suctions and then water contents + ! based on the soil values + call InitPlantHydStates(currentSite,newCohort) + + if(recruitstatus==1)then + + newCohort%co_hydr%is_newly_recruited = .true. + + ! If plant hydraulics is active, we must constrain the + ! number density of the new recruits based on the moisture + ! available to be subsumed in the new plant tissues. + ! So we go through the process of pre-initializing the hydraulic + ! states in the temporary cohort, to calculate this new number density + rmean_temp = patchptr%tveg24%GetMean() + call ConstrainRecruitNumber(currentSite, newCohort, patchptr, & + bc_in, rmean_temp) + + endif + + endif + + call patchptr%InsertCohort(newCohort) + + end subroutine create_cohort + + ! ------------------------------------------------------------------------------------! subroutine InitPRTObject(prt) @@ -345,7 +277,6 @@ subroutine InitPRTObject(prt) return end subroutine InitPRTObject - !-------------------------------------------------------------------------------------! subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_in) @@ -707,8 +638,6 @@ end subroutine SendCohortToLitter !-------------------------------------------------------------------------------------- - - subroutine fuse_cohorts(currentSite, currentPatch, bc_in) ! @@ -1281,218 +1210,16 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) enddo !do while nocohorts>maxcohorts endif ! patch. - + if (fusion_took_place == 1) then ! if fusion(s) occured sort cohorts - call sort_cohorts(currentPatch) + call currentPatch%SortCohorts() + call currentPatch%ValidateCohorts() endif - + end subroutine fuse_cohorts !-------------------------------------------------------------------------------------! - subroutine sort_cohorts(patchptr) - ! ============================================================================ - ! sort cohorts into the correct order DO NOT CHANGE THIS IT WILL BREAK - ! ============================================================================ - - type(fates_patch_type) , intent(inout), target :: patchptr - - type(fates_patch_type) , pointer :: current_patch - type(fates_cohort_type), pointer :: current_c, next_c - type(fates_cohort_type), pointer :: shortestc, tallestc - type(fates_cohort_type), pointer :: storesmallcohort - type(fates_cohort_type), pointer :: storebigcohort - integer :: snull,tnull - - current_patch => patchptr - tallestc => NULL() - shortestc => NULL() - storebigcohort => null() - storesmallcohort => null() - current_c => current_patch%tallest - - do while (associated(current_c)) - next_c => current_c%shorter - tallestc => storebigcohort - shortestc => storesmallcohort - if (associated(tallestc)) then - tnull = 0 - else - tnull = 1 - tallestc => current_c - endif - - if (associated(shortestc)) then - snull = 0 - else - snull = 1 - shortestc => current_c - endif - - call insert_cohort(current_patch, current_c, tallestc, shortestc, & - tnull, snull, storebigcohort, storesmallcohort) - - current_patch%tallest => storebigcohort - current_patch%shortest => storesmallcohort - current_c => next_c - - enddo - - end subroutine sort_cohorts - - !-------------------------------------------------------------------------------------! - subroutine insert_cohort(currentPatch, pcc, ptall, pshort, tnull, snull, storebigcohort, storesmallcohort) - ! - ! !DESCRIPTION: - ! Insert cohort into linked list - ! - ! !USES: - ! - ! !ARGUMENTS - type(fates_patch_type), intent(inout), target :: currentPatch - type(fates_cohort_type) , intent(inout), pointer :: pcc - type(fates_cohort_type) , intent(inout), pointer :: ptall - type(fates_cohort_type) , intent(inout), pointer :: pshort - integer , intent(in) :: tnull - integer , intent(in) :: snull - type(fates_cohort_type) , intent(inout),pointer,optional :: storesmallcohort ! storage of the smallest cohort for insertion routine - type(fates_cohort_type) , intent(inout),pointer,optional :: storebigcohort ! storage of the largest cohort for insertion routine - ! - ! !LOCAL VARIABLES: - !type(fates_patch_type), pointer :: currentPatch - type(fates_cohort_type), pointer :: current - type(fates_cohort_type), pointer :: tallptr, shortptr, icohort - type(fates_cohort_type), pointer :: ptallest, pshortest - real(r8) :: tsp - integer :: tallptrnull,exitloop - !---------------------------------------------------------------------- - - ptallest => ptall - pshortest => pshort - - if (tnull == 1) then - ptallest => null() - endif - if (snull == 1) then - pshortest => null() - endif - - icohort => pcc ! assign address to icohort local name - !place in the correct place in the linked list of heights - !begin by finding cohort that is just taller than the new cohort - tsp = icohort%height - - current => pshortest - exitloop = 0 - !starting with shortest tree on the grid, find tree just - !taller than tree being considered and return its pointer - if (associated(current)) then - do while (associated(current).and.exitloop == 0) - if (current%height < tsp) then - current => current%taller - else - exitloop = 1 - endif - enddo - endif - - if (associated(current)) then - tallptr => current - tallptrnull = 0 - else - tallptr => null() - tallptrnull = 1 - endif - - !new cohort is tallest - if (.not.associated(tallptr)) then - !new shorter cohort to the new cohort is the old tallest cohort - shortptr => ptallest - - !new cohort is tallest cohort and next taller remains null - ptallest => icohort - if (present(storebigcohort)) then - storebigcohort => icohort - end if - currentPatch%tallest => icohort - !new cohort is not tallest - else - !next shorter cohort to new cohort is the next shorter cohort - !to the cohort just taller than the new cohort - shortptr => tallptr%shorter - - !new cohort becomes the next shorter cohort to the cohort - !just taller than the new cohort - tallptr%shorter => icohort - endif - - !new cohort is shortest - if (.not.associated(shortptr)) then - !next shorter reamins null - !cohort is placed at the bottom of the list - pshortest => icohort - if (present(storesmallcohort)) then - storesmallcohort => icohort - end if - currentPatch%shortest => icohort - else - !new cohort is not shortest and becomes next taller cohort - !to the cohort just below it as defined in the previous block - shortptr%taller => icohort - endif - - ! assign taller and shorter links for the new cohort - icohort%taller => tallptr - if (tallptrnull == 1) then - icohort%taller=> null() - endif - icohort%shorter => shortptr - - end subroutine insert_cohort - - !-------------------------------------------------------------------------------------! - - subroutine count_cohorts( currentPatch ) - ! - ! !DESCRIPTION: - ! - ! !USES: - ! - ! !ARGUMENTS - type(fates_patch_type), intent(inout), target :: currentPatch !new site - ! - ! !LOCAL VARIABLES: - type(fates_cohort_type), pointer :: currentCohort !new patch - integer :: backcount - !---------------------------------------------------------------------- - - currentCohort => currentPatch%shortest - - currentPatch%countcohorts = 0 - do while (associated(currentCohort)) - currentPatch%countcohorts = currentPatch%countcohorts + 1 - currentCohort => currentCohort%taller - enddo - - backcount = 0 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - backcount = backcount + 1 - currentCohort => currentCohort%shorter - enddo - - if(debug) then - if (backcount /= currentPatch%countcohorts) then - write(fates_log(),*) 'problem with linked list, not symmetrical' - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - end if - - end subroutine count_cohorts - - ! =================================================================================== - - subroutine EvaluateAndCorrectDBH(currentCohort,delta_dbh,delta_height) ! ----------------------------------------------------------------------------------- diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index da979d87cc..54f95c2f30 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -9,7 +9,7 @@ module EDPatchDynamicsMod use EDPftvarcon , only : EDPftvarcon_inst use EDPftvarcon , only : GetDecompyFrac use PRTParametersMod , only : prt_params - use EDCohortDynamicsMod , only : fuse_cohorts, sort_cohorts, insert_cohort + use EDCohortDynamicsMod , only : fuse_cohorts use EDTypesMod , only : area_site => area use ChecksBalancesMod , only : PatchMassStock use FatesLitterMod , only : ncwd @@ -524,8 +524,6 @@ subroutine spawn_patches( currentSite, bc_in) type (fates_patch_type) , pointer :: currentPatch type (fates_cohort_type), pointer :: currentCohort type (fates_cohort_type), pointer :: nc - type (fates_cohort_type), pointer :: storesmallcohort - type (fates_cohort_type), pointer :: storebigcohort real(r8) :: site_areadis_primary ! total area disturbed (to primary forest) in m2 per site per day real(r8) :: site_areadis_secondary ! total area disturbed (to secondary forest) in m2 per site per day real(r8) :: patch_site_areadis ! total area disturbed in m2 per patch per day @@ -533,8 +531,6 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: age ! notional age of this patch in years integer :: el ! element loop index integer :: pft ! pft loop index - integer :: tnull ! is there a tallest cohort? - integer :: snull ! is there a shortest cohort? integer :: levcan ! canopy level real(r8) :: leaf_c ! leaf carbon [kg] real(r8) :: fnrt_c ! fineroot carbon [kg] @@ -570,9 +566,6 @@ subroutine spawn_patches( currentSite, bc_in) logical :: buffer_patch_used !--------------------------------------------------------------------- - storesmallcohort => null() ! storage of the smallest cohort for insertion routine - storebigcohort => null() ! storage of the largest cohort for insertion routine - if (hlm_use_nocomp .eq. itrue) then min_nocomp_pft = 0 max_nocomp_pft = numpft @@ -1257,30 +1250,7 @@ subroutine spawn_patches( currentSite, bc_in) ! if some plants in the new temporary cohort survived the transfer to the new patch, ! then put the cohort into the linked list. cohort_n_gt_zero: if (nc%n > 0.0_r8) then - storebigcohort => newPatch%tallest - storesmallcohort => newPatch%shortest - if(associated(newPatch%tallest))then - tnull = 0 - else - tnull = 1 - newPatch%tallest => nc - nc%taller => null() - endif - - if(associated(newPatch%shortest))then - snull = 0 - else - snull = 1 - newPatch%shortest => nc - nc%shorter => null() - endif - - call insert_cohort(newPatch, nc, newPatch%tallest, newPatch%shortest, & - tnull, snull, storebigcohort, storesmallcohort) - - newPatch%tallest => storebigcohort - newPatch%shortest => storesmallcohort - + call newPatch%InsertCohort(nc) else ! sadly, no plants in the cohort survived. on the bright side, we can deallocate their memory. call nc%FreeMemory() @@ -1293,8 +1263,10 @@ subroutine spawn_patches( currentSite, bc_in) currentCohort => currentCohort%taller enddo cohortloop + call newPatch%ValidateCohorts() - call sort_cohorts(currentPatch) + call currentPatch%SortCohorts() + call currentPatch%ValidateCohorts() !update area of donor patch oldarea = currentPatch%area @@ -1325,7 +1297,8 @@ subroutine spawn_patches( currentSite, bc_in) call terminate_cohorts(currentSite, currentPatch, 1,16,bc_in) call fuse_cohorts(currentSite,currentPatch, bc_in) call terminate_cohorts(currentSite, currentPatch, 2,16,bc_in) - call sort_cohorts(currentPatch) + call currentPatch%SortCohorts() + call currentPatch%ValidateCohorts() end if areadis_gt_zero_if ! if ( newPatch%area > nearzero ) then @@ -1352,7 +1325,8 @@ subroutine spawn_patches( currentSite, bc_in) call terminate_cohorts(currentSite, newPatch, 1,17, bc_in) call fuse_cohorts(currentSite,newPatch, bc_in) call terminate_cohorts(currentSite, newPatch, 2,17, bc_in) - call sort_cohorts(newPatch) + call newPatch%SortCohorts() + call newPatch%ValidateCohorts() endif @@ -1683,11 +1657,7 @@ subroutine split_patch(currentSite, currentPatch, new_patch, fraction_to_keep, a ! !LOCAL VARIABLES: integer :: el ! element loop index type (fates_cohort_type), pointer :: nc - type (fates_cohort_type), pointer :: storesmallcohort - type (fates_cohort_type), pointer :: storebigcohort type (fates_cohort_type), pointer :: currentCohort - integer :: tnull ! is there a tallest cohort? - integer :: snull ! is there a shortest cohort? integer :: pft real(r8) :: temp_area @@ -1754,34 +1724,14 @@ subroutine split_patch(currentSite, currentPatch, new_patch, fraction_to_keep, a ! loss of individuals from source patch due to area shrinking currentCohort%n = currentCohort%n * fraction_to_keep - storebigcohort => new_patch%tallest - storesmallcohort => new_patch%shortest - if(associated(new_patch%tallest))then - tnull = 0 - else - tnull = 1 - new_patch%tallest => nc - nc%taller => null() - endif - - if(associated(new_patch%shortest))then - snull = 0 - else - snull = 1 - new_patch%shortest => nc - nc%shorter => null() - endif - - call insert_cohort(new_patch, nc, new_patch%tallest, new_patch%shortest, & - tnull, snull, storebigcohort, storesmallcohort) - - new_patch%tallest => storebigcohort - new_patch%shortest => storesmallcohort + call new_patch%InsertCohort(nc) currentCohort => currentCohort%taller enddo ! currentCohort + call new_patch%ValidateCohorts() - call sort_cohorts(currentPatch) + call currentPatch%SortCohorts() + call currentPatch%ValidateCohorts() !update area of donor patch currentPatch%area = currentPatch%area - temp_area @@ -3124,7 +3074,8 @@ subroutine fuse_patches( csite, bc_in ) tmpptr => currentPatch%older call fuse_2_patches(csite, currentPatch, tpp) call fuse_cohorts(csite,tpp, bc_in) - call sort_cohorts(tpp) + call tpp%SortCohorts() + call tpp%ValidateCohorts() currentPatch => tmpptr !------------------------------------------------------------------------! @@ -3246,10 +3197,7 @@ subroutine fuse_2_patches(csite, dp, rp) ! !LOCAL VARIABLES: type (fates_cohort_type), pointer :: currentCohort ! Current Cohort type (fates_cohort_type), pointer :: nextc ! Remembers next cohort in list - type (fates_cohort_type), pointer :: storesmallcohort - type (fates_cohort_type), pointer :: storebigcohort integer :: c,p !counters for pft and litter size class. - integer :: tnull,snull ! are the tallest and shortest cohorts associated? integer :: el ! loop counting index for elements integer :: pft ! loop counter for pfts type(fates_patch_type), pointer :: youngerp ! pointer to the patch younger than donor @@ -3329,31 +3277,8 @@ subroutine fuse_2_patches(csite, dp, rp) endif do while(associated(dp%shortest)) - - storebigcohort => rp%tallest - storesmallcohort => rp%shortest - - if(associated(rp%tallest))then - tnull = 0 - else - tnull = 1 - rp%tallest => currentCohort - endif - - if(associated(rp%shortest))then - snull = 0 - else - snull = 1 - rp%shortest => currentCohort - endif - - call insert_cohort(rp, currentCohort, rp%tallest, rp%shortest, & - tnull, snull, storebigcohort, storesmallcohort) - - rp%tallest => storebigcohort - rp%shortest => storesmallcohort - - !currentCohort%patchptr => rp + + call rp%InsertCohort(currentCohort) currentCohort => nextc @@ -3364,6 +3289,7 @@ subroutine fuse_2_patches(csite, dp, rp) endif enddo !cohort + call rp%ValidateCohorts() endif !are there any cohorts? call patch_pft_size_profile(rp) ! Recalculate the patch size profile for the resulting patch diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index e91989e77b..fa15d20d69 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -43,7 +43,7 @@ module EDPhysiologyMod use EDPftvarcon , only : GetDecompyFrac use FatesInterfaceTypesMod, only : bc_in_type use FatesInterfaceTypesMod, only : bc_out_type - use EDCohortDynamicsMod , only : create_cohort, sort_cohorts + use EDCohortDynamicsMod , only : create_cohort use EDCohortDynamicsMod , only : InitPRTObject use FatesAllometryMod , only : tree_lai_sai use FatesAllometryMod , only : leafc_from_treelai @@ -681,7 +681,7 @@ subroutine trim_canopy( currentSite ) ! Add debug diagnstic output to determine which patch if (debug) then write(fates_log(),*) 'Current patch:', ipatch - write(fates_log(),*) 'Current patch cohorts:', currentPatch%countcohorts + write(fates_log(),*) 'Current patch cohorts:', currentPatch%num_cohorts endif icohort = 1 @@ -2791,6 +2791,7 @@ subroutine recruitment(currentSite, currentPatch, bc_in) endif any_recruits endif use_this_pft_if enddo !pft loop + call currentPatch%ValidateCohorts() end subroutine recruitment ! ====================================================================================== diff --git a/biogeochem/FatesCohortMod.F90 b/biogeochem/FatesCohortMod.F90 index f325449cf6..8fbaca6532 100644 --- a/biogeochem/FatesCohortMod.F90 +++ b/biogeochem/FatesCohortMod.F90 @@ -51,7 +51,7 @@ module FatesCohortMod implicit none private - + ! PARAMETERS character(len=*), parameter, private :: sourcefile = __FILE__ @@ -77,7 +77,6 @@ module FatesCohortMod !--------------------------------------------------------------------------- ! VEGETATION STRUCTURE - integer :: pft ! pft index real(r8) :: n ! number of individuals in cohort per 'area' (10000m2 default) [/m2] real(r8) :: dbh ! diameter at breast height [cm] @@ -450,7 +449,7 @@ subroutine NanValues(this) this%cambial_mort = nan this%crownfire_mort = nan this%fire_mort = nan - + end subroutine NanValues !=========================================================================== @@ -547,7 +546,7 @@ subroutine Create(this, prt, pft, nn, height, coage, dbh, status, & ! ! DESCRIPTION: ! set up values for a newly created cohort - + ! ARGUMENTS class(fates_cohort_type), intent(inout), target :: this ! cohort object class(prt_vartypes), intent(inout), pointer :: prt ! The allocated PARTEH object @@ -574,7 +573,7 @@ subroutine Create(this, prt, pft, nn, height, coage, dbh, status, & ! initialize cohort call this%Init(prt) - + ! set values this%pft = pft this%crowndamage = crowndamage diff --git a/biogeochem/FatesPatchMod.F90 b/biogeochem/FatesPatchMod.F90 index f8afc711db..e3816dfab9 100644 --- a/biogeochem/FatesPatchMod.F90 +++ b/biogeochem/FatesPatchMod.F90 @@ -1,39 +1,39 @@ module FatesPatchMod - use FatesConstantsMod, only : r8 => fates_r8 - use FatesConstantsMod, only : fates_unset_r8 - use FatesConstantsMod, only : fates_unset_int - use FatesConstantsMod, only : primaryland, secondaryland - use FatesConstantsMod, only : n_landuse_cats - use FatesConstantsMod, only : TRS_regeneration - use FatesConstantsMod, only : itrue, ifalse - use FatesGlobals, only : fates_log - use FatesGlobals, only : endrun => fates_endrun - use FatesUtilsMod, only : check_hlm_list - use FatesUtilsMod, only : check_var_real - use FatesCohortMod, only : fates_cohort_type - use FatesRunningMeanMod, only : rmean_type, rmean_arr_type - use FatesLitterMod, only : litter_type - use FatesFuelMod, only : fuel_type - use PRTGenericMod, only : num_elements - use PRTGenericMod, only : element_list - use PRTGenericMod, only : carbon12_element - use PRTGenericMod, only : struct_organ, leaf_organ, sapw_organ - use PRTParametersMod, only : prt_params - use FatesConstantsMod, only : nocomp_bareground - use EDParamsMod, only : nlevleaf, nclmax, maxpft - use FatesConstantsMod, only : n_dbh_bins, n_dist_types - use FatesConstantsMod, only : t_water_freeze_k_1atm - use FatesRunningMeanMod, only : ema_24hr, fixed_24hr, ema_lpa, ema_longterm - use FatesRunningMeanMod, only : ema_sdlng_emerg_h2o, ema_sdlng_mort_par - use FatesRunningMeanMod, only : ema_sdlng2sap_par, ema_sdlng_mdd - use TwoStreamMLPEMod, only : twostream_type - use FatesRadiationMemMod,only : num_swb - use FatesRadiationMemMod,only : num_rad_stream_types - use FatesInterfaceTypesMod,only : hlm_hio_ignore_val + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : fates_unset_r8 + use FatesConstantsMod, only : fates_unset_int + use FatesConstantsMod, only : primaryland, secondaryland + use FatesConstantsMod, only : n_landuse_cats + use FatesConstantsMod, only : TRS_regeneration + use FatesConstantsMod, only : itrue, ifalse + use FatesGlobals, only : fates_log + use FatesGlobals, only : endrun => fates_endrun + use FatesUtilsMod, only : check_hlm_list + use FatesUtilsMod, only : check_var_real + use FatesCohortMod, only : fates_cohort_type + use FatesRunningMeanMod, only : rmean_type, rmean_arr_type + use FatesLitterMod, only : litter_type + use FatesFuelMod, only : fuel_type + use PRTGenericMod, only : num_elements + use PRTGenericMod, only : element_list + use PRTGenericMod, only : carbon12_element + use PRTGenericMod, only : struct_organ, leaf_organ, sapw_organ + use PRTParametersMod, only : prt_params + use FatesConstantsMod, only : nocomp_bareground + use EDParamsMod, only : nlevleaf, nclmax, maxpft + use FatesConstantsMod, only : n_dbh_bins, n_dist_types + use FatesConstantsMod, only : t_water_freeze_k_1atm + use FatesRunningMeanMod, only : ema_24hr, fixed_24hr, ema_lpa, ema_longterm + use FatesRunningMeanMod, only : ema_sdlng_emerg_h2o, ema_sdlng_mort_par + use FatesRunningMeanMod, only : ema_sdlng2sap_par, ema_sdlng_mdd + use TwoStreamMLPEMod, only : twostream_type + use FatesRadiationMemMod, only : num_swb + use FatesRadiationMemMod, only : num_rad_stream_types + use FatesInterfaceTypesMod, only : hlm_hio_ignore_val use FatesInterfaceTypesMod, only : numpft - use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) - use shr_log_mod, only : errMsg => shr_log_errMsg + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + use shr_log_mod, only : errMsg => shr_log_errMsg implicit none private @@ -66,7 +66,7 @@ module FatesPatchMod real(r8) :: age ! average patch age [years] integer :: age_class ! age class of the patch for history binning purposes real(r8) :: area ! patch area [m2] - integer :: countcohorts ! number of cohorts in patch + integer :: num_cohorts ! number of cohorts in patch integer :: ncl_p ! number of occupied canopy layers integer :: land_use_label ! patch label for land use classification (primaryland, secondaryland, etc) real(r8) :: age_since_anthro_disturbance ! average age for secondary forest since last anthropogenic disturbance [years] @@ -234,6 +234,10 @@ module FatesPatchMod procedure :: InitRunningMeans procedure :: InitLitter procedure :: Create + procedure :: CountCohorts + procedure :: ValidateCohorts + procedure :: InsertCohort + procedure :: SortCohorts procedure :: UpdateTreeGrassArea procedure :: UpdateLiveGrass procedure :: FreeMemory @@ -437,7 +441,7 @@ subroutine NanValues(this) this%age = nan this%age_class = fates_unset_int this%area = nan - this%countcohorts = fates_unset_int + this%num_cohorts = fates_unset_int this%ncl_p = fates_unset_int this%land_use_label = fates_unset_int this%age_since_anthro_disturbance = nan @@ -540,6 +544,8 @@ subroutine ZeroDynamics(this) end subroutine ZeroDynamics + !=========================================================================== + subroutine ZeroValues(this) ! ! DESCRIPTION: @@ -782,32 +788,32 @@ end subroutine UpdateTreeGrassArea !=========================================================================== subroutine UpdateLiveGrass(this) - ! - ! DESCRIPTION: - ! Calculates the sum of live grass biomass [kgC/m2] on a patch - - ! ARGUMENTS: - class(fates_patch_type), intent(inout) :: this ! patch - - ! LOCALS: - real(r8) :: live_grass ! live grass [kgC/m2] - type(fates_cohort_type), pointer :: currentCohort ! cohort type - - live_grass = 0.0_r8 - currentCohort => this%tallest - do while(associated(currentCohort)) - ! for grasses sum all aboveground tissues - if (prt_params%woody(currentCohort%pft) == ifalse) then - live_grass = live_grass + & - (currentCohort%prt%GetState(leaf_organ, carbon12_element) + & - currentCohort%prt%GetState(sapw_organ, carbon12_element) + & - currentCohort%prt%GetState(struct_organ, carbon12_element))* & - currentCohort%n/this%area - endif - currentCohort => currentCohort%shorter - enddo + ! + ! DESCRIPTION: + ! Calculates the sum of live grass biomass [kgC/m2] on a patch - this%livegrass = live_grass + ! ARGUMENTS: + class(fates_patch_type), intent(inout) :: this ! patch + + ! LOCALS: + real(r8) :: live_grass ! live grass [kgC/m2] + type(fates_cohort_type), pointer :: currentCohort ! cohort type + + live_grass = 0.0_r8 + currentCohort => this%tallest + do while(associated(currentCohort)) + ! for grasses sum all aboveground tissues + if (prt_params%woody(currentCohort%pft) == ifalse) then + live_grass = live_grass + & + (currentCohort%prt%GetState(leaf_organ, carbon12_element) + & + currentCohort%prt%GetState(sapw_organ, carbon12_element) + & + currentCohort%prt%GetState(struct_organ, carbon12_element))* & + currentCohort%n/this%area + endif + currentCohort => currentCohort%shorter + enddo + + this%livegrass = live_grass end subroutine UpdateLiveGrass @@ -943,6 +949,243 @@ subroutine FreeMemory(this, regeneration_model, numpft) end subroutine FreeMemory + !=========================================================================== + + subroutine InsertCohort(this, cohort) + ! + ! DESCRIPTION: + ! Inserts a cohort into a patch's linked list structure + ! + + ! ARGUMENTS: + class(fates_patch_type), intent(inout), target :: this ! patch + type(fates_cohort_type), intent(inout), pointer :: cohort ! cohort to insert + + ! LOCALS: + type(fates_cohort_type), pointer :: temp_cohort1, temp_cohort2 ! temporary cohorts to store pointers + + ! validate the cohort before insertion + if (.not. associated(cohort)) then + call endrun(msg="cohort is not allocated", & + additional_msg=errMsg(sourcefile, __LINE__)) + return + end if + + ! check for inconsistent list state + if ((.not. associated(this%shortest) .and. associated(this%tallest)) .or. & + (associated(this%shortest) .and. .not. associated(this%tallest))) then + call endrun(msg="inconsistent list state", & + additional_msg=errMsg(sourcefile, __LINE__)) + return + end if + + ! nothing in the list - add to head + if (.not. associated(this%shortest)) then + this%shortest => cohort + this%tallest => this%shortest + cohort%taller => null() + cohort%shorter => null() + return + end if + + ! shortest - add to front of list + if (cohort%height < this%shortest%height) then + temp_cohort1 => this%shortest ! save current shortest in temporary pointer + cohort%taller => this%shortest ! attach cohort to list + this%shortest => cohort ! cohort is now the shortest + this%shortest%shorter => null() ! nullify new head's "shorter" pointer + temp_cohort1%shorter => this%shortest ! new head is previous head's 'shorter' + return + end if + + ! tallest - add to end + if (cohort%height >= this%tallest%height) then + this%tallest%taller => cohort ! attach cohort to end of list + temp_cohort1 => this%tallest ! store current tallest in temporary pointer + this%tallest => cohort ! cohort is now the tallest + this%tallest%shorter => temp_cohort1 ! new tail is previous tails's 'taller' + this%tallest%taller => null() ! nullify new tails's "taller" pointer + return + end if + + ! traverse list to find where to put cohort + temp_cohort1 => this%shortest + temp_cohort2 => temp_cohort1%taller + do while (associated(temp_cohort2)) + + ! validate list structure before insertion + + if (associated(temp_cohort1%taller) .and. & + .not. associated(temp_cohort1%taller%shorter, temp_cohort1)) then + call endrun(msg="corrupted list structure", & + additional_msg=errMsg(sourcefile, __LINE__)) + return + end if + + if ((cohort%height >= temp_cohort1%height) .and. (cohort%height < temp_cohort2%height)) then + ! add cohort here + cohort%taller => temp_cohort2 + temp_cohort1%taller => cohort + cohort%shorter => temp_cohort1 + temp_cohort2%shorter => cohort + exit + end if + temp_cohort1 => temp_cohort2 + temp_cohort2 => temp_cohort2%taller + end do + + end subroutine InsertCohort + + !=========================================================================== + + subroutine ValidateCohorts(this) + ! + ! DESCRIPTION: + ! Validates a patch's cohort linked list + ! + + ! ARGUMENTS: + class(fates_patch_type), intent(in), target :: this ! patch + + ! LOCALS: + type(fates_cohort_type), pointer :: currentCohort ! cohort object + integer :: forward_count, backward_count ! forwards and backwards counts of cohorts + + ! check initial conditions + if (.not. associated(this%shortest) .and. .not. associated(this%tallest)) then + ! validation passed - empty list + return + else if (.not. associated(this%shortest) .or. .not. associated(this%tallest)) then + call endrun(msg="one of shortest or tallest is null", & + additional_msg=errMsg(sourcefile, __LINE__)) + return + end if + + ! initialize counts + forward_count = 0 + backward_count = 0 + + ! traverse taller chain + currentCohort => this%shortest + do while (associated(currentCohort)) + forward_count = forward_count + 1 + + ! validate cohort + if (associated(currentCohort%taller)) then + if (.not. associated(currentCohort%taller%shorter, currentCohort)) then + call endrun(msg="mismatch in patch's taller chain", & + additional_msg=errMsg(sourcefile, __LINE__)) + return + end if + else + if (.not. associated(currentCohort, this%tallest)) then + call endrun(msg="cohort list does not end at tallest", & + additional_msg=errMsg(sourcefile, __LINE__)) + return + end if + end if + currentCohort => currentCohort%taller + end do + + ! traverse shorter chain + currentCohort => this%tallest + do while (associated(currentCohort)) + backward_count = backward_count + 1 + + if (associated(currentCohort%shorter)) then + if (.not. associated(currentCohort%shorter%taller, currentCohort)) then + call endrun(msg="mismatch in patch's shorter chain", & + additional_msg=errMsg(sourcefile, __LINE__)) + return + end if + else + if (.not. associated(currentCohort, this%shortest)) then + call endrun(msg="cohort list does not start at shortest", & + additional_msg=errMsg(sourcefile, __LINE__)) + return + end if + end if + currentCohort => currentCohort%shorter + end do + + ! check consistency between forward and backward counts + if (forward_count /= backward_count) then + call endrun(msg="forward and backward traversal counts do not match", & + additional_msg=errMsg(sourcefile, __LINE__)) + return + end if + + end subroutine ValidateCohorts + + !=========================================================================== + + subroutine CountCohorts(this) + ! + ! DESCRIPTION: + ! Counts the number of a cohorts in a patch's linked list and updates + ! the this%num_cohorts attribute + ! + + ! ARGUMENTS: + class(fates_patch_type), intent(inout), target :: this ! patch + + ! LOCALS: + type(fates_cohort_type), pointer :: currentCohort ! cohort object + integer :: cohort_count ! count of cohorts + + cohort_count = 0 + currentCohort => this%shortest + do while (associated(currentCohort)) + cohort_count = cohort_count + 1 + currentCohort => currentCohort%taller + end do + + this%num_cohorts = cohort_count + + end subroutine CountCohorts + + !=========================================================================== + + subroutine SortCohorts(this) + ! + ! DESCRIPTION: sort cohorts in patch's linked list + ! uses insertion sort to build a new list + ! + + ! ARGUMENTS: + class(fates_patch_type), intent(inout), target :: this ! patch + + ! LOCALS: + type(fates_cohort_type), pointer :: currentCohort + type(fates_cohort_type), pointer :: nextCohort + + ! check for inconsistent list state + if (.not. associated(this%shortest) .and. .not. associated(this%tallest)) then + ! empty list + return + else if (.not. associated(this%shortest) .or. .not. associated(this%tallest)) then + call endrun(msg="inconsistent list state", & + additional_msg=errMsg(sourcefile, __LINE__)) + return + end if + + ! hold on to current linked list so we don't lose it + currentCohort => this%shortest + + ! reset the current list: we'll build it incrementally + this%shortest => null() + this%tallest => null() + + ! insert each cohort + do while (associated(currentCohort)) + ! store the next cohort to sort + nextCohort => currentCohort%taller + call this%InsertCohort(currentCohort) + currentCohort => nextCohort + end do + + end subroutine SortCohorts + !=========================================================================== subroutine Dump(this) @@ -965,7 +1208,7 @@ subroutine Dump(this) write(fates_log(),*) 'pa%age = ',this%age write(fates_log(),*) 'pa%age_class = ',this%age_class write(fates_log(),*) 'pa%area = ',this%area - write(fates_log(),*) 'pa%countcohorts = ',this%countcohorts + write(fates_log(),*) 'pa%num_cohorts = ',this%num_cohorts write(fates_log(),*) 'pa%ncl_p = ',this%ncl_p write(fates_log(),*) 'pa%total_canopy_area = ',this%total_canopy_area write(fates_log(),*) 'pa%total_tree_area = ',this%total_tree_area diff --git a/biogeophys/CMakeLists.txt b/biogeophys/CMakeLists.txt index c6048491b9..b232b22a95 100644 --- a/biogeophys/CMakeLists.txt +++ b/biogeophys/CMakeLists.txt @@ -1,4 +1,5 @@ list(APPEND fates_sources - FatesHydroWTFMod.F90) + FatesHydroWTFMod.F90 + FatesPlantHydraulicsMod.F90) sourcelist_to_parent(fates_sources) \ No newline at end of file diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index d1413f1b15..56b40b9b4d 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -422,7 +422,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! ------------------------------------------------------------------------ rate_mask_z(:,1:numpft,:) = .false. - if_any_cohorts: if(currentPatch%countcohorts > 0.0)then + if_any_cohorts: if(currentPatch%num_cohorts > 0.0)then currentCohort => currentPatch%tallest do_cohort_drive: do while (associated(currentCohort)) ! Cohort loop diff --git a/main/CMakeLists.txt b/main/CMakeLists.txt index 17156c7e3e..8db1d06331 100644 --- a/main/CMakeLists.txt +++ b/main/CMakeLists.txt @@ -11,13 +11,6 @@ list(APPEND clm_sources FatesUtilsMod.F90 ) -list(APPEND fates_sources - FatesConstantsMod.F90 - FatesGlobals.F90 - FatesParametersInterface.F90 - ) - -sourcelist_to_parent(fates_sources) sourcelist_to_parent(clm_sources) list(APPEND fates_sources diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 9fc11491c1..5e2efa105f 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -24,7 +24,7 @@ module EDInitMod use FatesInterfaceTypesMod , only : hlm_current_tod use EDPftvarcon , only : EDPftvarcon_inst use PRTParametersMod , only : prt_params - use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts + use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts use EDCohortDynamicsMod , only : InitPRTObject use EDPatchDynamicsMod , only : set_patchno use EDPhysiologyMod , only : calculate_sp_properties @@ -1331,8 +1331,10 @@ subroutine init_cohorts(site_in, patch_in, bc_in) if (hlm_use_sp == ifalse) then call fuse_cohorts(site_in, patch_in,bc_in) - call sort_cohorts(patch_in) - end if + call patch_in%SortCohorts() + end if + + call patch_in%ValidateCohorts() end subroutine init_cohorts diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 8f3ea9537c..1abacccf69 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -33,8 +33,6 @@ module EDMainMod use PRTGenericMod , only : phosphorus_element use EDCohortDynamicsMod , only : terminate_cohorts use EDCohortDynamicsMod , only : fuse_cohorts - use EDCohortDynamicsMod , only : sort_cohorts - use EDCohortDynamicsMod , only : count_cohorts use EDCohortDynamicsMod , only : EvaluateAndCorrectDBH use EDCohortDynamicsMod , only : DamageRecovery use EDPatchDynamicsMod , only : disturbance_rates @@ -259,7 +257,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) do while (associated(currentPatch)) ! puts cohorts in right order - call sort_cohorts(currentPatch) + call currentPatch%SortCohorts() ! kills cohorts that are too few call terminate_cohorts(currentSite, currentPatch, 1, 10, bc_in ) @@ -273,6 +271,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) currentPatch => currentPatch%younger enddo + end if call TotalBalanceCheck(currentSite,2) @@ -861,7 +860,7 @@ subroutine ed_update_site( currentSite, bc_in, bc_out, is_restarting ) end if ! This cohort count is used in the photosynthesis loop - call count_cohorts(currentPatch) + call currentPatch%CountCohorts() ! Update the total area of by patch age class array currentSite%area_by_age(currentPatch%age_class) = & diff --git a/main/FatesGlobals.F90 b/main/FatesGlobals.F90 index 299fb5d5fb..22d2d623be 100644 --- a/main/FatesGlobals.F90 +++ b/main/FatesGlobals.F90 @@ -78,7 +78,7 @@ logical function fates_global_verbose() fates_global_verbose = fates_global_verbose_ end function fates_global_verbose - subroutine fates_endrun(msg) + subroutine fates_endrun(msg, additional_msg) !----------------------------------------------------------------------- ! !DESCRIPTION: @@ -90,11 +90,17 @@ subroutine fates_endrun(msg) ! ! !ARGUMENTS: implicit none - character(len=*), intent(in) :: msg ! string to be printed + character(len=*), intent(in) :: msg ! string to be printed + character(len=*), intent(in), optional :: additional_msg ! string to be printed, but not passed to shr_sys_abort !----------------------------------------------------------------------- - write(fates_log(),*)'ENDRUN:', msg - call shr_sys_abort() + if (present(additional_msg)) then + write(fates_log(),*) 'ENDRUN: ', trim(additional_msg) + else + write(fates_log(),*) 'ENDRUN: ' + end if + + call shr_sys_abort(msg) end subroutine fates_endrun diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 4b945741fd..482586df1e 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -121,8 +121,6 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) use FatesConstantsMod, only : nearzero use EDPatchDynamicsMod, only : fuse_patches use EDCohortDynamicsMod, only : fuse_cohorts - use EDCohortDynamicsMod, only : sort_cohorts - use EDcohortDynamicsMod, only : count_cohorts use EDPatchDynamicsMod, only : patch_pft_size_profile ! Arguments @@ -430,11 +428,11 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! Perform Cohort Fusion call fuse_cohorts(sites(s), currentpatch,bc_in(s)) - call sort_cohorts(currentpatch) + call currentpatch%SortCohorts() - ! This calculates %countcohorts - call count_cohorts(currentpatch) - total_cohorts = total_cohorts + currentPatch%countcohorts + ! This calculates %num_cohorts + call currentPatch%CountCohorts() + total_cohorts = total_cohorts + currentPatch%num_cohorts currentPatch => currentpatch%older enddo @@ -1132,6 +1130,7 @@ subroutine set_inventory_cohort_type1(csite,bc_in,css_file_unit,npatches, & deallocate(temp_cohort) ! get rid of temporary cohort end do + call cpatch%ValidateCohorts() return end subroutine set_inventory_cohort_type1 diff --git a/radiation/CMakeLists.txt b/radiation/CMakeLists.txt index 74d625b12d..feda02d4a6 100644 --- a/radiation/CMakeLists.txt +++ b/radiation/CMakeLists.txt @@ -1,7 +1,6 @@ # This file is required for unit testing, but is not used for production runs list(APPEND fates_sources TwoStreamMLPEMod.F90 - FatesRadiationMemMod.F90 - ) + FatesRadiationMemMod.F90) sourcelist_to_parent(fates_sources) diff --git a/testing/CMakeLists.txt b/testing/CMakeLists.txt index be26ace27f..0795757b05 100644 --- a/testing/CMakeLists.txt +++ b/testing/CMakeLists.txt @@ -5,7 +5,12 @@ add_subdirectory(functional_testing/allometry fates_allom_ftest) add_subdirectory(functional_testing/math_utils fates_math_ftest) add_subdirectory(functional_testing/fire/fuel fates_fuel_ftest) add_subdirectory(functional_testing/fire/ros fates_ros_ftest) +add_subdirectory(functional_testing/patch fates_patch_ftest) ## Unit tests add_subdirectory(unit_testing/fire_weather_test fates_fire_weather_utest) add_subdirectory(unit_testing/fire_fuel_test fates_fire_fuel_utest) +add_subdirectory(unit_testing/sort_cohorts_test fates_sort_cohorts_utest) +add_subdirectory(unit_testing/insert_cohort_test fates_insert_cohort_utest) +add_subdirectory(unit_testing/validate_cohorts_test fates_validate_cohorts_utest) +add_subdirectory(unit_testing/count_cohorts_test fates_count_cohorts_utest) diff --git a/testing/functional_testing/patch/CMakeLists.txt b/testing/functional_testing/patch/CMakeLists.txt new file mode 100644 index 0000000000..6672cf5ce0 --- /dev/null +++ b/testing/functional_testing/patch/CMakeLists.txt @@ -0,0 +1,24 @@ +set(patch_sources FatesTestPatch.F90) + +set(NETCDF_C_DIR ${NETCDF_C_PATH}) +set(NETCDF_FORTRAN_DIR ${NETCDF_F_PATH}) + +FIND_PATH(NETCDFC_FOUND libnetcdf.a ${NETCDF_C_DIR}/lib) +FIND_PATH(NETCDFF_FOUND libnetcdff.a ${NETCDF_FORTRAN_DIR}/lib) + + +include_directories(${NETCDF_C_DIR}/include + ${NETCDF_FORTRAN_DIR}/include) + +link_directories(${NETCDF_C_DIR}/lib + ${NETCDF_FORTRAN_DIR}/lib + ${PFUNIT_TOP_DIR}/lib) + +add_executable(FATES_patch_exe ${patch_sources}) + +target_link_libraries(FATES_patch_exe + netcdf + netcdff + fates + csm_share + funit) \ No newline at end of file diff --git a/testing/functional_testing/patch/FatesTestPatch.F90 b/testing/functional_testing/patch/FatesTestPatch.F90 new file mode 100644 index 0000000000..5b68a6f771 --- /dev/null +++ b/testing/functional_testing/patch/FatesTestPatch.F90 @@ -0,0 +1,52 @@ +program FatesTestPatch + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : itrue + use FatesUnitTestParamReaderMod, only : fates_unit_test_param_reader + use FatesArgumentUtils, only : command_line_arg + use FatesCohortMod, only : fates_cohort_type + use FatesPatchMod, only : fates_patch_type + use FatesFactoryMod, only : InitializeGlobals, GetSyntheticPatch + use SyntheticPatchTypes, only : synthetic_patch_array_type + + implicit none + + ! LOCALS: + type(fates_unit_test_param_reader) :: param_reader ! param reader instance + type(synthetic_patch_array_type) :: patch_data ! array of synthetic patches + character(len=:), allocatable :: param_file ! input parameter file + type(fates_patch_type), pointer :: patch ! patch + type(fates_cohort_type), pointer :: cohort ! cohort + integer :: i ! patch array location + + ! CONSTANTS: + integer, parameter :: num_levsoil = 10 ! number of soil layers + real(r8), parameter :: step_size = 1800.0_r8 ! step-size [s] + + !read in parameter file name from command line + param_file = command_line_arg(1) + + ! read in parameter file + call param_reader%Init(param_file) + call param_reader%RetrieveParameters() + + ! initialize some global data we need + call InitializeGlobals(step_size) + + ! get all the patch data + call patch_data%GetSyntheticPatchData() + + i = patch_data%PatchDataPosition(patch_name='tropical') + call GetSyntheticPatch(patch_data%patches(i), num_levsoil, patch) + + ! print out list in ascending order + cohort => patch%shortest + write(*,*) 'Patch structure:' + do while (associated(cohort)) + write (*,*) cohort%pft, cohort%dbh, cohort%height + cohort => cohort%taller + end do + write(*,*) ' ' + +end program FatesTestPatch + diff --git a/testing/functional_testing/patch/patch_test.py b/testing/functional_testing/patch/patch_test.py new file mode 100644 index 0000000000..7d4fec3e8d --- /dev/null +++ b/testing/functional_testing/patch/patch_test.py @@ -0,0 +1,39 @@ +""" +Concrete class for running the allometry functional tests for FATES. +""" +import os +import xarray as xr +import pandas as pd +import numpy as np +import matplotlib.pyplot as plt +from utils import round_up, get_color_palette, blank_plot +from functional_class import FunctionalTest + + +class PatchTest(FunctionalTest): + """Patch test class + """ + + name = "patch" + + def __init__(self, test_dict): + super().__init__( + PatchTest.name, + test_dict["test_dir"], + test_dict["test_exe"], + test_dict["out_file"], + test_dict["use_param_file"], + test_dict["other_args"], + ) + self.plot = True + + def plot_output(self, run_dir: str, save_figs: bool, plot_dir: str): + """Plots all allometry plots + + Args: + run_dir (str): run directory + out_file (str): output file name + save_figs (bool): whether or not to save the figures + plot_dir (str): plot directory to save the figures to + """ + diff --git a/testing/functional_tests.cfg b/testing/functional_tests.cfg index 1de704ac16..98d8448e42 100644 --- a/testing/functional_tests.cfg +++ b/testing/functional_tests.cfg @@ -25,3 +25,10 @@ test_exe = FATES_ros_exe out_file = ros_out.nc use_param_file = True other_args = [] + +[patch] +test_dir = fates_patch_ftest +test_exe = FATES_patch_exe +out_file = None +use_param_file = True +other_args = [] diff --git a/testing/load_functional_tests.py b/testing/load_functional_tests.py new file mode 100644 index 0000000000..7b2051f15d --- /dev/null +++ b/testing/load_functional_tests.py @@ -0,0 +1,8 @@ +# add testing subclasses here + +from functional_class import FunctionalTest +from functional_testing.allometry.allometry_test import AllometryTest +from functional_testing.math_utils.math_utils_test import QuadraticTest +from functional_testing.fire.fuel.fuel_test import FuelTest +from functional_testing.fire.ros.ros_test import ROSTest +from functional_testing.patch.patch_test import PatchTest diff --git a/testing/run_functional_tests.py b/testing/run_functional_tests.py index 44bd1dfe08..105c22b06a 100755 --- a/testing/run_functional_tests.py +++ b/testing/run_functional_tests.py @@ -34,22 +34,12 @@ from path_utils import add_cime_lib_to_path from utils import copy_file, create_nc_from_cdl, config_to_dict, parse_test_list -# add testing subclasses here -from functional_class import FunctionalTest -from functional_testing.allometry.allometry_test import ( - AllometryTest, -) # pylint: disable=unused-import -from functional_testing.math_utils.math_utils_test import ( - QuadraticTest, -) # pylint: disable=unused-import -from functional_testing.fire.fuel.fuel_test import FuelTest # pylint: disable=unused-import -from functional_testing.fire.ros.ros_test import ROSTest # pylint: disable=unused-import +# load the functional test classes +from load_functional_tests import * add_cime_lib_to_path() -from CIME.utils import ( - run_cmd_no_fail, -) # pylint: disable=wrong-import-position,import-error,wrong-import-order +from CIME.utils import run_cmd_no_fail # constants for this script _DEFAULT_CONFIG_FILE = "functional_tests.cfg" diff --git a/testing/testing_shr/CMakeLists.txt b/testing/testing_shr/CMakeLists.txt index c295bdaf64..292023195f 100644 --- a/testing/testing_shr/CMakeLists.txt +++ b/testing/testing_shr/CMakeLists.txt @@ -2,6 +2,8 @@ list(APPEND fates_sources FatesUnitTestParamReaderMod.F90 FatesUnitTestIOMod.F90 FatesArgumentUtils.F90 - ) + FatesFactoryMod.F90 + SyntheticPatchTypes.F90 + FatesUnitTestUtils.F90) sourcelist_to_parent(fates_sources) \ No newline at end of file diff --git a/testing/testing_shr/FatesFactoryMod.F90 b/testing/testing_shr/FatesFactoryMod.F90 new file mode 100644 index 0000000000..e0fe2293c6 --- /dev/null +++ b/testing/testing_shr/FatesFactoryMod.F90 @@ -0,0 +1,536 @@ +module FatesFactoryMod + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : leaves_on, leaves_off + use FatesConstantsMod, only : itrue + use FatesConstantsMod, only : ihard_stress_decid + use FatesConstantsMod, only : isemi_stress_decid + use FatesConstantsMod, only : primaryland + use FatesConstantsMod, only : sec_per_day, days_per_year + use FatesGlobals, only : fates_log + use FatesGlobals, only : endrun => fates_endrun + use FatesCohortMod, only : fates_cohort_type + use FatesPatchMod, only : fates_patch_type + use EDTypesMod, only : init_spread_inventory + use FatesRadiationMemMod, only : num_swb + use EDParamsMod, only : ED_val_vai_top_bin_width + use EDParamsMod, only : ED_val_vai_width_increase_factor + use EDParamsMod, only : nlevleaf + use EDParamsMod, only : dinc_vai + use EDParamsMod, only : dlower_vai + use EDParamsMod, only : nclmax + use EDParamsMod, only : photo_temp_acclim_timescale + use EDParamsMod, only : photo_temp_acclim_thome_time + use FatesRunningMeanMod, only : ema_24hr, fixed_24hr, ema_lpa, ema_longterm + use FatesRunningMeanMod, only : moving_ema_window, fixed_window + use EDCohortDynamicsMod, only : InitPRTObject + use PRTParametersMod, only : prt_params + use PRTGenericMod, only : element_pos + use PRTGenericMod, only : num_elements + use PRTGenericMod, only : element_list + use PRTGenericMod, only : SetState + use PRTGenericMod, only : prt_vartypes + use PRTGenericMod, only : leaf_organ + use PRTGenericMod, only : fnrt_organ + use PRTGenericMod, only : sapw_organ + use PRTGenericMod, only : store_organ + use PRTGenericMod, only : struct_organ + use PRTGenericMod, only : repro_organ + use PRTGenericMod, only : carbon12_element + use PRTGenericMod, only : nitrogen_element + use PRTGenericMod, only : phosphorus_element + use PRTGenericMod, only : prt_carbon_allom_hyp + use PRTGenericMod, only : prt_cnp_flex_allom_hyp + use PRTGenericMod, only : StorageNutrientTarget + use PRTAllometricCarbonMod, only : InitPRTGlobalAllometricCarbon + use FatesAllometryMod, only : h_allom + use FatesAllometryMod, only : bagw_allom + use FatesAllometryMod, only : bbgw_allom + use FatesAllometryMod, only : bleaf + use FatesAllometryMod, only : bfineroot + use FatesAllometryMod, only : bsap_allom + use FatesAllometryMod, only : bdead_allom + use FatesAllometryMod, only : bstore_allom + use FatesAllometryMod, only : carea_allom + use FatesInterfaceTypesMod, only : hlm_parteh_mode + use FatesInterfaceTypesMod, only : nleafage + use FatesSizeAgeTypeIndicesMod, only : get_age_class_index + use EDParamsMod, only : regeneration_model + use SyntheticPatchTypes, only : synthetic_patch_type + use shr_log_mod, only : errMsg => shr_log_errMsg + + implicit none + + public :: GetSyntheticPatch + public :: InitializeGlobals + + contains + + !--------------------------------------------------------------------------------------- + + subroutine InitializeGlobals(step_size) + ! + ! DESCRIPTION: + ! Initialize globals needed for running factory + + ! ARGUMENTS: + real(r8), intent(in) :: step_size ! step size to use + + ! LOCALS: + integer :: i ! looping index + + ! initialize some values + hlm_parteh_mode = prt_carbon_allom_hyp + num_elements = 1 + allocate(element_list(num_elements)) + element_list(1) = carbon12_element + element_pos(:) = 0 + element_pos(carbon12_element) = 1 + call InitPRTGlobalAllometricCarbon() + + allocate(ema_24hr) + call ema_24hr%define(sec_per_day, step_size, moving_ema_window) + allocate(fixed_24hr) + call fixed_24hr%define(sec_per_day, step_size, fixed_window) + allocate(ema_lpa) + call ema_lpa%define(photo_temp_acclim_timescale*sec_per_day, step_size, & + moving_ema_window) + allocate(ema_longterm) + call ema_longterm%define(photo_temp_acclim_thome_time*days_per_year*sec_per_day, & + step_size, moving_ema_window) + + do i = 1, nlevleaf + dinc_vai(i) = ED_val_vai_top_bin_width*ED_val_vai_width_increase_factor**(i-1) + end do + + do i = 1, nlevleaf + dlower_vai(i) = sum(dinc_vai(1:i)) + end do + + end subroutine InitializeGlobals + + !--------------------------------------------------------------------------------------- + + subroutine PRTFactory(prt, pft, c_struct, c_leaf, c_fnrt, c_sapw, c_store) + ! + ! DESCRIPTION: + ! Create a prt object + + ! ARGUMENTS: + class(prt_vartypes), pointer, intent(inout) :: prt ! PARTEH object + integer, intent(in) :: pft ! plant functional type + real(r8), intent(in) :: c_struct ! structural carbon [kgC] + real(r8), intent(in) :: c_leaf ! leaf carbon [kgC] + real(r8), intent(in) :: c_fnrt ! fine root carbon [kgC] + real(r8), intent(in) :: c_sapw ! sapwood carbon [kgC] + real(r8), intent(in) :: c_store ! storage carbon [kgC] + + ! LOCALS: + integer :: el ! looping index + integer :: iage ! looping index + integer :: element_id ! element id + real(r8) :: m_struct ! mass of structual biomass [kg] + real(r8) :: m_leaf ! mass of leaf biomass [kg] + real(r8) :: m_fnrt ! mass of fineroot biomass [kg] + real(r8) :: m_sapw ! mass of sapwood biomass [kg] + real(r8) :: m_store ! mass of storage biomass [kg] + real(r8) :: m_repro ! mass of reproductive tissue biomass [kg] + + prt => null() + + call InitPRTObject(prt) + + do el = 1, num_elements + + element_id = element_list(el) + + ! If this is carbon12, then the initialization is straight forward + ! otherwise, we use stoichiometric ratios + select case(element_id) + + case(carbon12_element) + m_struct = c_struct + m_leaf = c_leaf + m_fnrt = c_fnrt + m_sapw = c_sapw + m_store = c_store + m_repro = 0.0_r8 + case(nitrogen_element) + m_struct = c_struct*prt_params%nitr_stoich_p1(pft, prt_params%organ_param_id(struct_organ)) + m_leaf = c_leaf*prt_params%nitr_stoich_p1(pft, prt_params%organ_param_id(leaf_organ)) + m_fnrt = c_fnrt*prt_params%nitr_stoich_p1(pft, prt_params%organ_param_id(fnrt_organ)) + m_sapw = c_sapw*prt_params%nitr_stoich_p1(pft, prt_params%organ_param_id(sapw_organ)) + m_repro = 0.0_r8 + m_store = StorageNutrientTarget(pft, element_id, m_leaf, m_fnrt, m_sapw, m_struct) + case(phosphorus_element) + m_struct = c_struct*prt_params%phos_stoich_p1(pft, prt_params%organ_param_id(struct_organ)) + m_leaf = c_leaf*prt_params%phos_stoich_p1(pft, prt_params%organ_param_id(leaf_organ)) + m_fnrt = c_fnrt*prt_params%phos_stoich_p1(pft, prt_params%organ_param_id(fnrt_organ)) + m_sapw = c_sapw*prt_params%phos_stoich_p1(pft, prt_params%organ_param_id(sapw_organ)) + m_repro = 0.0_r8 + m_store = StorageNutrientTarget(pft, element_id, m_leaf, m_fnrt, m_sapw, m_struct) + + end select + + select case(hlm_parteh_mode) + + case (prt_carbon_allom_hyp, prt_cnp_flex_allom_hyp) + ! Put all of the leaf mass into the first bin + call SetState(prt, leaf_organ, element_id, m_leaf, 1) + do iage = 2, nleafage + call SetState(prt, leaf_organ, element_id, 0.0_r8, iage) + end do + call SetState(prt, fnrt_organ, element_id, m_fnrt) + call SetState(prt, sapw_organ, element_id, m_sapw) + call SetState(prt, store_organ, element_id, m_store) + call SetState(prt, struct_organ, element_id, m_struct) + call SetState(prt, repro_organ, element_id, m_repro) + + case default + write(fates_log(),*) 'Unspecified PARTEH module' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end select + + end do + + call prt%CheckInitialConditions() + + end subroutine PRTFactory + + !--------------------------------------------------------------------------------------- + + subroutine CohortFactory(cohort, pft, can_lai, dbh, number, crown_damage, status, age, & + canopy_trim, canopy_layer, elong_factor, patch_area) + ! + ! DESCRIPTION: + ! Create a FATES cohort + ! + + ! ARGUMENTS + type(fates_cohort_type), target, intent(out) :: cohort ! cohort object + integer, intent(in) :: pft ! plant functional type index + real(r8), intent(in) :: can_lai(:) ! canopy lai of patch that cohort is on [m2/m2] + real(r8), intent(in), optional :: dbh ! diameter at breast height [cm] + real(r8), intent(in), optional :: number ! number density [/m2] + integer, intent(in), optional :: crown_damage ! crown damage class + integer, intent(in), optional :: status ! growth status [leaves on/off] + real(r8), intent(in), optional :: age ! age [yr] + real(r8), intent(in), optional :: canopy_trim ! fraction of the maximum leaf biomass + integer, intent(in), optional :: canopy_layer ! canopy layer + real(r8), intent(in), optional :: elong_factor ! site-level elongation factor + real(r8), intent(in), optional :: patch_area ! patch area [m2] + + ! LOCALS: + class(prt_vartypes), pointer :: prt ! PARTEH object + real(r8) :: dbh_local ! local dbh [cm] + real(r8) :: number_local ! local number density [/m2] + integer :: crown_damage_local ! local crown damage + integer :: status_local ! local phenology status + integer :: canopy_layer_local ! local canopy layer + real(r8) :: canopy_trim_local ! local canopy trim + real(r8) :: age_local ! local age [yrs] + real(r8) :: elong_fact_local ! local elongation factor + real(r8) :: patch_area_local ! local patch area [m2] + real(r8) :: height ! height [m] + real(r8) :: can_area ! canopy area [m2] + real(r8) :: c_struct ! structural carbon [kgC] + real(r8) :: c_leaf ! leaf carbon [kgC] + real(r8) :: c_fnrt ! fine root carbon [kgC] + real(r8) :: c_sapw ! sapwood carbon [kgC] + real(r8) :: c_store ! storage carbon [kgC] + real(r8) :: c_agw ! aboveground biomass [kgC] + real(r8) :: c_bgw ! belowground biomass [kgC] + real(r8) :: a_sapw ! sapwood area [m2] + real(r8) :: elongf_leaf ! leaf elongation factor [fraction] + real(r8) :: elongf_fnrt ! fine-root "elongation factor" [fraction] + real(r8) :: elongf_stem ! stem "elongation factor" [fraction] + + ! CONSTANTS: + real(r8), parameter :: dbh_default = 10.0_r8 ! default dbh [cm] + real(r8), parameter :: canopy_trim_default = 1.0_r8 ! default canopy trim + integer, parameter :: crown_damage_default = 1 ! default crown damage + integer, parameter :: status_default = leaves_on ! default status + real(r8), parameter :: age_default = 25.0_r8 ! default age [yrs] + real(r8), parameter :: elong_factor_default = 1.0_r8 ! default elongation factor + integer, parameter :: canopy_layer_default = 1 ! default canopy layer + real(r8), parameter :: patch_area_default = 100.0_r8 ! default patch area [m2] + + ! set local values + if (present(dbh)) then + dbh_local = dbh + else + dbh_local = dbh_default + end if + + if (present(crown_damage)) then + crown_damage_local = crown_damage + else + crown_damage_local = crown_damage_default + end if + + if (present(canopy_trim)) then + canopy_trim_local = canopy_trim + else + canopy_trim_local = canopy_trim_default + end if + + if (present(status)) then + status_local = status + else + status_local = status_default + end if + + if (present(age)) then + age_local = age + else + age_local = age_default + end if + + if (present(elong_factor)) then + elong_fact_local = elong_factor + else + elong_fact_local = elong_factor_default + end if + + if (present(patch_area)) then + patch_area_local = patch_area + else + patch_area_local = patch_area_default + end if + + if (present(canopy_layer)) then + canopy_layer_local = canopy_layer + else + canopy_layer_local = canopy_layer_default + end if + + ! set leaf elongation factors + if (prt_params%season_decid(pft) == itrue .and. status_local == leaves_off) then + elongf_leaf = 0.0_r8 + elongf_fnrt = 1.0_r8 - prt_params%phen_fnrt_drop_fraction(pft) + elongf_stem = 1.0_r8 - prt_params%phen_stem_drop_fraction(pft) + + else if (any(prt_params%stress_decid(pft) == [ihard_stress_decid, isemi_stress_decid])) then + elongf_leaf = elong_fact_local + elongf_fnrt = 1.0_r8 - (1.0_r8 - elongf_leaf)*prt_params%phen_fnrt_drop_fraction(pft) + elongf_stem = 1.0_r8 - (1.0_r8 - elongf_leaf)*prt_params%phen_stem_drop_fraction(pft) + + if (elongf_leaf > 0.0_r8) then + status_local = leaves_on + else + status_local = leaves_off + end if + + else + elongf_leaf = 1.0_r8 + elongf_fnrt = 1.0_r8 + elongf_stem = 1.0_r8 + end if + + ! calculate allometric properties + + ! calculate or set number density + if (present(number)) then + + number_local = number + + else + + call carea_allom(dbh_local, 1.0_r8, init_spread_inventory, pft, crown_damage_local, & + can_area) + + ! calculate initial density required to close the canopy + number_local = patch_area_local/can_area + + end if + + ! calculate leaf biomass + call bleaf(dbh_local, pft, crown_damage_local, canopy_trim_local, elongf_leaf, c_leaf) + + ! recalculate crown area + call carea_allom(dbh_local, number_local, init_spread_inventory, pft, & + crown_damage_local, can_area) + + ! calculate height + call h_allom(dbh_local, pft, height) + + ! calculate total above-ground biomass + call bagw_allom(dbh_local, pft, crown_damage_local, elongf_stem, c_agw) + + ! calculate coarse root biomass + call bbgw_allom(dbh_local, pft, elongf_stem, c_bgw) + + ! fine root biomass from allometry + call bfineroot(dbh_local, pft, canopy_trim_local, prt_params%allom_l2fr(pft), & + elongf_fnrt, c_fnrt) + + ! sapwood biomass + call bsap_allom(dbh_local, pft, crown_damage_local, canopy_trim_local, elongf_stem, & + a_sapw, c_sapw) + + ! structural biomass + call bdead_allom(c_agw, c_bgw, c_sapw, pft, c_struct) + + ! storage biomass + call bstore_allom(dbh_local, pft, crown_damage_local, canopy_trim_local, c_store) + + ! initialize the PRT object + call PRTFactory(prt, pft, c_struct, c_leaf, c_fnrt, c_sapw, c_store) + + ! create the cohort + call cohort%Create(prt, pft, number_local, height, age_local, dbh_local, & + status_local, canopy_trim_local, can_area, canopy_layer_local, crown_damage_local, & + init_spread_inventory, can_lai, elongf_leaf, elongf_fnrt, elongf_stem) + + end subroutine CohortFactory + + !--------------------------------------------------------------------------------------- + + subroutine PatchFactory(patch, age, area, num_swb, num_pft, num_levsoil, & + land_use_label, nocomp_pft, current_tod) + ! + ! DESCRIPTION: + ! Create a fates patch + ! + + ! ARGUMENTS: + type(fates_patch_type), pointer, intent(out) :: patch ! patch object + real(r8), intent(in) :: age ! patch age [yrs] + real(r8), intent(in) :: area ! patch are [m2] + integer, intent(in) :: num_swb ! number of shortwave bands + integer, intent(in) :: num_pft ! number of pfts + integer, intent(in) :: num_levsoil ! number of soil layers + integer, intent(in), optional :: land_use_label ! land use label + integer, intent(in), optional :: nocomp_pft ! nocomp_pft label + integer, intent(in), optional :: current_tod ! time of day [seconds past 0Z] + + ! LOCALS: + integer :: land_use_label_local ! local land use label + integer :: nocomp_pft_local ! local nocomp pft label + integer :: tod_local ! local tod value + + ! CONSTANTS: + integer :: land_use_label_default = primaryland ! default land use label + integer :: nocomp_pft_default = 1 ! default nocomp pft label + integer :: tod_default = 0 ! default time of day + + ! set defaults if necessary + if (present(land_use_label)) then + land_use_label_local = land_use_label + else + land_use_label_local = land_use_label_default + end if + + if (present(nocomp_pft)) then + nocomp_pft_local = nocomp_pft + else + nocomp_pft_local = nocomp_pft_default + end if + + if (present(current_tod)) then + tod_local = current_tod + else + tod_local = tod_default + end if + + allocate(patch) + call patch%Create(age, area, land_use_label_local, nocomp_pft_local, num_swb, & + num_pft, num_levsoil, tod_local, regeneration_model) + + patch%patchno = 1 + patch%younger => null() + patch%older => null() + patch%age_class = get_age_class_index(patch%age) + + end subroutine PatchFactory + + !--------------------------------------------------------------------------------------- + + subroutine GetSyntheticPatch(patch_data, num_levsoil, patch) + ! + ! DESCRIPTION: + ! Create a synthetic patch based on input data + ! + + ! ARGUMETNS: + type(synthetic_patch_type), intent(in) :: patch_data ! synthetic patch data + integer, intent(in) :: num_levsoil ! number of soil layers + type(fates_patch_type), pointer, intent(out) :: patch ! patch + + ! LOCALS: + type(fates_cohort_type), pointer :: cohort ! cohort object + integer :: numpft ! total number of pfts + real(r8) :: can_lai(nclmax) ! canopy lai of plot + real(r8) :: patch_age ! patch age + integer :: i ! looping index + + numpft = size(prt_params%wood_density, dim=1) + patch_age = maxval(patch_data%ages(:)) + can_lai(:) = 0.0_r8 + + ! create the patch + call PatchFactory(patch, patch_age, patch_data%area, num_swb, numpft, num_levsoil) + + ! add cohorts + do i = 1, patch_data%num_cohorts + allocate(cohort) + call CohortFactory(cohort, patch_data%pft_ids(i), can_lai, dbh=patch_data%dbhs(i), & + number=patch_data%densities(i)*patch_data%area, age=patch_data%ages(i), & + canopy_layer=patch_data%canopy_layers(i), patch_area=patch_data%area) + + call patch%InsertCohort(cohort) + + end do + + end subroutine GetSyntheticPatch + + !--------------------------------------------------------------------------------------- + + subroutine CreateTestPatchList(patch, heights, dbhs) + ! + ! DESCRIPTION: + ! Create a patch with a hard-coded cohort linked list + ! Heights are supplied, optional dbhs + ! Used for unit testing + ! + + ! ARGUMENTS: + type(fates_patch_type), intent(out) :: patch ! patch object + real(r8), intent(in) :: heights(:) ! hard-coded heights + real(r8), intent(in), optional :: dbhs(:) ! optional hard-coded dbhs + + ! LOCALS: + type(fates_cohort_type), pointer :: cohort, next_cohort ! cohort objects + integer :: num_cohorts ! number of cohorts to add to list + integer :: i ! looping index + + ! size of heights array must match sie of dbhs, if supplied + if (present(dbhs)) then + if (size(heights) /= size(dbhs)) then + write(*, '(a)') "Size of heights array must match size of dbh array." + stop + end if + end if + + num_cohorts = size(heights) + + ! initialize first cohort + allocate(cohort) + cohort%height = heights(1) + if (present(dbhs)) cohort%dbh = dbhs(1) + patch%shortest => cohort + + ! initialize the rest of the cohorts + do i = 2, num_cohorts + allocate(next_cohort) + next_cohort%height = heights(i) + if (present(dbhs)) next_cohort%dbh = dbhs(i) + cohort%taller => next_cohort + next_cohort%shorter => cohort + cohort => next_cohort + end do + patch%tallest => cohort + + end subroutine CreateTestPatchList + +end module FatesFactoryMod \ No newline at end of file diff --git a/testing/testing_shr/FatesUnitTestParamReaderMod.F90 b/testing/testing_shr/FatesUnitTestParamReaderMod.F90 index 624c98ea68..2a4fb13cd8 100644 --- a/testing/testing_shr/FatesUnitTestParamReaderMod.F90 +++ b/testing/testing_shr/FatesUnitTestParamReaderMod.F90 @@ -10,6 +10,7 @@ module FatesUnitTestParamReaderMod use SFParamsMod, only : SpitFireRegisterParams, SpitFireReceiveParams use PRTInitParamsFatesMod, only : PRTRegisterParams, PRTReceiveParams use PRTParametersMod, only : prt_params + use FatesInterfaceTypesMod, only : nleafage use FatesParameterDerivedMod, only : param_derived use FatesSynchronizedParamsMod, only : FatesSynchronizedParamsInst use EDPftvarcon, only : EDPftvarcon_inst @@ -140,7 +141,9 @@ subroutine RetrieveParameters(this) call fates_pft_params%Destroy() deallocate(fates_params) deallocate(fates_pft_params) - + + nleafage = size(prt_params%leaf_long, dim=2) + ! initialize derived parameters call param_derived%Init(size(prt_params%wood_density, dim=1)) diff --git a/testing/testing_shr/FatesUnitTestUtils.F90 b/testing/testing_shr/FatesUnitTestUtils.F90 new file mode 100644 index 0000000000..26715bd8d9 --- /dev/null +++ b/testing/testing_shr/FatesUnitTestUtils.F90 @@ -0,0 +1,32 @@ +module FatesUnitTestUtils + + ! DESCRIPTION: + ! Miscellaneous methods to aid in unit testing + ! + + implicit none + private + + public :: endrun_msg + +contains + + !--------------------------------------------------------------------------------------- + + function endrun_msg(msg) + ! + ! DESCRIPTION: + ! Gives the message thrown by shr_abort_abort, given a call to endrun(msg) + ! + + ! ARGUMENTS: + character(len=:), allocatable :: endrun_msg ! function result + character(len=*), intent(in) :: msg + + endrun_msg = 'ABORTED: '//trim(msg) + + end function endrun_msg + + !--------------------------------------------------------------------------------------- + +end module FatesUnitTestUtils \ No newline at end of file diff --git a/testing/testing_shr/SyntheticPatchTypes.F90 b/testing/testing_shr/SyntheticPatchTypes.F90 new file mode 100644 index 0000000000..6094f0c6da --- /dev/null +++ b/testing/testing_shr/SyntheticPatchTypes.F90 @@ -0,0 +1,241 @@ +module SyntheticPatchTypes + + ! DESCRIPTION: + ! Methods to create synthetic patch objects + + use FatesConstantsMod, only : r8 => fates_r8 + + implicit none + private + + integer, parameter :: chunk_size = 10 + + ! patch data type to hold data about the synthetic patches + type, public :: synthetic_patch_type + character(len=:), allocatable :: patch_name ! patch name, used for reference + integer :: patch_id ! patch id, used for reference + integer :: num_cohorts ! number of cohorts on patch + real(r8) :: area ! patch area [m2] + real(r8), allocatable :: ages(:) ! cohort ages [yr] + real(r8), allocatable :: dbhs(:) ! cohort dbhs [cm] + real(r8), allocatable :: densities(:) ! cohort densities [/m2] + integer, allocatable :: canopy_layers(:) ! canopy layers + integer, allocatable :: pft_ids(:) ! pft ids + + contains + + procedure :: InitSyntheticPatchData + + end type synthetic_patch_type + + ! -------------------------------------------------------------------------------------- + + ! a class to just hold an array of these synthetic patches + type, public :: synthetic_patch_array_type + + type(synthetic_patch_type), allocatable :: patches(:) ! array of patches + integer :: num_patches ! total number of patches + + contains + + procedure :: AddPatch + procedure :: GetSyntheticPatchData + procedure :: PatchDataPosition + + end type synthetic_patch_array_type + + ! -------------------------------------------------------------------------------------- + + contains + + subroutine InitSyntheticPatchData(this, patch_id, patch_name, area, ages, dbhs, & + densities, pft_ids, canopy_layers) + ! + ! DESCRIPTION: + ! Initializes a synthetic patch with input characteristics + ! + + ! ARGUMENTS: + class(synthetic_patch_type), intent(inout) :: this ! patch data to create + integer, intent(in) :: patch_id ! patch id + character(len=*), intent(in) :: patch_name ! patch name + real(r8), intent(in) :: area ! patch area [m2] + real(r8), intent(in) :: ages(:) ! cohort ages [yr] + real(r8), intent(in) :: dbhs(:) ! cohort dbhs [cm] + real(r8), intent(in) :: densities(:) ! cohort densities [/m2] + integer, intent(in) :: pft_ids(:) ! pft ids + integer, intent(in) :: canopy_layers(:) ! canopy layers of cohorts + + ! LOCALS: + integer :: num_cohorts ! number of cohorts on patch + integer :: i ! looping index + + ! allocate arrays + num_cohorts = size(pft_ids) + + allocate(this%ages(num_cohorts)) + allocate(this%dbhs(num_cohorts)) + allocate(this%densities(num_cohorts)) + allocate(this%pft_ids(num_cohorts)) + allocate(this%canopy_layers(num_cohorts)) + + ! set values + this%patch_name = patch_name + this%num_cohorts = num_cohorts + this%patch_id = patch_id + this%area = area + + do i = 1, num_cohorts + this%ages(i) = ages(i) + this%dbhs(i) = dbhs(i) + this%densities(i) = densities(i) + this%pft_ids(i) = pft_ids(i) + this%canopy_layers(i) = canopy_layers(i) + end do + + end subroutine InitSyntheticPatchData + + ! -------------------------------------------------------------------------------------- + + subroutine AddPatch(this, patch_id, patch_name, area, ages, dbhs, densities, pft_ids, & + canopy_layers) + ! + ! DESCRIPTION: + ! Adds a synthetic patch data to a dynamic array + ! + + ! ARGUMENTS: + class(synthetic_patch_array_type), intent(inout) :: this ! array of synthetic patches + integer, intent(in) :: patch_id ! patch id + character(len=*), intent(in) :: patch_name ! name of patch + real(r8), intent(in) :: area ! patch area + real(r8), intent(in) :: ages(:) ! cohort ages [yr] + real(r8), intent(in) :: dbhs(:) ! cohort dbhs [cm] + real(r8), intent(in) :: densities(:) ! cohort densities [/m2] + integer, intent(in) :: pft_ids(:) ! pft ids + integer, intent(in) :: canopy_layers(:) ! canopy layers + + ! LOCALS: + type(synthetic_patch_type) :: patch_data ! synthetic patch data + type(synthetic_patch_type), allocatable :: temporary_array(:) ! temporary array to hold data while re-allocating + + ! first make sure we have enough space in the array + if (allocated(this%patches)) then + ! already allocated to some size + if (this%num_patches == size(this%patches)) then + ! need to add more space + allocate(temporary_array(size(this%patches) + chunk_size)) + temporary_array(1:size(this%patches)) = this%patches + call move_alloc(temporary_array, this%patches) + end if + + this%num_patches = this%num_patches + 1 + + else + ! first element in array + allocate(this%patches(chunk_size)) + this%num_patches = 1 + end if + + call patch_data%InitSyntheticPatchData(patch_id, patch_name, area, ages, dbhs, & + densities, pft_ids, canopy_layers) + + this%patches(this%num_patches) = patch_data + + end subroutine AddPatch + + ! -------------------------------------------------------------------------------------- + + integer function PatchDataPosition(this, patch_id, patch_name) + ! + ! DESCRIPTION: + ! Returns the index of a desired synthetic patch data + ! + + ! ARGUMENTS: + class(synthetic_patch_array_type), intent(in) :: this ! array of patch data + integer, intent(in), optional :: patch_id ! desired patch id + character(len=*), intent(in), optional :: patch_name ! desired patch name + + ! LOCALS: + integer :: i ! looping index + + ! can't supply both + if (present(patch_id) .and. present(patch_name)) then + write(*, '(a)') "Can only supply either a patch_id or a patch_name - not both" + stop + end if + + do i = 1, this%num_patches + if (present(patch_id)) then + if (this%patches(i)%patch_id == patch_id) then + PatchDataPosition = i + return + end if + else if (present(patch_name)) then + if (this%patches(i)%patch_name == patch_name) then + PatchDataPosition = i + return + end if + else + write(*, '(a)') "Must supply either a patch_id or a patch_name." + stop + end if + end do + write(*, '(a)') "Cannot find the synthetic patch type supplied" + stop + + end function PatchDataPosition + + ! -------------------------------------------------------------------------------------- + + subroutine GetSyntheticPatchData(this) + ! + ! DESCRIPTION: + ! Returns an array of hard-coded synthetic patch data + ! + ! + + ! ARGUMENTS: + class(synthetic_patch_array_type), intent(inout) :: this ! array of synthetic patches + + call this%AddPatch(patch_id=1, patch_name='tropical', area=500.0_r8, & + ages=(/100.0_r8, 80.0_r8, 40.0_r8, 20.0_r8/), & + dbhs=(/60.0_r8, 50.0_r8, 25.0_r8, 10.0_r8/), & + densities=(/0.005_r8, 0.008_r8, 0.02_r8, 0.017_r8/), & + pft_ids=(/1, 1, 1, 1/), & + canopy_layers=(/1, 1, 2, 2/)) + + call this%AddPatch(patch_id=2, patch_name='evergreen', area=500.0_r8, & + ages=(/50.0_r8, 50.0_r8/), & + dbhs=(/30.0_r8, 25.0_r8/), & + densities=(/0.015_r8, 0.015_r8/), & + pft_ids=(/2, 2/), & + canopy_layers=(/1, 1/)) + + call this%AddPatch(patch_id=3, patch_name='savannah', area=500.0_r8, & + ages=(/20.0_r8, 1.0_r8/), & + dbhs=(/15.0_r8, 1.0_r8/), & + densities=(/0.015_r8, 0.015_r8/), & + pft_ids=(/5, 14/), & + canopy_layers=(/1, 2/)) + + call this%AddPatch(patch_id=4, patch_name='grassland', area=500.0_r8, & + ages=(/1.0_r8, 2.0_r8/), & + dbhs=(/1.0_r8, 1.0_r8/), & + densities=(/0.015_r8, 0.015_r8/), & + pft_ids=(/13, 13/), & + canopy_layers=(/1, 1/)) + + call this%AddPatch(patch_id=5, patch_name='temperate', area=500.0_r8, & + ages=(/80.0_r8, 50.0_r8, 20.0_r8, 5.0_r8/), & + dbhs=(/50.0_r8, 30.0_r8, 15.0_r8, 3.0_r8/), & + densities=(/0.005_r8, 0.01_r8, 0.015_r8, 0.005_r8/), & + pft_ids=(/6, 2, 2, 9/), & + canopy_layers=(/1, 1, 2, 2/)) + + end subroutine GetSyntheticPatchData + + ! -------------------------------------------------------------------------------------- + +end module SyntheticPatchTypes diff --git a/testing/unit_testing/count_cohorts_test/CMakeLists.txt b/testing/unit_testing/count_cohorts_test/CMakeLists.txt new file mode 100644 index 0000000000..8646dadc92 --- /dev/null +++ b/testing/unit_testing/count_cohorts_test/CMakeLists.txt @@ -0,0 +1,6 @@ +set(pfunit_sources test_CountCohorts.pf) + +add_pfunit_ctest(CountCohorts + TEST_SOURCES "${pfunit_sources}" + LINK_LIBRARIES fates csm_share) + \ No newline at end of file diff --git a/testing/unit_testing/count_cohorts_test/test_CountCohorts.pf b/testing/unit_testing/count_cohorts_test/test_CountCohorts.pf new file mode 100644 index 0000000000..a227615130 --- /dev/null +++ b/testing/unit_testing/count_cohorts_test/test_CountCohorts.pf @@ -0,0 +1,112 @@ +module test_CountCohorts + ! + ! DESCRIPTION: + ! Tests the patch's CountCohorts method + ! + use FatesConstantsMod, only : r8 => fates_r8 + use FatesCohortMod, only : fates_cohort_type + use FatesPatchMod, only : fates_patch_type + use FatesFactoryMod, only : CreateTestPatchList + use funit + + implicit none + + @TestCase + type, extends(TestCase) :: TestCountCohorts + end type TestCountCohorts + + contains + + @Test + subroutine EmptyList_CountCohorts_GivesZero(this) + ! tests that for a patch with an empty list num_cohorts is 0 + class(TestCountCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + integer, parameter :: expected_cohorts = 0 ! expected number of cohorts + + ! create an empty patch + patch%shortest => null() + patch%tallest => null() + + ! count cohorts + call patch%CountCohorts() + + @assertEqual(patch%num_cohorts, expected_cohorts) + + end subroutine EmptyList_CountCohorts_GivesZero + + @Test + subroutine SingleCohort_CountCohorts_GivesOne(this) + ! tests that for a patch with one cohort, num_cohorts is 1 + class(TestCountCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort ! cohort object + integer, parameter :: expected_cohorts = 1 ! expected number of cohorts + + ! create hard-coded patch + allocate(cohort) + patch%shortest => cohort + patch%tallest => cohort + + ! count cohorts + call patch%CountCohorts() + @assertEqual(patch%num_cohorts, expected_cohorts) + + end subroutine SingleCohort_CountCohorts_GivesOne + + @Test + subroutine SmallList_CountCohorts_GivesEight(this) + ! tests that for a patch with eight cohorts, num_cohorts is 8 + class(TestCountCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort, next_cohort ! cohort objects + integer, parameter :: expected_cohorts = 8 ! expected number of cohorts + integer :: i ! looping index + + + ! create the patch and list + allocate(cohort) + patch%shortest => cohort + do i = 2, expected_cohorts + allocate(next_cohort) + cohort%taller => next_cohort + next_cohort%shorter => cohort + cohort => next_cohort + end do + patch%tallest => cohort + + ! count cohorts + call patch%CountCohorts() + @assertEqual(patch%num_cohorts, expected_cohorts) + + end subroutine SmallList_CountCohorts_GivesEight + + @Test + subroutine LargeList_CountCohorts_GivesOneHundred(this) + ! tests that for a patch with 100 cohorts, num_cohorts is 100 + class(TestCountCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort, next_cohort ! cohort objects + integer, parameter :: expected_cohorts = 100 ! expected number of cohorts + integer :: i ! looping index + + ! create the patch and list + allocate(cohort) + patch%shortest => cohort + do i = 2, expected_cohorts + allocate(next_cohort) + cohort%taller => next_cohort + next_cohort%shorter => cohort + cohort => next_cohort + end do + patch%tallest => cohort + + ! count cohorts + call patch%CountCohorts() + @assertEqual(patch%num_cohorts, expected_cohorts) + + end subroutine LargeList_CountCohorts_GivesOneHundred + +end module test_CountCohorts + + diff --git a/testing/unit_testing/insert_cohort_test/CMakeLists.txt b/testing/unit_testing/insert_cohort_test/CMakeLists.txt new file mode 100644 index 0000000000..d3f35d81c7 --- /dev/null +++ b/testing/unit_testing/insert_cohort_test/CMakeLists.txt @@ -0,0 +1,6 @@ +set(pfunit_sources test_InsertCohort.pf) + +add_pfunit_ctest(InsertCohorts + TEST_SOURCES "${pfunit_sources}" + LINK_LIBRARIES fates csm_share) + \ No newline at end of file diff --git a/testing/unit_testing/insert_cohort_test/test_InsertCohort.pf b/testing/unit_testing/insert_cohort_test/test_InsertCohort.pf new file mode 100644 index 0000000000..36482406a1 --- /dev/null +++ b/testing/unit_testing/insert_cohort_test/test_InsertCohort.pf @@ -0,0 +1,379 @@ +module test_InsertCohort + ! + ! DESCRIPTION: + ! Tests the patch's InsertCohort method + ! + use FatesConstantsMod, only : r8 => fates_r8 + use FatesCohortMod, only : fates_cohort_type + use FatesPatchMod, only : fates_patch_type + use FatesUnitTestUtils, only : endrun_msg + use FatesFactoryMod, only : CreateTestPatchList + use funit + + implicit none + + @TestCase + type, extends(TestCase) :: TestInsertCohort + type(fates_patch_type) :: patch + contains + procedure :: setUp + procedure :: tearDown + end type TestInsertCohort + + contains + + subroutine setUp(this) + class(TestInsertCohort), intent(inout) :: this ! test object + ! heights for cohors + real(r8), parameter :: heights(8) = (/2.0_r8, 5.0_r8, 10.0_r8, 12.0_r8, 12.5_r8, & + 15.0_r8, 20.0_r8, 25.0_r8/) + + ! hard-code a linked list + call CreateTestPatchList(this%patch, heights) + + end subroutine setUp + + subroutine tearDown(this) + class(TestInsertCohort), intent(inout) :: this ! test object + type(fates_cohort_type), pointer :: cohort ! cohort object + type(fates_cohort_type), pointer :: next_cohort ! next cohort object + + ! deallocate cohorts + cohort => this%patch%shortest + do while(associated(cohort)) + next_cohort => cohort%taller + deallocate(cohort) + cohort => next_cohort + end do + + end subroutine tearDown + + @Test + subroutine InsertCohort_EmptyList(this) + ! test that when inserting into an empty list, the new cohort becomes the shortest and tallest + ! and the taller and shorter pointers are null() + class(TestInsertCohort), intent(inout) :: this ! test object + type(fates_patch_type) :: patch + type(fates_cohort_type), pointer :: cohort + + ! create and empty patch + patch%shortest => null() + patch%tallest => null() + + ! insert a new cohort + allocate(cohort) + call patch%InsertCohort(cohort) + + ! verify cohort is shortest and tallest in list + @assertTrue(associated(cohort, patch%tallest)) + @assertTrue(associated(cohort, patch%shortest)) + + ! verify taller and shorter pointers of inserted cohort are null + @assertFalse(associated(cohort%taller)) + @assertFalse(associated(cohort%shorter)) + + end subroutine InsertCohort_EmptyList + + @Test + subroutine InsertCohort_ShortestCohort(this) + ! test that when inserted as the shortest cohort, it is inserted correctly + class(TestInsertCohort), intent(inout) :: this ! test object + type(fates_cohort_type), pointer :: cohort ! cohort object + type(fates_cohort_type), pointer :: previous_shortest ! previous tallest cohort + real(r8), parameter :: height = 1.0_r8 ! hard-coded height + + ! save previous shorter + previous_shortest => this%patch%shortest + + ! insert cohort + allocate(cohort) + cohort%height = height + call this%patch%InsertCohort(cohort) + + ! verify that new cohort is now the shortest + @assertTrue(associated(cohort, this%patch%shortest)) + + ! verify that new new shortest cohort's taller pointer is the previous shortest + @assertTrue(associated(cohort%taller, previous_shortest)) + + ! verify that the previous shortest%shorter now points to cohort + @assertTrue(associated(previous_shortest%shorter, cohort)) + + + end subroutine InsertCohort_ShortestCohort + + @Test + subroutine InsertCohort_TallestCohort(this) + ! test that when inserted as the tallest cohort, it is inserted correctly + class(TestInsertCohort), intent(inout) :: this ! test object + type(fates_cohort_type), pointer :: cohort ! cohort object + type(fates_cohort_type), pointer :: previous_tallest ! previous tallest cohort + real(r8), parameter :: height = 100.0_r8 ! cohort height + + ! save previous shorter + previous_tallest => this%patch%tallest + + ! insert cohort + allocate(cohort) + cohort%height = height + call this%patch%InsertCohort(cohort) + + ! verify that new cohort is now the tallest + @assertTrue(associated(cohort, this%patch%tallest)) + + ! verify that new new tallest cohort's shorter pointer is the previous tallest + @assertTrue(associated(cohort%shorter, previous_tallest)) + + ! verify that that the previous tallest%taller now points to cohort + @assertTrue(associated(previous_tallest%taller, cohort)) + + end subroutine InsertCohort_TallestCohort + + @Test + subroutine InsertCohort_CorrectOrder(this) + ! test that a cohort is inserted correctly into the middle of a list + class(TestInsertCohort), intent(inout) :: this ! test object + type(fates_cohort_type), pointer :: cohort ! cohort object + real(r8), parameter :: height = 16.0_r8 ! cohort height + + ! insert cohort + allocate(cohort) + cohort%height = height + call this%patch%InsertCohort(cohort) + + ! traverse the list to ensure correct order + cohort => this%patch%shortest + do while (associated(cohort%taller)) + @assertLessThanOrEqual(cohort%height, cohort%taller%height) + cohort => cohort%taller + end do + + ! traverse backwards + cohort => this%patch%tallest + do while (associated(cohort%shorter)) + @assertGreaterThanOrEqual(cohort%height, cohort%shorter%height) + cohort => cohort%shorter + end do + + end subroutine InsertCohort_CorrectOrder + + @Test + subroutine InsertCohort_SameHeight(this) + ! test that inserting a cohort with the same height as an existing cohort maintains insertion order + class(TestInsertCohort), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort1 ! first cohort object + type(fates_cohort_type), pointer :: cohort2 ! second cohort object + type(fates_cohort_type), pointer :: cohort3 ! third cohort object + + ! initialize cohorts + allocate(cohort1) + cohort1%height = 10.0_r8 + + allocate(cohort2) + cohort2%height = 15.0_r8 + + allocate(cohort3) + cohort3%height = 10.0_r8 + + ! insert cohorts + call patch%InsertCohort(cohort1) + call patch%InsertCohort(cohort2) + call patch%InsertCohort(cohort3) + + ! validate state of linked list - cohort3 should be after cohort1 + ! cohort1 is still shortest + @assertTrue(associated(patch%shortest, cohort1)) + + ! verify order of cohorts with height 10.0 + @assertTrue(associated(cohort1%taller, cohort3)) + @assertTrue(associated(cohort3%shorter, cohort1)) + + ! verify cohort3 points to cohort2 as taller + @assertTrue(associated(cohort3%taller, cohort2)) + @assertTrue(associated(cohort2%shorter, cohort3)) + + ! tallest cohort is still cohort2 + @assertTrue(associated(patch%tallest, cohort2)) + + end subroutine InsertCohort_SameHeight + + @Test + subroutine InsertCohort_SmallList(this) + ! test inserting many cohorts into a list and it is ordered correctly + class(TestInsertCohort), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort ! cohort object + integer :: i ! looping index + + ! heights for cohorts + real(r8), parameter :: heights(10) = (/12.0_r8, 5.0_r8, 20.0_r8, 7.0_r8, 15.0_r8, & + 3.0_r8, 25.0_r8, 10.0_r8, 8.0_r8, 30.0_r8/) + + real(r8), parameter :: heights_sorted(10) = (/3.0_r8, 5.0_r8, 7.0_r8, 8.0_r8, & + 10.0_r8, 12.0_r8, 15.0_r8, 20.0_r8, 25.0_r8, 30.0_r8/) + + ! insert cohorts of varrying heights + do i = 1, size(heights) + allocate(cohort) + cohort%height = heights(i) + call patch%InsertCohort(cohort) + end do + + ! validate final list structure + + ! traverse list from shortest to tallest first + cohort => patch%shortest + do i = 1, size(heights) + @assertTrue(associated(cohort)) + @assertEqual(cohort%height, heights_sorted(i)) + if (i < size(heights)) then + @assertTrue(associated(cohort%taller)) + cohort => cohort%taller + else + @assertFalse(associated(cohort%taller)) + end if + end do + + ! traverse list tallest to shortest + cohort => patch%tallest + do i = size(heights), 1, -1 + @assertTrue(associated(cohort)) + @assertEqual(cohort%height, heights_sorted(i)) + if (i > 1) then + @assertTrue(associated(cohort%shorter)) + cohort => cohort%shorter + else + @assertFalse(associated(cohort%shorter)) + end if + end do + + end subroutine InsertCohort_SmallList + + @Test + subroutine InsertCohort_SmallList_IdenticalHeights(this) + ! test inserting many cohorts of the same height into a list and it is ordered correctly + class(TestInsertCohort), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort ! cohort object + integer :: i ! looping index + real(r8) :: dbh ! cohort diameter + real(r8), parameter :: height = 35.0_r8 ! cohort height + + ! insert cohorts of same height + do i = 1, 10 + allocate(cohort) + cohort%height = height + cohort%dbh = i + call patch%InsertCohort(cohort) + end do + + ! validate final list structure + + ! test that order is correct + i = 1 + cohort => patch%shortest + do while(associated(cohort)) + dbh = float(i) + @assertEqual(cohort%dbh, dbh) + cohort => cohort%taller + i = i + 1 + end do + + end subroutine InsertCohort_SmallList_IdenticalHeights + + @Test + subroutine InsertCohort_Unassociated_Errors(this) + ! test inserting an unassociated cohort errors + class(TestInsertCohort), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort ! cohort object + character(len=:), allocatable :: expected_msg ! expected error message for failure + + expected_msg = endrun_msg("cohort is not allocated") + + ! make sure cohort is null + cohort => null() + + ! try to insert, should fail + call patch%InsertCohort(cohort) + @assertExceptionRaised(expected_msg) + + end subroutine InsertCohort_Unassociated_Errors + + @Test + subroutine InsertCohort_InconsistentListState_Errors(this) + ! test inserting a cohort into an inconsistent list state errors + class(TestInsertCohort), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort, new_cohort ! cohort objects + character(len=:), allocatable :: expected_msg ! expected error message for failure + + expected_msg = endrun_msg("inconsistent list state") + + ! allocate and link one cohort incorrectly + allocate(cohort) + cohort%height = 5.0_r8 + patch%shortest => cohort + + ! allocate a new cohort and try to insert + allocate(new_cohort) + new_cohort%height = 10.0_r8 + + ! should fail + call patch%InsertCohort(new_cohort) + @assertExceptionRaised(expected_msg) + + ! try the opposite + patch%shortest => null() + patch%tallest => cohort + + call patch%InsertCohort(new_cohort) + @assertExceptionRaised(expected_msg) + + end subroutine InsertCohort_InconsistentListState_Errors + + @Test + subroutine InsertCohort_CorruptedListStructure_Errors(this) + ! tests that inserting a cohort into a currupted list structure errors + class(TestInsertCohort), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort1, cohort2, cohort3 ! cohorts + type(fates_cohort_type), pointer :: new_cohort ! cohort to insert + character(len=:), allocatable :: expected_msg ! expected error message for failure + + expected_msg = endrun_msg("corrupted list structure") + + ! allocate and link cohorts + allocate(cohort1) + allocate(cohort2) + allocate(cohort3) + cohort1%height = 1.0_r8 + cohort2%height = 2.0_r8 + cohort3%height = 4.0_r8 + + ! set up a list + patch%shortest => cohort1 + patch%tallest => cohort3 + + cohort1%taller => cohort2 + cohort2%shorter => cohort1 + cohort2%taller => cohort3 + cohort3%shorter => cohort2 + + ! break shorter chain + nullify(cohort2%shorter)! breaks backwards link + + ! allocate a new cohort to insert + allocate(new_cohort) + new_cohort%height = 3.0_r8 + + ! should fail + call patch%InsertCohort(new_cohort) + @assertExceptionRaised(expected_msg) + + end subroutine InsertCohort_CorruptedListStructure_Errors + +end module test_InsertCohort + + diff --git a/testing/unit_testing/sort_cohorts_test/CMakeLists.txt b/testing/unit_testing/sort_cohorts_test/CMakeLists.txt new file mode 100644 index 0000000000..cc05afae40 --- /dev/null +++ b/testing/unit_testing/sort_cohorts_test/CMakeLists.txt @@ -0,0 +1,6 @@ +set(pfunit_sources test_SortCohorts.pf) + +add_pfunit_ctest(SortCohorts + TEST_SOURCES "${pfunit_sources}" + LINK_LIBRARIES fates csm_share) + \ No newline at end of file diff --git a/testing/unit_testing/sort_cohorts_test/test_SortCohorts.pf b/testing/unit_testing/sort_cohorts_test/test_SortCohorts.pf new file mode 100644 index 0000000000..9ee33910f3 --- /dev/null +++ b/testing/unit_testing/sort_cohorts_test/test_SortCohorts.pf @@ -0,0 +1,282 @@ +module test_SortCohorts + ! + ! DESCRIPTION: + ! Tests the patche's SortCohorts method + ! + use FatesConstantsMod, only : r8 => fates_r8 + use FatesCohortMod, only : fates_cohort_type + use FatesPatchMod, only : fates_patch_type + use FatesUnitTestUtils, only : endrun_msg + use FatesFactoryMod, only : CreateTestPatchList + use funit + + implicit none + + @TestCase + type, extends(TestCase) :: TestSortCohorts + end type TestSortCohorts + + contains + + @Test + subroutine EmptyList_SortCohorts_Passes(this) + ! test that for an empty list - sortcohorts does not error + class(TestSortCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + + ! sort cohorts - should pass + call patch%SortCohorts() + + end subroutine EmptyList_SortCohorts_Passes + + @Test + subroutine TwoCohorts_AscendingOrder_Unchanged(this) + ! test that for a hard-coded list in ascending order is sorted, the order remains unchanged + class(TestSortCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch objects + type(fates_cohort_type), pointer :: cohort ! cohort object + real(r8) :: heights(2) = (/2.0_r8, 5.0_r8/) ! hard-coded cohort heights + integer :: i ! looping index + + ! create a hardcoded doubly linked list + call CreateTestPatchList(patch, heights) + + ! sort cohorts + call patch%SortCohorts() + + ! test that the order is correct + i = 1 + cohort => patch%shortest + do while (associated(cohort)) + @assertEqual(heights(i), cohort%height) + cohort => cohort%taller + i = i + 1 + end do + + end subroutine TwoCohorts_AscendingOrder_Unchanged + + @Test + subroutine TwoCohorts_DescendingOrder_Reversed(this) + ! test that for a hard-coded list in descending order is sorted, the order is reversed + class(TestSortCohorts), intent(inout) :: this ! patch test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort ! cohort object + real(r8) :: heights(2) = (/5.0_r8, 2.0_r8/) ! hard-coded cohort heights + integer :: i ! looping index + + ! create a hardcoded doubly linked list + call CreateTestPatchList(patch, heights) + + ! sort cohorts + call patch%SortCohorts() + + ! test that the order is correct + i = size(heights) + cohort => patch%shortest + do while (associated(cohort)) + @assertEqual(cohort%height, heights(i)) + cohort => cohort%taller + i = i - 1 + end do + + end subroutine TwoCohorts_DescendingOrder_Reversed + + @Test + subroutine SmallList_AscendingOrder_Unchanged(this) + ! test that for a hard-coded list in ascending order is sorted, the order remains unchanged + class(TestSortCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort ! cohort object + integer :: i ! looping index + + ! hard-coded heights + real(r8) :: heights(8) = (/2.0_r8, 5.0_r8, 10.0_r8, 12.0_r8, 12.5_r8, 12.5001_r8, 20.0_r8, 25.0_r8/) + + ! create a hardcoded doubly linked list + call CreateTestPatchList(patch, heights) + + ! sort cohorts + call patch%SortCohorts() + + ! test that the order is correct + i = 1 + cohort => patch%shortest + do while (associated(cohort)) + @assertEqual(cohort%height, heights(i)) + cohort => cohort%taller + i = i + 1 + end do + + end subroutine SmallList_AscendingOrder_Unchanged + + @Test + subroutine SmallList_DescendingOrder_Reversed(this) + ! test that for a hard-coded list in descending order is sorted, the order remains unchanged + class(TestSortCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort ! cohort object + integer :: i ! looping index + ! hard-coded heights + real(r8) :: heights(8) = (/25.0_r8, 20.0_r8, 12.5001_r8, 12.5_r8, 12.0_r8, 10.0_r8, 5.0_r8, 2.0_r8/) + + ! create a hardcoded doubly linked list + call CreateTestPatchList(patch, heights) + + ! sort cohorts + call patch%SortCohorts() + + ! test that the order is correct + i = size(heights) + cohort => patch%shortest + do while (associated(cohort)) + @assertEqual(cohort%height, heights(i)) + cohort => cohort%taller + i = i - 1 + end do + + end subroutine SmallList_DescendingOrder_Reversed + + @Test + subroutine SmallList_UnsortedOrder_SortedCorrectly(this) + ! test that a small list in unsorted order is sorted correctly + class(TestSortCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort ! cohort object + integer :: i ! looping index + + ! hard-coded heights + real(r8) :: heights(8) = (/10.0_r8, 100.0_r8, 15.0_r8, 2.0_r8, 1.0_r8, 12.5001_r8, 20.0_r8, 0.5_r8/) + + ! create a hardcoded doubly linked list + call CreateTestPatchList(patch, heights) + + ! sort cohorts + call patch%SortCohorts() + + ! check backwards and forwards + cohort => patch%shortest + do while (associated(cohort)) + if (associated(cohort%taller)) then + @assertGreaterThanOrEqual(cohort%taller%height, cohort%height) + end if + cohort => cohort%taller + end do + + cohort => patch%tallest + do while (associated(cohort)) + if (associated(cohort%shorter)) then + @assertGreaterThanOrEqual(cohort%height, cohort%shorter%height) + end if + cohort => cohort%shorter + end do + + end subroutine SmallList_UnsortedOrder_SortedCorrectly + + @Test + subroutine TwoCohorts_IdenticalHeights_CorrectOrder(this) + ! test that when a list of two cohorts of identical heights is sorted the order remains unchanged + class(TestSortCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort ! cohort object + real(r8), parameter :: dbhs(2) = (/1.0_r8, 2.0_r8/) ! hard-coded dbhs + real(r8), parameter :: heights(2) = (/5.0_r8, 5.0_r8/) ! hard-coded heights + integer :: i ! looping index + + ! create a hardcoded doubly linked list + call CreateTestPatchList(patch, heights, dbhs=dbhs) + + ! sort cohorts + call patch%SortCohorts() + + ! test that the order is correct + i = 1 + cohort => patch%shortest + do while (associated(cohort)) + @assertEqual(cohort%dbh, dbhs(i)) + cohort => cohort%taller + i = i + 1 + end do + + end subroutine TwoCohorts_IdenticalHeights_CorrectOrder + + @Test + subroutine SmallList_IdenticalHeights_CorrectOrder(this) + ! test that when a small list of cohorts of identical heights is sorted the order remains unchanged + class(TestSortCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort ! cohort object + real(r8), allocatable :: heights(:), dbhs(:) ! hard-coded dbhs and heights + real(r8) :: dbh ! dbh to test against + integer :: i ! looping index + real(r8), parameter :: height = 10.0_r8 ! hard-coded height + integer, parameter :: num_cohorts = 8 ! number of cohorts to put in list + + ! create dbh and height arrays + allocate(dbhs(num_cohorts)) + allocate(heights(num_cohorts)) + do i = 1, num_cohorts + dbhs(i) = i + heights(i) = height + end do + + ! create a hardcoded doubly linked list + call CreateTestPatchList(patch, heights, dbhs=dbhs) + + ! sort cohorts + call patch%SortCohorts() + + ! test that the order is correct + i = 1 + cohort => patch%shortest + do while (associated(cohort)) + dbh = float(i) + @assertEqual(cohort%dbh, dbh) + cohort => cohort%taller + i = i + 1 + end do + + end subroutine SmallList_IdenticalHeights_CorrectOrder + + @Test + subroutine SortCohorts_InconsistentListState_Errors(this) + ! test that sorting an inconsistent list state errors + class(TestSortCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort1, cohort2, cohort3 ! cohorts + character(len=:), allocatable :: expected_msg ! expected error message for failure + + expected_msg = endrun_msg("inconsistent list state") + + ! Allocate cohorts + allocate(cohort1) + allocate(cohort2) + allocate(cohort3) + + ! initialize heights + cohort1%height = 2.0 + cohort2%height = 1.5 + cohort3%height = 3.0 + + ! set up a corrupted list + patch%shortest => cohort1 + ! omit setting patch%tallest + cohort1%taller => cohort2 + cohort2%shorter => cohort1 + cohort2%taller => cohort3 + cohort3%shorter => cohort2 + + ! should fail + call patch%SortCohorts() + @assertExceptionRaised(expected_msg) + + ! try the opposite + patch%shortest => null() + patch%tallest => cohort3 + + ! should also fail + call patch%SortCohorts() + @assertExceptionRaised(expected_msg) + + end subroutine SortCohorts_InconsistentListState_Errors + +end module test_SortCohorts diff --git a/testing/unit_testing/validate_cohorts_test/CMakeLists.txt b/testing/unit_testing/validate_cohorts_test/CMakeLists.txt new file mode 100644 index 0000000000..b1dbe30408 --- /dev/null +++ b/testing/unit_testing/validate_cohorts_test/CMakeLists.txt @@ -0,0 +1,6 @@ +set(pfunit_sources test_ValidateCohorts.pf) + +add_pfunit_ctest(ValidateCohorts + TEST_SOURCES "${pfunit_sources}" + LINK_LIBRARIES fates csm_share) + \ No newline at end of file diff --git a/testing/unit_testing/validate_cohorts_test/test_ValidateCohorts.pf b/testing/unit_testing/validate_cohorts_test/test_ValidateCohorts.pf new file mode 100644 index 0000000000..f1fe695fce --- /dev/null +++ b/testing/unit_testing/validate_cohorts_test/test_ValidateCohorts.pf @@ -0,0 +1,246 @@ +module test_ValidateCohorts + ! + ! DESCRIPTION: + ! Tests the patch's ValidateCohorts method + ! + use FatesConstantsMod, only : r8 => fates_r8 + use FatesCohortMod, only : fates_cohort_type + use FatesPatchMod, only : fates_patch_type + use FatesUnitTestUtils, only : endrun_msg + use FatesFactoryMod, only : CreateTestPatchList + use funit + + implicit none + + @TestCase + type, extends(TestCase) :: TestValidateCohorts + end type TestValidateCohorts + + real(r8), parameter :: tol = 1.e-13_r8 + + contains + + @Test + subroutine EmptyList_ValidateCohorts_Returns(this) + ! tests that for a patch where shortest and tallest are null, subroutine returns without error + class(TestValidateCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + + ! create an empty patch + patch%shortest => null() + patch%tallest => null() + + ! should pass + call patch%ValidateCohorts() + + end subroutine EmptyList_ValidateCohorts_Returns + + @Test + subroutine SingleCohort_ValidateCohorts_Returns(this) + ! tests that for a single-cohort list, subroutine returns without error + class(TestValidateCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort ! cohort object + real(r8), parameter :: height = 10.0_r8 ! cohort height + + ! create hard-coded patch + allocate(cohort) + cohort%height = height + patch%shortest => cohort + patch%tallest => cohort + + ! should pass + call patch%ValidateCohorts() + + end subroutine SingleCohort_ValidateCohorts_Returns + + @Test + subroutine MultipleCohorts_ValidateCohorts_Returns(this) + ! tests that for a patch with multiple cohorts correctly linked, subroutine returns without error + class(TestValidateCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: new_node, head ! cohort objects + + ! heights for cohors + real(r8), parameter :: heights(8) = (/2.0_r8, 5.0_r8, 10.0_r8, 12.0_r8, 12.5_r8, & + 15.0_r8, 20.0_r8, 25.0_r8/) + + ! create a hard-coded test patch + call CreateTestPatchList(patch, heights) + + ! should pass + call patch%ValidateCohorts() + + end subroutine MultipleCohorts_ValidateCohorts_Returns + + @Test + subroutine ShortestNull_ValidateCohorts_Errors(this) + + ! tests that for a patch where only shortest is null, the subroutine errors correctly + class(TestValidateCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort ! cohort object + character(len=:), allocatable :: expected_msg ! expected error message for failure + + expected_msg = endrun_msg("one of shortest or tallest is null") + + ! allocate and link one cohort incorrectly + allocate(cohort) + patch%shortest => cohort + + ! should fail + call patch%ValidateCohorts() + @assertExceptionRaised(expected_msg) + + end subroutine ShortestNull_ValidateCohorts_Errors + + @Test + subroutine BrokenLink_ValidateCohorts_Errors(this) + ! tests that for a patch with a broken link the subroutine errors correctly + class(TestValidateCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort1, cohort2, cohort3 ! cohorts + character(len=:), allocatable :: expected_msg ! expected error message for failure + + expected_msg = endrun_msg("mismatch in patch's taller chain") + + ! allocate and link cohorts + allocate(cohort1) + allocate(cohort2) + allocate(cohort3) + + ! set up a list + patch%shortest => cohort1 + patch%tallest => cohort3 + + cohort1%taller => cohort2 + cohort2%shorter => cohort1 + cohort2%taller => cohort3 + cohort3%shorter => cohort2 + + ! break shorter chain + cohort2%shorter => cohort3 ! breaks backwards link + + ! should fail + call patch%ValidateCohorts() + @assertExceptionRaised(expected_msg) + + end subroutine BrokenLink_ValidateCohorts_Errors + + @Test + subroutine BrokenTallest_ValidateCohorts_Errors(this) + ! tests that for a patch that does not end with tallest the subroutine errors correctly + class(TestValidateCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort1, cohort2, cohort3 ! cohorts + character(len=:), allocatable :: expected_msg ! expected error message for failure + + expected_msg = endrun_msg("cohort list does not end at tallest") + + ! allocate and link cohorts + allocate(cohort1) + allocate(cohort2) + allocate(cohort3) + + ! set up a list + patch%shortest => cohort1 + patch%tallest => cohort3 + + cohort1%taller => cohort2 + cohort2%shorter => cohort1 + cohort2%taller => cohort3 + cohort3%shorter => cohort2 + + ! break the list + cohort2%taller => null() + + ! should fail + call patch%ValidateCohorts() + @assertExceptionRaised(expected_msg) + + end subroutine BrokenTallest_ValidateCohorts_Errors + + @Test + subroutine BrokenShortest_ValidateCohorts_Errors(this) + ! tests that for a patch that does not start with shortest the subroutine errors correctly + class(TestValidateCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort1, cohort2, cohort3 ! cohorts + character(len=:), allocatable :: expected_msg ! expected error message for failure + + expected_msg = endrun_msg("cohort list does not start at shortest") + + ! allocate and link cohorts + allocate(cohort1) + allocate(cohort2) + allocate(cohort3) + + ! set up a list + patch%shortest => cohort1 + patch%tallest => cohort3 + + cohort1%taller => cohort2 + cohort2%shorter => cohort1 + cohort2%taller => cohort3 + cohort3%shorter => cohort2 + + ! break the list + patch%shortest => cohort2 + + ! should fail + call patch%ValidateCohorts() + @assertExceptionRaised(expected_msg) + + end subroutine BrokenShortest_ValidateCohorts_Errors + + @Test + subroutine TestLargeLinkedList_ValidateCohorts(this) + ! test the ValidateCohorts subroutine with a large linked list of cohorts. + class(TestValidateCohorts), intent(inout) :: this ! test object + type(fates_patch_type) :: patch ! patch object + type(fates_cohort_type), pointer :: cohort ! cohort object + type(fates_cohort_type), pointer :: next_cohort ! next cohort object + integer :: forward_count ! forward count of cohorts + integer :: backward_count ! backwards counts of cohorts + integer :: i ! looping index + integer, parameter :: num_cohorts = 1000 ! number of cohorts to create + + ! create the patch and list + allocate(cohort) + patch%shortest => cohort + do i = 2, num_cohorts + allocate(next_cohort) + cohort%taller => next_cohort + next_cohort%shorter => cohort + cohort => next_cohort + end do + patch%tallest => cohort + + ! should pass + call patch%ValidateCohorts() + + ! Count forward and backward links for confirmation + forward_count = 0 + backward_count = 0 + + ! Traverse the taller chain + cohort => patch%shortest + do while (associated(cohort)) + forward_count = forward_count + 1 + cohort => cohort%taller + end do + + ! Traverse the shorter chain + cohort => patch%tallest + do while (associated(cohort)) + backward_count = backward_count + 1 + cohort => cohort%shorter + end do + + ! assert that forward and backward counts match and are correct + @assertEqual(forward_count, num_cohorts) + @assertEqual(backward_count, num_cohorts) + + end subroutine TestLargeLinkedList_ValidateCohorts + +end module test_ValidateCohorts diff --git a/testing/unit_tests.cfg b/testing/unit_tests.cfg index 179b924735..1827ec0604 100644 --- a/testing/unit_tests.cfg +++ b/testing/unit_tests.cfg @@ -3,3 +3,17 @@ test_dir = fates_fire_weather_utest [fire_fuel] test_dir = fates_fire_fuel_utest + +[sort_cohorts] +test_dir = fates_sort_cohorts_utest + +[insert_cohort] +test_dir = fates_insert_cohort_utest + +[validate_cohorts] +test_dir = fates_validate_cohorts_utest + +[count_cohorts] +test_dir = fates_count_cohorts_utest + +