diff --git a/CHANGELOG.md b/CHANGELOG.md index 68cb55bb41a4..896a4b318cb2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,11 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] +### Added +- Added subroutine MAPL_MethodAdd to MAPL_Generic.F90 +- Added subrutines get_callbacks and copy_callbacks to OpenMP_Support.F90 +- These added subroutines are to support "callback" procedures when inside OpenMP parallel region for mini states for component level threading. + ### Added - Added `MAPL_find_bounds => find_bounds` and `MAPL_Interval => Interval` to `MAPL.F90` for use when doing component level OpenMP diff --git a/generic/CMakeLists.txt b/generic/CMakeLists.txt index 04b34fb8f012..901ec303d3ff 100644 --- a/generic/CMakeLists.txt +++ b/generic/CMakeLists.txt @@ -50,7 +50,11 @@ set (srcs RunEntryPoint.F90 EntryPointVector.F90 + + MAPL_ESMF_Interfaces.F90 + CallbackMap.F90 ) + if (BUILD_WITH_PFLOGGER) find_package(PFLOGGER REQUIRED) endif () diff --git a/generic/CallbackMap.F90 b/generic/CallbackMap.F90 new file mode 100644 index 000000000000..cf044357d061 --- /dev/null +++ b/generic/CallbackMap.F90 @@ -0,0 +1,19 @@ +module mapl_CallbackMap + + use mapl_ESMF_Interfaces + +#define Key __CHARACTER_DEFERRED +#define T CallbackMethodWrapper +#define Map CallbackMap +#define Pair CallbackPair +#define MapIterator CallbackMapIterator + +#include "map/template.inc" + +#undef MapIterator +#undef Pair +#undef Map +#undef T +#undef Key + +end module mapl_CallbackMap diff --git a/generic/MAPL_ESMF_Interfaces.F90 b/generic/MAPL_ESMF_Interfaces.F90 new file mode 100644 index 000000000000..8bf09ecfb260 --- /dev/null +++ b/generic/MAPL_ESMF_Interfaces.F90 @@ -0,0 +1,22 @@ +! This module is a collection of abstract interfaces that enforce +! interfaces of user routines that are passed to ESMF. + +module mapl_ESMF_Interfaces + implicit none + private ! except + public :: I_CallBackMethod + public :: CallbackMethodWrapper + + abstract interface + subroutine I_CallBackMethod(state, rc) + use ESMF + type(ESMF_State) :: state + integer, intent(out) :: rc + end subroutine I_CallBackMethod + end interface + + type CallbackMethodWrapper + procedure(I_CallBackMethod), pointer, nopass :: userRoutine + end type CallbackMethodWrapper + +end module mapl_ESMF_Interfaces diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index 7c67794be568..ed77a88b2b31 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -224,6 +224,7 @@ module MAPL_GenericMod public MAPL_GenericStateRestore public MAPL_RootGcRetrieve public MAPL_AddAttributeToFields + public MAPL_MethodAdd !BOP ! !PUBLIC TYPES: @@ -11547,4 +11548,32 @@ recursive subroutine MAPL_AddAttributeToFields_I4(gc,field_name,att_name,att_val _RETURN(_SUCCESS) end subroutine MAPL_AddAttributeToFields_I4 + subroutine MAPL_MethodAdd(state, label, userRoutine, rc) + use mapl_ESMF_Interfaces + use mapl_CallbackMap + use mapl_OpenMP_Support, only : get_callbacks + type(ESMF_State), intent(inout) :: state + character(*), intent(in) :: label + procedure(I_CallBackMethod) :: userRoutine + integer, optional, intent(out) :: rc + + integer :: status + type(CallbackMap), pointer :: callbacks + + call ESMF_MethodAdd(state, label=label, userRoutine=userRoutine, _RC) + + call get_callbacks(state, callbacks, _RC) + call callbacks%insert(label, wrap(userRoutine)) + + _RETURN(ESMF_SUCCESS) + contains + + function wrap(userRoutine) result(wrapper) + type(CallbackMethodWrapper) :: wrapper + procedure(I_CallBackMethod) :: userRoutine + wrapper%userRoutine => userRoutine + end function wrap + + end subroutine MAPL_MethodAdd + end module MAPL_GenericMod diff --git a/generic/MaplGenericComponent.F90 b/generic/MaplGenericComponent.F90 index 2d3a379744b9..e4e554b9b593 100644 --- a/generic/MaplGenericComponent.F90 +++ b/generic/MaplGenericComponent.F90 @@ -22,8 +22,6 @@ module mapl_MaplGenericComponent public :: MaplGenericComponent public :: get_grid - procedure(), pointer :: user_method => null() - type SubComponent type(ESMF_GridComp) :: gridcomp type(ESMF_State) :: internal_state diff --git a/generic/OpenMP_Support.F90 b/generic/OpenMP_Support.F90 index 901dfa3f59d8..329559994cdd 100644 --- a/generic/OpenMP_Support.F90 +++ b/generic/OpenMP_Support.F90 @@ -21,6 +21,7 @@ module MAPL_OpenMP_Support public :: subset_array public :: get_current_thread public :: get_num_threads + public :: get_callbacks type :: Interval integer :: min @@ -432,7 +433,7 @@ end function make_subFieldBundles_ordinary recursive function make_substates_from_num_grids(state, num_subgrids, unusable, rc) result(substates) type(ESMF_State), allocatable :: substates(:) - type(ESMF_State), intent(in) :: state + type(ESMF_State), intent(inout) :: state integer, intent(in) :: num_subgrids class(KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc @@ -491,6 +492,9 @@ recursive function make_substates_from_num_grids(state, num_subgrids, unusable, end do end if end do + + call copy_callbacks(state, substates, _RC) + _RETURN(0) end function make_substates_from_num_grids @@ -519,19 +523,20 @@ function make_subgridcomps(GridComp, run_entry_points, num_grids, unusable, rc) character(len=ESMF_MAXSTR) :: comp_name character(len=:), allocatable :: labels(:) integer :: phase + type(ESMF_Config) :: CF allocate(subgridcomps(num_grids)) call ESMF_VMGetCurrent(vm, _RC) call ESMF_VMGet(vm, localPET=myPET, _RC) - call ESMF_GridCompGet(GridComp, name=comp_name, _RC) + call ESMF_GridCompGet(GridComp, config=CF, name=comp_name, _RC) call ESMF_InternalStateGet(GridComp, labelList=labels, _RC) if(myPET==0) print*,__FILE__,__LINE__, 'internal states labels : <',trim(comp_name), (trim(labels(i)),i=1,size(labels)), '>' print*,__FILE__,__LINE__, 'splitting component: <',trim(comp_name),'>' do i = 1, num_grids associate (gc => subgridcomps(i) ) - gc = ESMF_GridCompCreate(name=trim(comp_name), petlist=[myPet], & + gc = ESMF_GridCompCreate(name=trim(comp_name), config=CF, petlist=[myPet], & & contextflag=ESMF_CONTEXT_OWN_VM, _RC) call ESMF_GridCompSetServices(gc, set_services, userrc=user_status, _RC) _VERIFY(user_status) @@ -544,7 +549,6 @@ function make_subgridcomps(GridComp, run_entry_points, num_grids, unusable, rc) do i = 1, num_grids associate (gc => subgridcomps(i) ) if (has_private_state) then - !print *, __FILE__, __LINE__, myPET, ilabel, i, trim(comp_name), trim(labels(ilabel)), has_private_state call ESMF_UserCompSetInternalState(gc, trim(labels(ilabel)), wrap, status) _VERIFY(status) end if @@ -570,6 +574,72 @@ subroutine set_services(gc, rc) end do _RETURN(ESMF_SUCCESS) end subroutine set_services + end function make_subgridcomps + subroutine copy_callbacks(state, multi_states, rc) + use mapl_ESMF_Interfaces + use mapl_CallbackMap + type(ESMF_State), intent(inout) :: state + type(ESMF_State), intent(inout) :: multi_states(:) + integer, optional, intent(out) :: rc + + integer :: n_multi, i + integer :: status + type(CallbackMethodWrapper), pointer :: wrapper + type(CallbackMap), pointer :: callbacks + type(CallbackMapIterator) :: iter + + n_multi = size(multi_states) + call get_callbacks(state, callbacks, _RC) + _ASSERT(associated(callbacks), 'callbacks must be associated') + associate( e => callbacks%end()) + iter = callbacks%begin() + do while (iter /= e) + wrapper => iter%second() + do i = 1, n_multi + call ESMF_MethodAdd(multi_states(i), label=iter%first(), userRoutine=wrapper%userRoutine, _RC) + end do + call iter%next() + end do + end associate + + _RETURN(ESMF_SUCCESS) + + end subroutine copy_callbacks + + subroutine get_callbacks(state, callbacks, rc) + use mapl_ESMF_Interfaces + use mapl_CallbackMap + type(ESMF_State), intent(inout) :: state + type(CallbackMap), pointer, intent(out) :: callbacks + integer, optional, intent(out) :: rc + + integer :: status + integer(kind=ESMF_KIND_I4), allocatable :: valueList(:) + logical :: isPresent + + type CallbackMapWrapper + type(CallbackMap), pointer :: map + end type + type(CallbackMapWrapper) :: wrapper + + call ESMF_AttributeGet(state, name='MAPL_CALLBACK_MAP', isPresent=isPresent, _RC) + if (.not. isPresent) then ! create callback map for this state + allocate(callbacks) + wrapper%map => callbacks + valueList = transfer(wrapper, valueList) + call ESMF_AttributeSet(state, name='MAPL_CALLBACK_MAP', valueList=valueList, _RC) + end if + + ! Ugly hack to decode ESMF attribute as a gFTL map + valueList = transfer(wrapper, valueList) + call ESMF_AttributeGet(state, name='MAPL_CALLBACK_MAP', valueList=valueList, _RC) + wrapper = transfer(valueList, wrapper) + callbacks => wrapper%map + + _RETURN(ESMF_SUCCESS) + + end subroutine get_callbacks + end module MAPL_OpenMP_Support