Skip to content

Commit

Permalink
Merge pull request #824 from amametjanov/azamat/fix-ibm-dealloc-errors
Browse files Browse the repository at this point in the history 
Add return status checks in cohort deallocations
  • Loading branch information
@glemieux
glemieux authored Feb 15, 2023
2 parents da1f7f7 + 5e55e44 commit b8b905c
Show file tree
Hide file tree
Showing 7 changed files with 164 additions and 83 deletions.
17 changes: 12 additions & 5 deletions biogeochem/EDCanopyStructureMod.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -63,6 +63,9 @@ module EDCanopyStructureMod
character(len=*), parameter, private :: sourcefile = &
__FILE__

integer :: istat ! return status code
character(len=255) :: smsg ! Message string for deallocation errors

real(r8), parameter :: area_target_precision = 1.0E-11_r8 ! Area conservation
! will attempt to reduce errors
! below this level
Expand Down Expand Up @@ -337,10 +340,10 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in)
use SFParamsMod, only : SF_val_CWD_frac

! !ARGUMENTS
type(ed_site_type), intent(inout), target :: currentSite
type(ed_patch_type), intent(inout), target :: currentPatch
integer, intent(in) :: i_lyr ! Current canopy layer of interest
type(bc_in_type), intent(in) :: bc_in
type(ed_site_type), intent(inout) :: currentSite
type(ed_patch_type), intent(inout) :: currentPatch
integer, intent(in) :: i_lyr ! Current canopy layer of interest
type(bc_in_type), intent(in) :: bc_in

! !LOCAL VARIABLES:
type(ed_cohort_type), pointer :: currentCohort
Expand Down Expand Up @@ -734,7 +737,11 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in)
! put the litter from the terminated cohorts
! straight into the fragmenting pools
call terminate_cohort(currentSite,currentPatch,currentCohort,bc_in)
deallocate(currentCohort)
deallocate(currentCohort, stat=istat, errmsg=smsg)
if (istat/=0) then
write(fates_log(),*) 'dealloc012: fail on deallocate(currentCohort):'//trim(smsg)
call endrun(msg=errMsg(sourcefile, __LINE__))
endif
else
call carea_allom(currentCohort%dbh,currentCohort%n, &
currentSite%spread,currentCohort%pft,currentCohort%crowndamage, &
Expand Down
57 changes: 38 additions & 19 deletions biogeochem/EDCohortDynamicsMod.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -134,7 +134,7 @@ Module EDCohortDynamicsMod
public :: DamageRecovery

logical, parameter :: debug = .false. ! local debug flag

character(len=*), parameter, private :: sourcefile = &
__FILE__

Expand Down Expand Up @@ -184,7 +184,8 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, &
real(r8), intent(in) :: hite ! height: meters
real(r8), intent(in) :: coage ! cohort age in years
real(r8), intent(in) :: dbh ! dbh: cm
class(prt_vartypes),target :: prt ! The allocated PARTEH
class(prt_vartypes),intent(inout), pointer :: prt ! The allocated PARTEH
!class(prt_vartypes),target :: prt ! The allocated PARTEH
! object
real(r8), intent(in) :: ctrim ! What is the fraction of the maximum
! leaf biomass that we are targeting?
Expand Down Expand Up @@ -740,11 +741,11 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_

!
! !ARGUMENTS
type (ed_site_type) , intent(inout), target :: currentSite
type (ed_patch_type), intent(inout), target :: currentPatch
integer , intent(in) :: level
integer :: call_index
type(bc_in_type), intent(in) :: bc_in
type (ed_site_type) , intent(inout) :: currentSite
type (ed_patch_type), intent(inout) :: currentPatch
integer , intent(in) :: level
integer :: call_index
type(bc_in_type), intent(in) :: bc_in

! Important point regarding termination levels. Termination is typically
! called after fusion. We do this so that we can re-capture the biomass that would
Expand All @@ -767,6 +768,8 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_
real(r8) :: repro_c ! reproductive carbon [kg]
real(r8) :: struct_c ! structural carbon [kg]
integer :: terminate ! do we terminate (itrue) or not (ifalse)
integer :: istat ! return status code
character(len=255) :: smsg
!----------------------------------------------------------------------

currentCohort => currentPatch%shortest
Expand Down Expand Up @@ -834,11 +837,15 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_

if (terminate == itrue) then
call terminate_cohort(currentSite, currentPatch, currentCohort, bc_in)
deallocate(currentCohort)
deallocate(currentCohort, stat=istat, errmsg=smsg)
if (istat/=0) then
write(fates_log(),*) 'dealloc001: fail on terminate_cohorts:deallocate(currentCohort):'//trim(smsg)
call endrun(msg=errMsg(sourcefile, __LINE__))
endif
endif
currentCohort => tallerCohort
enddo

end subroutine terminate_cohorts

!-------------------------------------------------------------------------------------!
Expand Down Expand Up @@ -869,6 +876,7 @@ subroutine terminate_cohort(currentSite, currentPatch, currentCohort, bc_in)
integer :: terminate ! do we terminate (itrue) or not (ifalse)
integer :: c ! counter for litter size class.
integer :: levcan ! canopy level

!----------------------------------------------------------------------

leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element)
Expand Down Expand Up @@ -1078,6 +1086,8 @@ subroutine DeallocateCohort(currentCohort)
! ----------------------------------------------------------------------------------

type(ed_cohort_type),intent(inout) :: currentCohort
integer :: istat ! return status code
character(len=255) :: smsg

! At this point, nothing should be pointing to current Cohort
if (hlm_use_planthydro.eq.itrue) call DeallocateHydrCohort(currentCohort)
Expand All @@ -1086,7 +1096,12 @@ subroutine DeallocateCohort(currentCohort)
call currentCohort%prt%DeallocatePRTVartypes()

! Deallocate the PRT object
deallocate(currentCohort%prt)

deallocate(currentCohort%prt, stat=istat, errmsg=smsg)
if (istat/=0) then
write(fates_log(),*) 'dealloc002: fail in deallocate(currentCohort%prt):'//trim(smsg)
call endrun(msg=errMsg(sourcefile, __LINE__))
endif

return
end subroutine DeallocateCohort
Expand All @@ -1107,9 +1122,9 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in)

!
! !ARGUMENTS
type (ed_site_type), intent(inout), target :: currentSite
type (ed_patch_type), intent(inout), target :: currentPatch
type (bc_in_type), intent(in) :: bc_in
type (ed_site_type), intent(inout) :: currentSite
type (ed_patch_type), intent(inout), pointer :: currentPatch
type (bc_in_type), intent(in) :: bc_in
!

! !LOCAL VARIABLES:
Expand Down Expand Up @@ -1144,6 +1159,8 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in)

logical, parameter :: fuse_debug = .false. ! This debug is over-verbose
! and gets its own flag
integer :: istat ! return status code
character(len=255) :: smsg

!----------------------------------------------------------------------

Expand Down Expand Up @@ -1566,9 +1583,11 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in)
endif

call DeallocateCohort(nextc)
deallocate(nextc)
nullify(nextc)

deallocate(nextc, stat=istat, errmsg=smsg)
if (istat/=0) then
write(fates_log(),*) 'dealloc003: fail on deallocate(nextc):'//trim(smsg)
call endrun(msg=errMsg(sourcefile, __LINE__))
endif

endif ! if( currentCohort%isnew.eqv.nextc%isnew ) then
endif !canopy layer
Expand Down Expand Up @@ -1720,9 +1739,9 @@ subroutine insert_cohort(pcc, ptall, pshort, tnull, snull, storebigcohort, store
! !USES:
!
! !ARGUMENTS
type(ed_cohort_type) , intent(inout), target :: pcc
type(ed_cohort_type) , intent(inout), target :: ptall
type(ed_cohort_type) , intent(inout), target :: pshort
type(ed_cohort_type) , intent(inout), pointer :: pcc
type(ed_cohort_type) , intent(inout), pointer :: ptall
type(ed_cohort_type) , intent(inout), pointer :: pshort
integer , intent(in) :: tnull
integer , intent(in) :: snull
type(ed_cohort_type) , intent(inout),pointer,optional :: storesmallcohort ! storage of the smallest cohort for insertion routine
Expand Down
92 changes: 59 additions & 33 deletions biogeochem/EDPatchDynamicsMod.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -141,6 +141,8 @@ module EDPatchDynamicsMod
real(r8), parameter :: treefall_localization = 0.0_r8
real(r8), parameter :: burn_localization = 0.0_r8

integer :: istat ! return status code
character(len=255) :: smsg ! Message string for deallocation errors
character(len=512) :: msg ! Message string for warnings and logging

! 10/30/09: Created by Rosie Fisher
Expand Down Expand Up @@ -168,7 +170,7 @@ subroutine disturbance_rates( site_in, bc_in)


! !ARGUMENTS:
type(ed_site_type) , intent(inout), target :: site_in
type(ed_site_type) , intent(inout) :: site_in
type(bc_in_type) , intent(in) :: bc_in
!
! !LOCAL VARIABLES:
Expand Down Expand Up @@ -408,8 +410,8 @@ subroutine spawn_patches( currentSite, bc_in)

!
! !ARGUMENTS:
type (ed_site_type), intent(inout), target :: currentSite
type (bc_in_type), intent(in) :: bc_in
type (ed_site_type), intent(inout) :: currentSite
type (bc_in_type), intent(in) :: bc_in
!
! !LOCAL VARIABLES:
type (ed_patch_type) , pointer :: new_patch
Expand Down Expand Up @@ -1106,8 +1108,11 @@ subroutine spawn_patches( currentSite, bc_in)

! Get rid of the new temporary cohort
call DeallocateCohort(nc)
deallocate(nc)

deallocate(nc, stat=istat, errmsg=smsg)
if (istat/=0) then
write(fates_log(),*) 'dealloc005: fail on deallocate(nc):'//trim(smsg)
call endrun(msg=errMsg(sourcefile, __LINE__))
endif
endif

currentCohort => currentCohort%taller
Expand Down Expand Up @@ -1245,7 +1250,7 @@ subroutine check_patch_area( currentSite )
! !USES:
!
! !ARGUMENTS:
type(ed_site_type), intent(inout), target :: currentSite
type(ed_site_type), intent(inout) :: currentSite
!
! !LOCAL VARIABLES:
real(r8) :: areatot
Expand Down Expand Up @@ -1317,7 +1322,7 @@ subroutine set_patchno( currentSite )
! !USES:
!
! !ARGUMENTS:
type(ed_site_type),intent(in), target :: currentSite
type(ed_site_type),intent(in) :: currentSite
!
! !LOCAL VARIABLES:
type(ed_patch_type), pointer :: currentPatch
Expand Down Expand Up @@ -1399,11 +1404,11 @@ subroutine TransLitterNewPatch(currentSite, &
! !USES:
!
! !ARGUMENTS:
type(ed_site_type) , intent(in), target :: currentSite ! site
type(ed_patch_type) , intent(in), target :: currentPatch ! Donor patch
type(ed_patch_type) , intent(inout) :: newPatch ! New patch
real(r8) , intent(in) :: patch_site_areadis ! Area being donated
! by current patch
type(ed_site_type) , intent(in) :: currentSite ! site
type(ed_patch_type) , intent(in) :: currentPatch ! Donor patch
type(ed_patch_type) , intent(inout) :: newPatch ! New patch
real(r8) , intent(in) :: patch_site_areadis ! Area being donated
! by current patch


! locals
Expand Down Expand Up @@ -2763,8 +2768,11 @@ subroutine fuse_2_patches(csite, dp, rp)

! We have no need for the dp pointer anymore, we have passed on it's legacy
call dealloc_patch(dp)
deallocate(dp)

deallocate(dp, stat=istat, errmsg=smsg)
if (istat/=0) then
write(fates_log(),*) 'dealloc006: fail on deallocate(dp):'//trim(smsg)
call endrun(msg=errMsg(sourcefile, __LINE__))
endif

if(associated(youngerp))then
! Update the younger patch's new older patch (because it isn't dp anymore)
Expand Down Expand Up @@ -3003,7 +3011,7 @@ subroutine dealloc_patch(cpatch)
! to via the patch structure. This subroutine DOES NOT deallocate the patch
! structure itself.

type(ed_patch_type), target :: cpatch
type(ed_patch_type) :: cpatch

type(ed_cohort_type), pointer :: ccohort ! current
type(ed_cohort_type), pointer :: ncohort ! next
Expand All @@ -3017,7 +3025,12 @@ subroutine dealloc_patch(cpatch)
ncohort => ccohort%taller

call DeallocateCohort(ccohort)
deallocate(ccohort)
deallocate(ccohort, stat=istat, errmsg=smsg)
if (istat/=0) then
write(fates_log(),*) 'dealloc007: fail on deallocate(cchort):'//trim(smsg)
call endrun(msg=errMsg(sourcefile, __LINE__))
endif

ccohort => ncohort

end do
Expand All @@ -3026,25 +3039,38 @@ subroutine dealloc_patch(cpatch)
do el=1,num_elements
call cpatch%litter(el)%DeallocateLitt()
end do
deallocate(cpatch%litter)

! Secondly, and lastly, deallocate the allocatable vector spaces in the patch
if(allocated(cpatch%tr_soil_dir))then
deallocate(cpatch%tr_soil_dir)
deallocate(cpatch%tr_soil_dif)
deallocate(cpatch%tr_soil_dir_dif)
deallocate(cpatch%fab)
deallocate(cpatch%fabd)
deallocate(cpatch%fabi)
deallocate(cpatch%sabs_dir)
deallocate(cpatch%sabs_dif)
deallocate(cpatch%fragmentation_scaler)
end if

deallocate(cpatch%litter, stat=istat, errmsg=smsg)
if (istat/=0) then
write(fates_log(),*) 'dealloc008: fail on deallocate(cpatch%litter):'//trim(smsg)
call endrun(msg=errMsg(sourcefile, __LINE__))
endif

! Secondly, deallocate the allocatable vector spaces in the patch
deallocate(cpatch%tr_soil_dir, &
cpatch%tr_soil_dif, &
cpatch%tr_soil_dir_dif, &
cpatch%fab, &
cpatch%fabd, &
cpatch%fabi, &
cpatch%sabs_dir, &
cpatch%sabs_dif, &
cpatch%fragmentation_scaler, stat=istat, errmsg=smsg)
if (istat/=0) then
write(fates_log(),*) 'dealloc009: fail on deallocate patch vectors:'//trim(smsg)
call endrun(msg=errMsg(sourcefile, __LINE__))
endif

! Deallocate any running means
deallocate(cpatch%tveg24)
deallocate(cpatch%tveg_lpa)
deallocate(cpatch%tveg24, stat=istat, errmsg=smsg)
if (istat/=0) then
write(fates_log(),*) 'dealloc010: fail on deallocate(cpatch%tveg24):'//trim(smsg)
call endrun(msg=errMsg(sourcefile, __LINE__))
endif
deallocate(cpatch%tveg_lpa, stat=istat, errmsg=smsg)
if (istat/=0) then
write(fates_log(),*) 'dealloc011: fail on deallocate(cpatch%tveg_lpa):'//trim(smsg)
call endrun(msg=errMsg(sourcefile, __LINE__))
endif

return
end subroutine dealloc_patch
Expand Down
15 changes: 11 additions & 4 deletions biogeochem/EDPhysiologyMod.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -144,6 +144,8 @@ module EDPhysiologyMod
character(len=*), parameter, private :: sourcefile = &
__FILE__

integer :: istat ! return status code
character(len=255) :: smsg ! Message string for deallocation errors
integer, parameter :: dleafon_drycheck = 100 ! Drought deciduous leaves max days on check parameter


Expand Down Expand Up @@ -1983,9 +1985,9 @@ subroutine recruitment( currentSite, currentPatch, bc_in )

!
! !ARGUMENTS
type(ed_site_type), intent(inout), target :: currentSite
type(ed_patch_type), intent(inout), pointer :: currentPatch
type(bc_in_type), intent(in) :: bc_in
type(ed_site_type), intent(inout) :: currentSite
type(ed_patch_type), intent(inout),pointer :: currentPatch
type(bc_in_type), intent(in) :: bc_in
!
! !LOCAL VARIABLES:
class(prt_vartypes), pointer :: prt
Expand Down Expand Up @@ -2285,8 +2287,13 @@ subroutine recruitment( currentSite, currentPatch, bc_in )
endif !use_this_pft
enddo !pft loop

deallocate(temp_cohort) ! delete temporary cohort
deallocate(temp_cohort, stat=istat, errmsg=smsg)
if (istat/=0) then
write(fates_log(),*) 'dealloc013: fail on deallocate(temp_cohort):'//trim(smsg)
call endrun(msg=errMsg(sourcefile, __LINE__))
endif


end subroutine recruitment

! ============================================================================
Expand Down
Loading

0 comments on commit b8b905c

Please sign in to comment.