Merge pull request #1317 from adrifoster/patch_testing

Update to cohort insertion and sorting routines

Author: adrifoster

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)

biogeochem/EDCohortDynamicsMod.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
@@ -516,17 +516,13 @@ 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
     real(r8) :: site_areadis                 ! total site area disturbed in m2 per day
     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]
@@ -562,9 +558,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
@@ -1249,30 +1242,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()
@@ -1285,8 +1255,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
@@ -1317,7 +1289,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
 
@@ -1344,7 +1317,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
 
 
@@ -1675,11 +1649,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
 
@@ -1746,34 +1716,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
@@ -3116,7 +3066,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
 
                             !------------------------------------------------------------------------!
@@ -3238,10 +3189,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
@@ -3321,31 +3269,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
 
@@ -3356,6 +3281,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

biogeochem/EDPatchDynamicsMod.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
 
    ! ======================================================================================

biogeochem/EDPhysiologyMod.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