Merge pull request #1226 from rgknox/luh2_nocomp_merge-bcindex

cleaning up nocomp patch indexing

Author: glemieux

biogeochem/EDCanopyStructureMod.F90

@@ -20,6 +20,7 @@ module EDCanopyStructureMod
   use EDCohortDynamicsMod   , only : InitPRTObject
   use FatesAllometryMod     , only : tree_lai_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
@@ -1313,7 +1314,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
@@ -1350,7 +1350,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
 
@@ -1896,7 +1896,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out)
 
     do s = 1,nsites
 
-       ifp = 0
        total_patch_area = 0._r8
        total_canopy_area = 0._r8
        bc_out(s)%canopy_fraction_pa(:) = 0._r8
@@ -1908,9 +1907,8 @@ 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
+          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
                 if(debug)then
@@ -2028,7 +2026,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out)
 
              total_patch_area = total_patch_area + currentPatch%area/AREA
 
-          end if
+          end if if_bare
           currentPatch => currentPatch%younger
        end do
 
@@ -2048,13 +2046,11 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out)
           end if
 
           currentPatch => sites(s)%oldest_patch
-          ifp = 0
           do while(associated(currentPatch))
+             ifp = currentPatch%patchno
              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
-
              currentPatch => currentPatch%younger
           end do
 

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 = &
@@ -1323,7 +1323,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
@@ -1810,48 +1810,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
-    !---------------------------------------------------------------------
-
-    patchno = 1
-    currentPatch => currentSite%oldest_patch
-    do while(associated(currentPatch))
-       currentPatch%patchno = patchno
-       patchno = patchno + 1
-       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
-
-  end subroutine set_patchno
-
   ! ============================================================================
 
   subroutine TransLitterNewPatch(currentSite,        &
@@ -3595,6 +3553,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
 

biogeochem/EDPhysiologyMod.F90

@@ -638,8 +638,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
@@ -673,19 +671,15 @@ 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:', currentPatch%patchno
           write(fates_log(),*) 'Current patch cohorts:', currentPatch%num_cohorts
        endif
 
-       icohort = 1
-
        currentCohort => currentPatch%tallest
        do while (associated(currentCohort))
 
@@ -695,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
 
@@ -907,10 +900,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

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
@@ -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) )
-    
-    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
 

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

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
 

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

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