From 4d31bda3caf0a2c330a6c1b5ec0f7500115171fc Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sat, 28 Dec 2024 16:06:43 -0500 Subject: [PATCH 1/7] removed instances of iterating patch indices and replaced with usage of cpatch%patchno (which uses a function call to define) --- biogeochem/EDCanopyStructureMod.F90 | 17 +++++------ biogeochem/EDPatchDynamicsMod.F90 | 25 ++++++---------- biogeochem/EDPhysiologyMod.F90 | 11 +------- biogeochem/FatesSoilBGCFluxMod.F90 | 33 +++++++++++----------- biogeophys/EDAccumulateFluxesMod.F90 | 10 +++---- biogeophys/EDBtranMod.F90 | 11 ++++---- biogeophys/FatesPlantHydraulicsMod.F90 | 8 +++--- biogeophys/FatesPlantRespPhotosynthMod.F90 | 6 ++-- main/FatesHistoryInterfaceMod.F90 | 22 ++------------- main/FatesInterfaceMod.F90 | 14 ++++----- main/FatesInterfaceTypesMod.F90 | 2 +- 11 files changed, 62 insertions(+), 97 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index e859a7339f..3d610fcf5c 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -31,6 +31,7 @@ module EDCanopyStructureMod use EDtypesMod , only : AREA use EDLoggingMortalityMod , only : UpdateHarvestC use FatesGlobals , only : endrun => fates_endrun + use FatesInterfaceTypesMod , only : hlm_patchi use FatesInterfaceTypesMod , only : hlm_days_per_year use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking @@ -1897,7 +1898,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) do s = 1,nsites - ifp = 0 + ifp = hlm_patchi total_patch_area = 0._r8 total_canopy_area = 0._r8 bc_out(s)%canopy_fraction_pa(:) = 0._r8 @@ -1909,9 +1910,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) c = fcolumn(s) do while(associated(currentPatch)) - if(currentPatch%nocomp_pft_label.ne.nocomp_bareground)then ! ignore the bare-ground-PFT patch entirely for these BC outs - - ifp = ifp+1 + if_bare: if(currentPatch%nocomp_pft_label.ne.nocomp_bareground)then ! ignore the bare-ground-PFT patch entirely for these BC outs if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then if(debug)then @@ -2029,7 +2028,10 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) total_patch_area = total_patch_area + currentPatch%area/AREA - end if + end if if_bare + + ifp = ifp + 1 + currentPatch => currentPatch%younger end do @@ -2049,13 +2051,12 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) end if currentPatch => sites(s)%oldest_patch - ifp = 0 + ifp = hlm_patchi do while(associated(currentPatch)) if(currentPatch%nocomp_pft_label.ne.nocomp_bareground)then ! for vegetated patches only - ifp = ifp+1 bc_out(s)%canopy_fraction_pa(ifp) = bc_out(s)%canopy_fraction_pa(ifp)/total_patch_area endif ! veg patch - + ifp = ifp + 1 currentPatch => currentPatch%younger end do diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 9b02c9e14a..32dcb0941d 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -45,6 +45,7 @@ module EDPatchDynamicsMod use FatesConstantsMod , only : rsnbl_math_prec use FatesConstantsMod , only : fates_tiny use FatesConstantsMod , only : nocomp_bareground + use FatesInterfaceTypesMod , only : hlm_patchi use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : numpft @@ -1891,7 +1892,12 @@ subroutine set_patchno( currentSite ) integer patchno !--------------------------------------------------------------------- - patchno = 1 + if(hlm_use_fixed_biogeog.eq.itrue .and. hlm_use_nocomp.eq.itrue)then + patchno = 0 + else + patchno = 1 + end if + currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) currentPatch%patchno = patchno @@ -1899,22 +1905,7 @@ subroutine set_patchno( currentSite ) currentPatch => currentPatch%younger enddo - if(hlm_use_fixed_biogeog.eq.itrue .and. hlm_use_nocomp.eq.itrue)then - patchno = 1 - currentPatch => currentSite%oldest_patch - do while(associated(currentPatch)) - if(currentPatch%nocomp_pft_label.eq.nocomp_bareground)then - ! for bareground patch, we make the patch number 0 - ! we also do not count this in the veg. patch numbering scheme. - currentPatch%patchno = 0 - else - currentPatch%patchno = patchno - patchno = patchno + 1 - endif - currentPatch => currentPatch%younger - enddo - endif - + return end subroutine set_patchno ! ============================================================================ diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 8d689a759a..534f9ae23b 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -639,8 +639,6 @@ subroutine trim_canopy( currentSite ) real(r8) :: cumulative_lai_cohort ! cumulative LAI within the current cohort only ! Temporary diagnostic ouptut - integer :: ipatch - integer :: icohort ! LAPACK linear least squares fit variables ! The standard equation for a linear fit, y = mx + b, is converted to a linear system, AX=B and has @@ -674,19 +672,14 @@ subroutine trim_canopy( currentSite ) real(r8) :: leaf_long ! temporary leaf lifespan before accounting for deciduousness !---------------------------------------------------------------------- - ipatch = 1 ! Start counting patches - currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) ! 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 endif - icohort = 1 - currentCohort => currentPatch%tallest do while (associated(currentCohort)) @@ -696,7 +689,6 @@ subroutine trim_canopy( currentSite ) ! Add debug diagnostic output to determine which cohort if (debug) then - write(fates_log(),*) 'Current cohort:', icohort write(fates_log(),*) 'Starting canopy trim:', initial_trim endif @@ -916,10 +908,9 @@ subroutine trim_canopy( currentSite ) ! currentCohort%canopy_trim = 1.0_r8 !FIX(RF,032414) this turns off ctrim for now. currentCohort => currentCohort%shorter - icohort = icohort + 1 enddo currentPatch => currentPatch%older - ipatch = ipatch + 1 + enddo end subroutine trim_canopy diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 2dd3f816a4..f422d3dab9 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -252,7 +252,7 @@ subroutine PrepCH4BCs(csite,bc_in,bc_out) type(fates_patch_type), pointer :: cpatch ! current patch pointer type(fates_cohort_type), pointer :: ccohort ! current cohort pointer integer :: pft ! plant functional type - integer :: fp ! patch index of the site + integer :: ifp ! patch index of the site real(r8) :: agnpp ! Above ground daily npp real(r8) :: bgnpp ! Below ground daily npp real(r8) :: plant_area ! crown area (m2) of all plants in patch @@ -284,16 +284,16 @@ subroutine PrepCH4BCs(csite,bc_in,bc_out) ! Process CH4 variables first !if(.not.(hlm_use_ch4==itrue) .and. .not.(hlm_parteh_mode==prt_cnp_flex_allom_hyp) ) - fp = 0 cpatch => csite%oldest_patch do while (associated(cpatch)) + + ifp = cpatch%patchno + if_notbare: if(cpatch%nocomp_pft_label .ne. nocomp_bareground)then ! Patch ordering when passing boundary conditions ! always goes from oldest to youngest, following ! the convention of EDPatchDynamics::set_patchno() - fp = fp + 1 - agnpp = 0._r8 bgnpp = 0._r8 woody_area = 0._r8 @@ -334,13 +334,13 @@ subroutine PrepCH4BCs(csite,bc_in,bc_out) if(hlm_use_ch4==itrue)then ! Fine root fraction over depth - bc_out%rootfr_pa(fp,1:bc_in%nlevsoil) = & - bc_out%rootfr_pa(fp,1:bc_in%nlevsoil) + & + bc_out%rootfr_pa(ifp,1:bc_in%nlevsoil) = & + bc_out%rootfr_pa(ifp,1:bc_in%nlevsoil) + & csite%rootfrac_scr(1:bc_in%nlevsoil) ! Fine root carbon, convert [kg/plant] -> [g/m2] - bc_out%frootc_pa(fp) = & - bc_out%frootc_pa(fp) + & + bc_out%frootc_pa(ifp) = & + bc_out%frootc_pa(ifp) + & fnrt_c*ccohort%n/cpatch%area * g_per_kg ! (gC/m2/s) root respiration (fine root MR + total root GR) @@ -366,10 +366,10 @@ subroutine PrepCH4BCs(csite,bc_in,bc_out) end do if(hlm_use_ch4==itrue)then - if( sum(bc_out%rootfr_pa(fp,1:bc_in%nlevsoil)) > nearzero) then - bc_out%rootfr_pa(fp,1:bc_in%nlevsoil) = & - bc_out%rootfr_pa(fp,1:bc_in%nlevsoil) / & - sum(bc_out%rootfr_pa(fp,1:bc_in%nlevsoil)) + if( sum(bc_out%rootfr_pa(ifp,1:bc_in%nlevsoil)) > nearzero) then + bc_out%rootfr_pa(ifp,1:bc_in%nlevsoil) = & + bc_out%rootfr_pa(ifp,1:bc_in%nlevsoil) / & + sum(bc_out%rootfr_pa(ifp,1:bc_in%nlevsoil)) end if ! RGK: These averages should switch to the new patch averaging methods @@ -378,17 +378,18 @@ subroutine PrepCH4BCs(csite,bc_in,bc_out) ! would be arguably worse than just using the instantaneous value ! gC/m2/s - bc_out%annavg_agnpp_pa(fp) = agnpp - bc_out%annavg_bgnpp_pa(fp) = bgnpp + bc_out%annavg_agnpp_pa(ifp) = agnpp + bc_out%annavg_bgnpp_pa(ifp) = bgnpp ! gc/m2/yr - bc_out%annsum_npp_pa(fp) = (bgnpp+agnpp)*days_per_year*sec_per_day + bc_out%annsum_npp_pa(ifp) = (bgnpp+agnpp)*days_per_year*sec_per_day if(plant_area>nearzero) then - bc_out%woody_frac_aere_pa(fp) = woody_area/plant_area + bc_out%woody_frac_aere_pa(ifp) = woody_area/plant_area end if end if end if if_notbare + cpatch => cpatch%younger end do diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index 5bab6b5191..b4f93ba5c9 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -15,7 +15,6 @@ module EDAccumulateFluxesMod use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : nocomp_bareground - implicit none private ! @@ -62,16 +61,16 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) do s = 1, nsites - ifp = 0 - ! Note: Do not attempt to accumulate or log any ! heterotrophic respiration fluxes from the HLM here ! It is likely this has not been calculated yet (ELM/CLM) cpatch => sites(s)%oldest_patch - do while (associated(cpatch)) + do while (associated(cpatch)) + + ifp = cpatch%patchno + if(cpatch%nocomp_pft_label.ne.nocomp_bareground)then - ifp = ifp+1 if( bc_in(s)%filter_photo_pa(ifp) == 3 ) then ccohort => cpatch%shortest @@ -105,6 +104,7 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) enddo ! while(associated(ccohort)) end if end if ! not bare ground + cpatch => cpatch%younger end do ! while(associated(cpatch)) end do diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index 3e2401a033..177557aedf 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -137,11 +137,12 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) bc_out(s)%rootr_pasl(:,:) = 0._r8 - ifp = 0 cpatch => sites(s)%oldest_patch - do while (associated(cpatch)) - if(cpatch%nocomp_pft_label.ne.nocomp_bareground)then ! only for veg patches - ifp=ifp+1 + do while (associated(cpatch)) + + ifp = cpatch%patchno + + if_bare: if(cpatch%nocomp_pft_label.ne.nocomp_bareground)then ! only for veg patches ! THIS SHOULD REALLY BE A COHORT LOOP ONCE WE HAVE rootfr_ft FOR COHORTS (RGK) @@ -246,7 +247,7 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) enddo end if - endif ! not bare ground + endif if_bare cpatch => cpatch%younger end do diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 454bf5d28d..2e1b6b3d16 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -2152,10 +2152,10 @@ subroutine BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) do s = 1,nsites - ifp = 0 cpatch => sites(s)%oldest_patch do while (associated(cpatch)) - ifp=ifp+1 + + ifp = cpatch%patchno balive_patch = 0._r8 ccohort=>cpatch%tallest @@ -2496,12 +2496,12 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) !err_soil = delta_soil_storage - root_flux !err_plot = delta_plant_storage - (root_flux - transp_flux) - ifp = 0 cpatch => sites(s)%oldest_patch do while (associated(cpatch)) + ifp = cpatch%patchno + if(cpatch%nocomp_pft_label.ne.nocomp_bareground)then - ifp = ifp + 1 ! ---------------------------------------------------------------------------- ! Objective: Partition the transpiration flux diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index d1413f1b15..89e8240fe0 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -344,11 +344,13 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) end do - ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) + + ifp = currentPatch%patchno + if_notbare: if(currentpatch%nocomp_pft_label.ne.nocomp_bareground)then - ifp = ifp+1 + NCL_p = currentPatch%NCL_p ! Part I. Zero output boundary conditions diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 55287c40f5..678f930ffa 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2365,7 +2365,6 @@ subroutine update_history_dyn1(this,nc,nsites,sites,bc_in) type(litter_type), pointer :: litt ! Generic pointer to any litter pool integer :: s ! site counter - integer :: ipa ! patch index matching host model array space integer :: io_si ! site's index in the history output array space integer :: el ! element index integer :: ft ! pft index @@ -2628,7 +2627,6 @@ subroutine update_history_dyn1(this,nc,nsites,sites,bc_in) AREA_INV * days_per_sec ! Loop through patches to sum up diagonistics - ipa = 0 cpatch => sites(s)%oldest_patch patchloop: do while(associated(cpatch)) @@ -2973,7 +2971,6 @@ subroutine update_history_dyn1(this,nc,nsites,sites,bc_in) ccohort => ccohort%taller enddo cohortloop ! cohort loop - ipa = ipa + 1 cpatch => cpatch%younger end do patchloop !patch loop @@ -3050,7 +3047,7 @@ subroutine update_history_dyn2(this,nc,nsites,sites,bc_in) type(litter_type), pointer :: litt_c ! Pointer to the carbon12 litter pool type(litter_type), pointer :: litt ! Generic pointer to any litter pool integer :: s ! site counter - integer :: ipa,ipa2 ! patch index matching host model array space + integer :: ipa2 ! patch index matching host model array space integer :: io_si ! site's index in the history output array space integer :: el ! element index integer :: ft ! pft index @@ -3415,7 +3412,6 @@ subroutine update_history_dyn2(this,nc,nsites,sites,bc_in) end do ! Loop through patches to sum up diagonistics - ipa = 0 cpatch => sites(s)%oldest_patch patchloop: do while(associated(cpatch)) @@ -4330,7 +4326,6 @@ subroutine update_history_dyn2(this,nc,nsites,sites,bc_in) end do - ipa = ipa + 1 cpatch => cpatch%younger end do patchloop !patch loop @@ -4944,7 +4939,6 @@ subroutine update_history_hifrq1(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) ! Locals integer :: s ! The local site index integer :: io_si ! The site index of the IO array - integer :: ipa ! patch bc index for the patch integer :: age_class ! class age index real(r8) :: site_area_veg_inv ! inverse canopy area of the site (1/m2) real(r8) :: site_area_rad_inv ! inverse canopy area of site for only @@ -5065,15 +5059,11 @@ subroutine update_history_hifrq1(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) else - ipa = 0 site_area_veg_inv = 1._r8/site_area_veg_inv cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - ipa = ipa + 1 - - hio_c_stomata_si(io_si) = hio_c_stomata_si(io_si) + & cpatch%c_stomata * cpatch%total_canopy_area * mol_per_umol * site_area_veg_inv @@ -5147,7 +5137,6 @@ subroutine update_history_hifrq1(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) end if if_notnew ccohort => ccohort%taller end do - cpatch => cpatch%younger end do end if if_veg_area @@ -5182,7 +5171,6 @@ subroutine update_history_hifrq2(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) ! Locals integer :: s ! The local site index integer :: io_si ! The site index of the IO array - integer :: ipa ! The local "I"ndex of "PA"tches integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread integer :: ivar ! index of IO variable object vector integer :: ft ! functional type index @@ -5267,16 +5255,12 @@ subroutine update_history_hifrq2(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) io_si = sites(s)%h_gid - ipa = 0 - patch_area_by_age(1:nlevage) = 0._r8 canopy_area_by_age(1:nlevage) = 0._r8 cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - ipa = ipa + 1 - patch_area_by_age(cpatch%age_class) = & patch_area_by_age(cpatch%age_class) + cpatch%area @@ -5618,7 +5602,6 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) ! Locals integer :: s ! The local site index integer :: io_si ! The site index of the IO array - integer :: ipa ! The local "I"ndex of "PA"tches integer :: ft ! functional type index ! integer :: io_shsl ! The combined "SH"ell "S"oil "L"ayer index in the IO array real(r8) :: ncohort_scpf(nlevsclass*maxpft) ! Bins to count up cohorts counts used in weighting @@ -5862,7 +5845,6 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) end do end do - ipa = 0 cpatch => sites(s)%oldest_patch do while(associated(cpatch)) @@ -5945,7 +5927,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) ccohort => ccohort%taller enddo ! cohort loop - ipa = ipa + 1 + cpatch => cpatch%younger end do !patch loop diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index e77b3e34bc..42468ed6ba 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -793,7 +793,7 @@ subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft,param_reade maxpatches_by_landuse(primaryland) = fates_numpft maxpatches_by_landuse(secondaryland:n_landuse_cats) = 0 maxpatch_total = fates_numpft - + ! If this is an SP run, we actually need enough patches on the ! CLM/ELM side of the code to hold the LAI data. This ! number may be larger than what fates requires. Of course @@ -802,7 +802,6 @@ subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft,param_reade ! maxpatch_total does not include the bare ground (so add 1) fates_maxPatchesPerSite = max(surf_numpft+surf_numcft,maxpatch_total+1) - else ! If we are using fixed biogeography or no-comp then we @@ -813,11 +812,6 @@ subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft,param_reade maxpatches_by_landuse(primaryland) = max(maxpatches_by_landuse(primaryland),fates_numpft) maxpatch_total = sum(maxpatches_by_landuse(:)) - - !if(maxpatch_primary sites(s)%oldest_patch do while(associated(cpatch)) + + ifp = cpatch%patchno + if (cpatch%patchno .ne. 0) then - ifp=ifp+1 + call cpatch%tveg24%UpdateRMean(bc_in(s)%t_veg_pa(ifp)) call cpatch%tveg_lpa%UpdateRMean(bc_in(s)%t_veg_pa(ifp)) call cpatch%tveg_longterm%UpdateRMean(bc_in(s)%t_veg_pa(ifp)) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 75e64307a5..c9f859e113 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -90,7 +90,7 @@ module FatesInterfaceTypesMod ! between the pedotransfer functions of the HLM ! and how it moves and stores water in its ! rhizosphere shells - + integer, public :: hlm_parteh_mode ! This flag signals which Plant Allocation and Reactive ! Transport (exensible) Hypothesis (PARTEH) to use From 36a86e66c90324a2d3f195ce715d56ded02ce452 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 18 Dec 2024 10:28:55 -0700 Subject: [PATCH 2/7] Update vegetation temperature weighting convention during chill day calculation --- biogeochem/EDPhysiologyMod.F90 | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 534f9ae23b..4b4fd6a6ad 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -957,6 +957,8 @@ subroutine phenology( currentSite, bc_in ) integer :: gddstart ! beginning of counting period for growing degree days. integer :: nlevroot ! Number of rooting levels to consider real(r8) :: temp_in_C ! daily averaged temperature in celsius + real(r8) :: temp_wgt ! canopy area weighting factor for daily average + ! vegetation temperature calculation real(r8) :: elongf_prev ! Elongation factor from previous time real(r8) :: elongf_1st ! First guess for elongation factor integer :: ndays_pft_leaf_lifespan ! PFT life span of drought deciduous [days]. @@ -1010,13 +1012,23 @@ subroutine phenology( currentSite, bc_in ) !Parameters, default from from SDGVM model of senesence temp_in_C = 0._r8 + temp_wgt = 0._r8 cpatch => CurrentSite%oldest_patch do while(associated(cpatch)) - temp_in_C = temp_in_C + cpatch%tveg24%GetMean()*cpatch%area + temp_in_C = temp_in_C + cpatch%tveg24%GetMean()*cpatch%total_canopy_area + temp_wgt = temp_wgt + cpatch%total_canopy_area cpatch => cpatch%younger end do - temp_in_C = temp_in_C * area_inv - tfrz - + if(cpatch%total_canopy_area>nearzero)then + temp_in_C = temp_in_C/temp_wgt - tfrz + else + ! If there is no canopy area, we use the veg temperature + ! of the first patch, which is the forcing air temperature + ! as defined in CLM/ELM. The forcing air temperature + ! should be the same among all patches. (Although + ! it is unlikely there are more than 1 in this scenario) + temp_in_C = CurrentSite%oldest_patch%tveg24%GetMean() - tfrz + end if !-----------------Cold Phenology--------------------! From 599619012345d84af91cfe16eec247b4c513f938 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 18 Dec 2024 11:17:23 -0700 Subject: [PATCH 3/7] Fixed null pointer --- biogeochem/EDPhysiologyMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 4b4fd6a6ad..35f6979dfc 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1019,7 +1019,7 @@ subroutine phenology( currentSite, bc_in ) temp_wgt = temp_wgt + cpatch%total_canopy_area cpatch => cpatch%younger end do - if(cpatch%total_canopy_area>nearzero)then + if(temp_wgt>nearzero)then temp_in_C = temp_in_C/temp_wgt - tfrz else ! If there is no canopy area, we use the veg temperature From 7ed9209734bd4fad7a80434ab11b302c7dcf4d97 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 29 Dec 2024 10:18:32 -0700 Subject: [PATCH 4/7] bug fixes --- biogeochem/EDCanopyStructureMod.F90 | 9 ++------- biogeochem/EDPatchDynamicsMod.F90 | 1 - 2 files changed, 2 insertions(+), 8 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 3d610fcf5c..3cbe2f4a08 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -31,7 +31,6 @@ module EDCanopyStructureMod use EDtypesMod , only : AREA use EDLoggingMortalityMod , only : UpdateHarvestC use FatesGlobals , only : endrun => fates_endrun - use FatesInterfaceTypesMod , only : hlm_patchi use FatesInterfaceTypesMod , only : hlm_days_per_year use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking @@ -1898,7 +1897,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) do s = 1,nsites - ifp = hlm_patchi total_patch_area = 0._r8 total_canopy_area = 0._r8 bc_out(s)%canopy_fraction_pa(:) = 0._r8 @@ -1910,6 +1908,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) c = fcolumn(s) do while(associated(currentPatch)) + ifp = currentPatch%patchno if_bare: if(currentPatch%nocomp_pft_label.ne.nocomp_bareground)then ! ignore the bare-ground-PFT patch entirely for these BC outs if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then @@ -2029,9 +2028,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) total_patch_area = total_patch_area + currentPatch%area/AREA end if if_bare - - ifp = ifp + 1 - currentPatch => currentPatch%younger end do @@ -2051,12 +2047,11 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) end if currentPatch => sites(s)%oldest_patch - ifp = hlm_patchi do while(associated(currentPatch)) + ifp = currentPatch%patchno if(currentPatch%nocomp_pft_label.ne.nocomp_bareground)then ! for vegetated patches only bc_out(s)%canopy_fraction_pa(ifp) = bc_out(s)%canopy_fraction_pa(ifp)/total_patch_area endif ! veg patch - ifp = ifp + 1 currentPatch => currentPatch%younger end do diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 32dcb0941d..a5b8d4ce73 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -45,7 +45,6 @@ module EDPatchDynamicsMod use FatesConstantsMod , only : rsnbl_math_prec use FatesConstantsMod , only : fates_tiny use FatesConstantsMod , only : nocomp_bareground - use FatesInterfaceTypesMod , only : hlm_patchi use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : numpft From 6b4c08f3dd07fa8156c654c83baadd1f2eb8ebbe Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 30 Dec 2024 11:49:28 -0700 Subject: [PATCH 5/7] migrating method of getting patch numbers to be more uniform --- biogeochem/EDCanopyStructureMod.F90 | 4 +-- biogeochem/EDPatchDynamicsMod.F90 | 40 +++-------------------- biogeochem/FatesSoilBGCFluxMod.F90 | 6 ++-- main/EDInitMod.F90 | 6 ++-- main/EDTypesMod.F90 | 49 +++++++++++++++++++++++++---- main/FatesRestartInterfaceMod.F90 | 10 ++++-- 6 files changed, 64 insertions(+), 51 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 3cbe2f4a08..3a16eb01bb 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -21,6 +21,7 @@ module EDCanopyStructureMod use FatesAllometryMod , only : tree_lai use FatesAllometryMod , only : tree_sai use EDTypesMod , only : ed_site_type + use EDTypesMod , only : set_patchno use FatesAllometryMod , only : VegAreaLayer use FatesAllometryMod , only : CrownDepth use FatesPatchMod, only : fates_patch_type @@ -1314,7 +1315,6 @@ subroutine canopy_summarization( nsites, sites, bc_in ) ! --------------------------------------------------------------------------------- use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking - use EDPatchDynamicsMod , only : set_patchno use FatesSizeAgeTypeIndicesMod, only : sizetype_class_index use FatesSizeAgeTypeIndicesMod, only : coagetype_class_index use EDtypesMod , only : area @@ -1351,7 +1351,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) ! driving model. Loops through all patches and sets cpatch%patchno to the integer ! order of oldest to youngest where the oldest is 1. ! -------------------------------------------------------------------------------- - call set_patchno( sites(s) ) + call set_patchno( sites(s) , .false., 0) currentPatch => sites(s)%oldest_patch diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index a5b8d4ce73..33147a3e54 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -22,7 +22,8 @@ module EDPatchDynamicsMod use FatesConstantsMod , only : patchfusion_dbhbin_loweredges use EDtypesMod , only : force_patchfuse_min_biomass use EDTypesMod , only : ed_site_type - use FatesPatchMod, only : fates_patch_type + use FatesPatchMod , only : fates_patch_type + use EDTypesMod , only : set_patchno use FatesCohortMod , only : fates_cohort_type use EDTypesMod , only : site_massbal_type use EDTypesMod , only : site_fluxdiags_type @@ -124,7 +125,6 @@ module EDPatchDynamicsMod public :: patch_pft_size_profile public :: disturbance_rates public :: check_patch_area - public :: set_patchno private:: fuse_2_patches character(len=*), parameter, private :: sourcefile = & @@ -1362,7 +1362,7 @@ subroutine spawn_patches( currentSite, bc_in) call check_patch_area(currentSite) - call set_patchno(currentSite) + call set_patchno(currentSite,.false.,0) end do landusechange_receiverpatchlabel_loop end do landuse_donortype_loop @@ -1875,38 +1875,6 @@ subroutine check_patch_area( currentSite ) return end subroutine check_patch_area - ! ============================================================================ - subroutine set_patchno( currentSite ) - ! - ! !DESCRIPTION: - ! Give patches an order number from the oldest to youngest. - ! - ! !USES: - ! - ! !ARGUMENTS: - type(ed_site_type),intent(in) :: currentSite - ! - ! !LOCAL VARIABLES: - type(fates_patch_type), pointer :: currentPatch - integer patchno - !--------------------------------------------------------------------- - - if(hlm_use_fixed_biogeog.eq.itrue .and. hlm_use_nocomp.eq.itrue)then - patchno = 0 - else - patchno = 1 - end if - - currentPatch => currentSite%oldest_patch - do while(associated(currentPatch)) - currentPatch%patchno = patchno - patchno = patchno + 1 - currentPatch => currentPatch%younger - enddo - - return - end subroutine set_patchno - ! ============================================================================ subroutine TransLitterNewPatch(currentSite, & @@ -3662,6 +3630,8 @@ subroutine terminate_patches(currentSite, bc_in) !check area is not exceeded call check_patch_area( currentSite ) + call set_patchno( currentSite, .false., 0) + return end subroutine terminate_patches diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index f422d3dab9..e0af2a9e0f 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -283,17 +283,17 @@ subroutine PrepCH4BCs(csite,bc_in,bc_out) ! Process CH4 variables first !if(.not.(hlm_use_ch4==itrue) .and. .not.(hlm_parteh_mode==prt_cnp_flex_allom_hyp) ) - + cpatch => csite%oldest_patch do while (associated(cpatch)) - + ifp = cpatch%patchno if_notbare: if(cpatch%nocomp_pft_label .ne. nocomp_bareground)then ! Patch ordering when passing boundary conditions ! always goes from oldest to youngest, following ! the convention of EDPatchDynamics::set_patchno() - + agnpp = 0._r8 bgnpp = 0._r8 woody_area = 0._r8 diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 9fc11491c1..dce708dedd 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -26,7 +26,7 @@ module EDInitMod use PRTParametersMod , only : prt_params use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts use EDCohortDynamicsMod , only : InitPRTObject - use EDPatchDynamicsMod , only : set_patchno + use EDTypesMod , only : set_patchno use EDPhysiologyMod , only : calculate_sp_properties use ChecksBalancesMod , only : SiteMassStock use FatesInterfaceTypesMod , only : hlm_day_of_year @@ -713,7 +713,7 @@ subroutine init_patches( nsites, sites, bc_in) sites(s)%iflux_balance(el)%iflux_litter = litter_stock * area_inv end do - call set_patchno(sites(s)) + call set_patchno(sites(s),.false.,0) enddo else @@ -987,7 +987,7 @@ subroutine init_patches( nsites, sites, bc_in) end do - call set_patchno(sites(s)) + call set_patchno(sites(s),.false.,0) enddo sites_loop end if diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 20881c6e34..c86af6b8f0 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -5,6 +5,7 @@ module EDTypesMod use FatesConstantsMod, only : ifalse use FatesConstantsMod, only : itrue use FatesConstantsMod, only : nocomp_bareground_land + use FatesConstantsMod, only : nocomp_bareground use FatesConstantsMod, only : secondaryland use FatesConstantsMod, only : secondary_age_threshold use FatesConstantsMod, only : nearzero @@ -258,6 +259,7 @@ module EDTypesMod contains procedure :: ZeroFluxDiags + end type site_fluxdiags_type @@ -566,14 +568,51 @@ module EDTypesMod procedure, public :: get_secondary_young_fraction end type ed_site_type - + ! Make public necessary subroutines and functions public :: dump_site public :: CalculateTreeGrassAreaSite + public :: set_patchno + +contains - contains - - ! ===================================================================================== + ! ============================================================================ + + subroutine set_patchno( currentSite, check , call_id) + + type(ed_site_type),intent(in) :: currentSite + logical,intent(in) :: check ! If true, we are checking order, not setting + integer,intent(in) :: call_id ! An index used for testing + type(fates_patch_type), pointer :: currentPatch + integer patchno + + !--------------------------------------------------------------------- + + patchno = 1 + currentPatch => currentSite%oldest_patch + do while(associated(currentPatch)) + if(currentPatch%nocomp_pft_label.eq.nocomp_bareground)then + ! for bareground patch, we make the patch number 0 + if(check .and. currentPatch%patchno.ne.0)then + write(fates_log(),*)'nocomp patch numbering is not correct:',currentPatch%patchno,'call_id:',call_id + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + currentPatch%patchno = 0 + else + if(check .and. currentPatch%patchno.ne.patchno) then + write(fates_log(),*)'patch numbering is not correct:',currentPatch%patchno,patchno,'call_id:',call_id + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + currentPatch%patchno = patchno + patchno = patchno + 1 + endif + currentPatch => currentPatch%younger + enddo + + return + end subroutine set_patchno + + ! ===================================================================================== subroutine ZeroFluxDiags(this) @@ -656,8 +695,6 @@ subroutine CalculateTreeGrassAreaSite(csite, tree_fraction, grass_fraction, bare ! DESCRIPTION: ! Calculates total grass, tree, and bare fractions for a site - use FatesConstantsMod, only : nocomp_bareground - ! ARGUMENTS: type(ed_site_type), intent(inout) :: csite ! site object real(r8), intent(out) :: tree_fraction ! total site tree fraction diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index bf63274d0e..7e233c64e8 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -44,6 +44,7 @@ module FatesRestartInterfaceMod use FatesFuelClassesMod, only : num_fuel_classes use FatesLitterMod, only : ndcmpy use EDTypesMod, only : area + use EDTypesMod, only : set_patchno use EDParamsMod, only : nlevleaf use PRTGenericMod, only : prt_global use PRTGenericMod, only : num_elements @@ -2902,8 +2903,9 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in, bc_out) init_seed_germ=fates_unset_r8) end do - ! give this patch a unique patch number - newp%patchno = idx_pa + ! Set the new patch number to nonsense, we will + ! call set_patchno() + newp%patchno = -9 ! Iterate over the number of cohorts @@ -3779,8 +3781,12 @@ subroutine get_restart_vectors(this, nc, nsites, sites) call endrun(msg=errMsg(sourcefile, __LINE__)) endif + + call set_patchno(sites(s),.false.,0) + end do + if ( debug ) then write(fates_log(),*) 'CVTL total cohorts ',totalCohorts end if From 50ea2d3193a786a0f2a8784e4b489236a3d7d50d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 30 Dec 2024 13:55:31 -0700 Subject: [PATCH 6/7] cleaned out unnecessary patch order checks --- main/EDMainMod.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 01111c0626..ec15fb4df8 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -64,6 +64,7 @@ module EDMainMod use FatesLitterMod , only : litter_type use FatesLitterMod , only : ncwd use EDtypesMod , only : ed_site_type + use EDTypesMod , only : set_patchno use FatesPatchMod , only : fates_patch_type use FatesCohortMod , only : fates_cohort_type use EDTypesMod , only : AREA @@ -317,8 +318,6 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) ! Final instantaneous mass balance check call TotalBalanceCheck(currentSite,5) - - end subroutine ed_ecosystem_dynamics @@ -835,6 +834,9 @@ subroutine ed_update_site( currentSite, bc_in, bc_out, is_restarting ) type (fates_patch_type) , pointer :: currentPatch !----------------------------------------------------------------------- + ! check patch order (set second argument to true) + ! call set_patchno(currentSite,.true.,1) + if(hlm_use_sp.eq.ifalse .and. (.not.is_restarting))then call canopy_spread(currentSite) end if From 0be5cd133070d78d8dee7918ef89c5632d6a6117 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 8 Jan 2025 11:00:49 -0700 Subject: [PATCH 7/7] more tweaking and cleaning of patch numbering --- main/EDMainMod.F90 | 2 +- main/FatesHistoryInterfaceMod.F90 | 4 ++-- main/FatesInterfaceMod.F90 | 28 ++++++++++++++++++++-------- main/FatesRestartInterfaceMod.F90 | 8 +++++--- radiation/FatesRadiationDriveMod.F90 | 23 +++++++++-------------- 5 files changed, 37 insertions(+), 28 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index ec15fb4df8..c1713047db 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -211,7 +211,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) ! oldest patch per set_patchno, we check that the youngest patch isn't zero. ! If there are multiple patches on the site, the bareground patch is avoided ! at the level of the fire_model subroutines. - if (currentSite%youngest_patch%patchno .ne. 0) then + if (currentSite%youngest_patch%nocomp_pft_label .ne. nocomp_bareground)then call fire_model(currentSite, bc_in) end if diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 678f930ffa..a7e34686b6 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -5071,11 +5071,11 @@ subroutine update_history_hifrq1(this,nc,nsites,sites,bc_in,bc_out,dt_tstep) cpatch%c_lblayer * cpatch%total_canopy_area * mol_per_umol * site_area_veg_inv ! Only accumulate the instantaneous vegetation temperature for vegetated patches - if (cpatch%patchno .ne. 0) then + !if (cpatch%nocomp_pft_label.ne.nocomp_bareground)then hio_tveg(io_si) = hio_tveg(io_si) + & (bc_in(s)%t_veg_pa(cpatch%patchno) - t_water_freeze_k_1atm) * & cpatch%total_canopy_area * site_area_veg_inv - end if + !end if ccohort => cpatch%shortest do while(associated(ccohort)) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 42468ed6ba..8adda8301c 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -774,8 +774,9 @@ subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft,param_reade integer, intent(in) :: surf_numpft ! Number of PFTs in surface dataset integer, intent(in) :: surf_numcft ! Number of CFTs in surface dataset class(fates_param_reader_type), intent(in) :: param_reader ! HLM-provided param file reader - integer :: fates_numpft ! Number of PFTs tracked in FATES + + logical, parameter :: preserve_b4b = .true. if (use_fates) then @@ -807,13 +808,24 @@ subroutine SetFatesGlobalElements1(use_fates,surf_numpft,surf_numcft,param_reade ! If we are using fixed biogeography or no-comp then we ! can also apply those constraints to maxpatch_primaryland and secondary ! and that value will match fates_maxPatchesPerSite - - if(hlm_use_nocomp==itrue) then + if_preserve_b4b: if(.not.preserve_b4b)then - maxpatches_by_landuse(primaryland) = max(maxpatches_by_landuse(primaryland),fates_numpft) - maxpatch_total = sum(maxpatches_by_landuse(:)) - end if + if(hlm_use_luh==ifalse) then + maxpatches_by_landuse(secondaryland:n_landuse_cats) = 0 + end if + maxpatch_total = sum(maxpatches_by_landuse(:)) + + else + + if(hlm_use_nocomp==itrue) then + + maxpatches_by_landuse(primaryland) = max(maxpatches_by_landuse(primaryland),fates_numpft) + maxpatch_total = sum(maxpatches_by_landuse(:)) + end if + + end if if_preserve_b4b + ! maxpatch_total does not include the bare ground (so add 1) fates_maxPatchesPerSite = maxpatch_total+1 @@ -2110,7 +2122,7 @@ subroutine UpdateFatesRMeansTStep(sites,bc_in, bc_out) ifp = cpatch%patchno - if (cpatch%patchno .ne. 0) then + nocomp_bare: if(cpatch%nocomp_pft_label.ne.nocomp_bareground)then call cpatch%tveg24%UpdateRMean(bc_in(s)%t_veg_pa(ifp)) call cpatch%tveg_lpa%UpdateRMean(bc_in(s)%t_veg_pa(ifp)) @@ -2172,7 +2184,7 @@ subroutine UpdateFatesRMeansTStep(sites,bc_in, bc_out) ccohort => ccohort%shorter end do - end if + end if nocomp_bare cpatch => cpatch%younger enddo diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 7e233c64e8..bac1ce14f2 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -3822,10 +3822,10 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) do s = 1, nsites - ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) - ifp = ifp+1 + + ifp = currentPatch%patchno currentPatch%f_sun (:,:,:) = 0._r8 currentPatch%fabd_sun_z (:,:,:) = 0._r8 @@ -3848,6 +3848,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) ! currentPatch%solar_zenith_flag (is there daylight?) ! currentPatch%solar_zenith_angle (what is the value?) ! ----------------------------------------------------------- + nocomp_bareground: if(currentPatch%nocomp_pft_label .ne. nocomp_bareground)then if(currentPatch%solar_zenith_flag)then @@ -3920,8 +3921,9 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) end select endif ! is there vegetation? - + end if ! if the vegetation and zenith filter is active + end if nocomp_bareground currentPatch => currentPatch%younger end do ! Loop linked-list patches enddo ! Loop Sites diff --git a/radiation/FatesRadiationDriveMod.F90 b/radiation/FatesRadiationDriveMod.F90 index b3e36c39b0..206d6f74f6 100644 --- a/radiation/FatesRadiationDriveMod.F90 +++ b/radiation/FatesRadiationDriveMod.F90 @@ -97,17 +97,14 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) do s = 1, nsites - ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) ! do not do albedo calculations for bare ground patch in SP mode - ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein - ! ifp=1 is the first vegetated patch. - - if_notbareground: if(currentpatch%nocomp_pft_label.ne.nocomp_bareground)then - ifp = ifp+1 + ifp = currentpatch%patchno + + nocomp_bareground: if(currentpatch%nocomp_pft_label.ne.nocomp_bareground)then ! Zero diagnostics currentPatch%f_sun (:,:,:) = 0._r8 @@ -240,7 +237,7 @@ subroutine FatesNormalizedCanopyRadiation(nsites, sites, bc_in, bc_out ) end if if_nrad endif if_zenith_flag - end if if_notbareground + end if nocomp_bareground currentPatch => currentPatch%younger end do ! Loop linked-list patches @@ -282,17 +279,15 @@ subroutine FatesSunShadeFracs(nsites, sites,bc_in,bc_out) do s = 1,nsites - ifp = 0 cpatch => sites(s)%oldest_patch - do while (associated(cpatch)) - if_notbareground:if(cpatch%nocomp_pft_label.ne.nocomp_bareground)then !only for veg patches - ! do not do albedo calculations for bare ground patch in SP mode - ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein - ! ifp=1 is the first vegetated patch. - ifp=ifp+1 + ifp = cpatch%patchno + + nocomp_bareground:if(cpatch%nocomp_pft_label.ne.nocomp_bareground)then !only for veg patches + ! do not do albedo calculations for bare ground patch in SP mode + ! Initialize diagnostics cpatch%ed_parsun_z(:,:,:) = 0._r8 cpatch%ed_parsha_z(:,:,:) = 0._r8