diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index d3ce44f499..3ce5f38e29 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -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 @@ -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 @@ -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, & diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 1fe3ffb4e0..55d64315a8 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -134,7 +134,7 @@ Module EDCohortDynamicsMod public :: DamageRecovery logical, parameter :: debug = .false. ! local debug flag - + character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -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? @@ -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 @@ -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 @@ -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 !-------------------------------------------------------------------------------------! @@ -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) @@ -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) @@ -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 @@ -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: @@ -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 !---------------------------------------------------------------------- @@ -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 @@ -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 diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 9ff5f49594..2e85f5e62a 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -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 @@ -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: @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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) @@ -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 @@ -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 @@ -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 diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 0c6c296ad2..cb10597b0f 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -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 @@ -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 @@ -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 ! ============================================================================ diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 79d5974042..752781dfb5 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -88,6 +88,8 @@ module EDInitMod logical :: debug = .false. + integer :: istat ! return status code + character(len=255) :: smsg ! Message string for deallocation errors character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -111,8 +113,8 @@ subroutine init_site_vars( site_in, bc_in, bc_out ) ! ! !ARGUMENTS type(ed_site_type), intent(inout) :: site_in - type(bc_in_type),intent(in),target :: bc_in - type(bc_out_type),intent(in),target :: bc_out + type(bc_in_type),intent(in) :: bc_in + type(bc_out_type),intent(in) :: bc_out ! ! !LOCAL VARIABLES: !---------------------------------------------------------------------- @@ -333,9 +335,9 @@ subroutine set_site_properties( nsites, sites,bc_in ) ! ! !ARGUMENTS - integer, intent(in) :: nsites - type(ed_site_type) , intent(inout), target :: sites(nsites) - type(bc_in_type), intent(in) :: bc_in(nsites) + integer, intent(in) :: nsites + type(ed_site_type) , intent(inout) :: sites(nsites) + type(bc_in_type), intent(in) :: bc_in(nsites) ! ! !LOCAL VARIABLES: integer :: s @@ -966,8 +968,12 @@ subroutine init_cohorts( site_in, patch_in, bc_in) temp_cohort%coage, temp_cohort%dbh, prt_obj, cstatus, rstatus, & temp_cohort%canopy_trim, temp_cohort%c_area,1,temp_cohort%crowndamage, site_in%spread, bc_in) - deallocate(temp_cohort) ! get rid of temporary cohort - + deallocate(temp_cohort, stat=istat, errmsg=smsg) + if (istat/=0) then + write(fates_log(),*) 'dealloc014: fail on deallocate(temp_cohort):'//trim(smsg) + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + endif endif !use_this_pft enddo !numpft diff --git a/parteh/PRTAllometricCNPMod.F90 b/parteh/PRTAllometricCNPMod.F90 index 9e53e422a6..0f4b29b4b6 100644 --- a/parteh/PRTAllometricCNPMod.F90 +++ b/parteh/PRTAllometricCNPMod.F90 @@ -286,10 +286,14 @@ subroutine InitPRTGlobalAllometricCNP() ! ----------------------------------------------------------------------------------- integer :: nleafage + integer :: istat + character(len=255) :: smsg - allocate(prt_global_acnp) - allocate(prt_global_acnp%state_descriptor(num_vars)) - + allocate(prt_global_acnp, stat=istat, errmsg=smsg) + if (istat/=0) call endrun(msg='allocate stat/=0:'//trim(smsg)//errMsg(sourcefile, __LINE__)) + allocate(prt_global_acnp%state_descriptor(num_vars), stat=istat, errmsg=smsg) + if (istat/=0) call endrun(msg='allocate stat/=0:'//trim(smsg)//errMsg(sourcefile, __LINE__)) + prt_global_acnp%hyp_name = 'Allometric Flexible C+N+P' prt_global_acnp%hyp_id = prt_cnp_flex_allom_hyp @@ -1927,6 +1931,8 @@ subroutine CNPAllocateRemainder(this, c_gain,n_gain,p_gain, & + nullify(dbh) + return end subroutine CNPAllocateRemainder @@ -2089,7 +2095,9 @@ function GetNutrientTargetCNP(this,element_id,organ_id,stoich_mode) result(targe call endrun(msg=errMsg(sourcefile, __LINE__)) end if end if - + + nullify(dbh) + return end function GetNutrientTargetCNP diff --git a/parteh/PRTGenericMod.F90 b/parteh/PRTGenericMod.F90 index ca8d337b31..3f76517254 100644 --- a/parteh/PRTGenericMod.F90 +++ b/parteh/PRTGenericMod.F90 @@ -873,33 +873,41 @@ subroutine DeallocatePRTVartypes(this) ! --------------------------------------------------------------------------------- class(prt_vartypes) :: this - integer :: i_var + integer :: i_var, istat + character(len=255) :: smsg ! Check to see if there is any value in these pools? ! SHould not deallocate if there is any carbon left if(allocated(this%variables)) then do i_var = 1, prt_global%num_vars - deallocate(this%variables(i_var)%val) - deallocate(this%variables(i_var)%val0) - deallocate(this%variables(i_var)%net_alloc) - deallocate(this%variables(i_var)%turnover) - deallocate(this%variables(i_var)%burned) + deallocate( & + this%variables(i_var)%val, & + this%variables(i_var)%val0, & + this%variables(i_var)%net_alloc, & + this%variables(i_var)%turnover, & + this%variables(i_var)%burned, & + stat=istat, errmsg=smsg ) + if (istat/=0) call endrun(msg='DeallocatePRTVartypes 1 stat/=0:'//trim(smsg)//errMsg(sourcefile, __LINE__)) end do - - deallocate(this%variables) + + deallocate(this%variables, stat=istat, errmsg=smsg) + if (istat/=0) call endrun(msg='DeallocatePRTVartypes 2 stat/=0:'//trim(smsg)//errMsg(sourcefile, __LINE__)) end if if(allocated(this%bc_in))then - deallocate(this%bc_in) + deallocate(this%bc_in, stat=istat, errmsg=smsg) + if (istat/=0) call endrun(msg='DeallocatePRTVartypes bc_in stat/=0:'//trim(smsg)//errMsg(sourcefile, __LINE__)) end if if(allocated(this%bc_out))then - deallocate(this%bc_out) + deallocate(this%bc_out, stat=istat, errmsg=smsg) + if (istat/=0) call endrun(msg='DeallocatePRTVartypes bc_out stat/=0:'//trim(smsg)//errMsg(sourcefile, __LINE__)) end if if(allocated(this%bc_inout))then - deallocate(this%bc_inout) + deallocate(this%bc_inout, stat=istat, errmsg=smsg) + if (istat/=0) call endrun(msg='DeallocatePRTVartypes bc_inout stat/=0:'//trim(smsg)//errMsg(sourcefile, __LINE__)) end if return