module shared_memory_mpi_bool use mpi use Parallel_neci use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer use constants use scalar_shared_memory_mpi use util_mod, only: stop_all implicit none interface shared_allocate_mpi module procedure shared_allocate_mpi_bool end interface interface shared_deallocate_mpi module procedure shared_deallocate_mpi_bool end interface contains subroutine shared_allocate_mpi_bool (win_shm, p_shm, dims, ierr) use HElem integer(MPIArg):: win_shm integer, intent(out), optional :: ierr logical, dimension(:), pointer :: p_shm integer(int64):: dims(1) integer(MPIArg):: disp_unit integer(MPIArg) :: ierr_, jerr, errorclass, length integer(kind=mpi_address_kind):: wsize character(255) :: string TYPE(C_PTR):: cptr_shm character(*), parameter :: this_routine = 'shared_allocate_mpi' #ifdef SHARED_MEM_ if (iProcIndex_intra.eq.0) then wsize=product(dims)*(4) else wsize=0 end if call mpi_win_allocate_shared(wsize,int(4,MPIArg),MPI_INFO_NULL,mpi_comm_intra,& cptr_shm,win_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif call mpi_win_shared_query(win_shm,0_MPIArg,wsize,disp_unit,cptr_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif !map to Fortran array pointer call c_f_pointer(cptr_shm,p_shm,dims) !start read/write epoch for this window call mpi_win_lock_all(MPI_MODE_NOCHECK,win_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif #else ! no shared memory features used call variadic_allocate(p_shm,dims) #endif end subroutine subroutine shared_deallocate_mpi_bool(win_shm, p_shm, ierr) integer(MPIArg):: win_shm logical, dimension(:), pointer :: p_shm integer, intent(out), optional :: ierr integer(MPIArg) :: ierr_, jerr, errorclass, length character(len=255) :: string character(*), parameter :: this_routine = 'shared_deallocate_mpi' #ifdef SHARED_MEM_ nullify(p_shm) call mpi_win_unlock_all(win_shm, ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif call mpi_win_free(win_shm, ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif #else deallocate(p_shm) #endif end subroutine end module module shared_memory_mpi_int use mpi use Parallel_neci use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer use constants use scalar_shared_memory_mpi use util_mod, only: stop_all implicit none interface shared_allocate_mpi module procedure shared_allocate_mpi_int end interface interface shared_deallocate_mpi module procedure shared_deallocate_mpi_int end interface contains subroutine shared_allocate_mpi_int (win_shm, p_shm, dims, ierr) use HElem integer(MPIArg):: win_shm integer, intent(out), optional :: ierr integer(int32), dimension(:), pointer :: p_shm integer(int64):: dims(1) integer(MPIArg):: disp_unit integer(MPIArg) :: ierr_, jerr, errorclass, length integer(kind=mpi_address_kind):: wsize character(255) :: string TYPE(C_PTR):: cptr_shm character(*), parameter :: this_routine = 'shared_allocate_mpi' #ifdef SHARED_MEM_ if (iProcIndex_intra.eq.0) then wsize=product(dims)*(4) else wsize=0 end if call mpi_win_allocate_shared(wsize,int(4,MPIArg),MPI_INFO_NULL,mpi_comm_intra,& cptr_shm,win_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif call mpi_win_shared_query(win_shm,0_MPIArg,wsize,disp_unit,cptr_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif !map to Fortran array pointer call c_f_pointer(cptr_shm,p_shm,dims) !start read/write epoch for this window call mpi_win_lock_all(MPI_MODE_NOCHECK,win_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif #else ! no shared memory features used call variadic_allocate(p_shm,dims) #endif end subroutine subroutine shared_deallocate_mpi_int(win_shm, p_shm, ierr) integer(MPIArg):: win_shm integer(int32), dimension(:), pointer :: p_shm integer, intent(out), optional :: ierr integer(MPIArg) :: ierr_, jerr, errorclass, length character(len=255) :: string character(*), parameter :: this_routine = 'shared_deallocate_mpi' #ifdef SHARED_MEM_ nullify(p_shm) call mpi_win_unlock_all(win_shm, ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif call mpi_win_free(win_shm, ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif #else deallocate(p_shm) #endif end subroutine end module module shared_memory_mpi_int64 use mpi use Parallel_neci use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer use constants use scalar_shared_memory_mpi use util_mod, only: stop_all implicit none interface shared_allocate_mpi module procedure shared_allocate_mpi_int64 end interface interface shared_deallocate_mpi module procedure shared_deallocate_mpi_int64 end interface contains subroutine shared_allocate_mpi_int64 (win_shm, p_shm, dims, ierr) use HElem integer(MPIArg):: win_shm integer, intent(out), optional :: ierr integer(int64), dimension(:), pointer :: p_shm integer(int64):: dims(1) integer(MPIArg):: disp_unit integer(MPIArg) :: ierr_, jerr, errorclass, length integer(kind=mpi_address_kind):: wsize character(255) :: string TYPE(C_PTR):: cptr_shm character(*), parameter :: this_routine = 'shared_allocate_mpi' #ifdef SHARED_MEM_ if (iProcIndex_intra.eq.0) then wsize=product(dims)*(8) else wsize=0 end if call mpi_win_allocate_shared(wsize,int(8,MPIArg),MPI_INFO_NULL,mpi_comm_intra,& cptr_shm,win_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif call mpi_win_shared_query(win_shm,0_MPIArg,wsize,disp_unit,cptr_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif !map to Fortran array pointer call c_f_pointer(cptr_shm,p_shm,dims) !start read/write epoch for this window call mpi_win_lock_all(MPI_MODE_NOCHECK,win_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif #else ! no shared memory features used call variadic_allocate(p_shm,dims) #endif end subroutine subroutine shared_deallocate_mpi_int64(win_shm, p_shm, ierr) integer(MPIArg):: win_shm integer(int64), dimension(:), pointer :: p_shm integer, intent(out), optional :: ierr integer(MPIArg) :: ierr_, jerr, errorclass, length character(len=255) :: string character(*), parameter :: this_routine = 'shared_deallocate_mpi' #ifdef SHARED_MEM_ nullify(p_shm) call mpi_win_unlock_all(win_shm, ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif call mpi_win_free(win_shm, ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif #else deallocate(p_shm) #endif end subroutine end module module shared_memory_mpi_doub use mpi use Parallel_neci use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer use constants use scalar_shared_memory_mpi use util_mod, only: stop_all implicit none interface shared_allocate_mpi module procedure shared_allocate_mpi_doub end interface interface shared_deallocate_mpi module procedure shared_deallocate_mpi_doub end interface contains subroutine shared_allocate_mpi_doub (win_shm, p_shm, dims, ierr) use HElem integer(MPIArg):: win_shm integer, intent(out), optional :: ierr real(dp), dimension(:), pointer :: p_shm integer(int64):: dims(1) integer(MPIArg):: disp_unit integer(MPIArg) :: ierr_, jerr, errorclass, length integer(kind=mpi_address_kind):: wsize character(255) :: string TYPE(C_PTR):: cptr_shm character(*), parameter :: this_routine = 'shared_allocate_mpi' #ifdef SHARED_MEM_ if (iProcIndex_intra.eq.0) then wsize=product(dims)*(sizeof_dp) else wsize=0 end if call mpi_win_allocate_shared(wsize,int(sizeof_dp,MPIArg),MPI_INFO_NULL,mpi_comm_intra,& cptr_shm,win_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif call mpi_win_shared_query(win_shm,0_MPIArg,wsize,disp_unit,cptr_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif !map to Fortran array pointer call c_f_pointer(cptr_shm,p_shm,dims) !start read/write epoch for this window call mpi_win_lock_all(MPI_MODE_NOCHECK,win_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif #else ! no shared memory features used call variadic_allocate(p_shm,dims) #endif end subroutine subroutine shared_deallocate_mpi_doub(win_shm, p_shm, ierr) integer(MPIArg):: win_shm real(dp), dimension(:), pointer :: p_shm integer, intent(out), optional :: ierr integer(MPIArg) :: ierr_, jerr, errorclass, length character(len=255) :: string character(*), parameter :: this_routine = 'shared_deallocate_mpi' #ifdef SHARED_MEM_ nullify(p_shm) call mpi_win_unlock_all(win_shm, ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif call mpi_win_free(win_shm, ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif #else deallocate(p_shm) #endif end subroutine end module module shared_memory_mpi_comp use mpi use Parallel_neci use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer use constants use scalar_shared_memory_mpi use util_mod, only: stop_all implicit none interface shared_allocate_mpi module procedure shared_allocate_mpi_comp end interface interface shared_deallocate_mpi module procedure shared_deallocate_mpi_comp end interface contains subroutine shared_allocate_mpi_comp (win_shm, p_shm, dims, ierr) use HElem integer(MPIArg):: win_shm integer, intent(out), optional :: ierr complex(dp), dimension(:), pointer :: p_shm integer(int64):: dims(1) integer(MPIArg):: disp_unit integer(MPIArg) :: ierr_, jerr, errorclass, length integer(kind=mpi_address_kind):: wsize character(255) :: string TYPE(C_PTR):: cptr_shm character(*), parameter :: this_routine = 'shared_allocate_mpi' #ifdef SHARED_MEM_ if (iProcIndex_intra.eq.0) then wsize=product(dims)*((2*dp)) else wsize=0 end if call mpi_win_allocate_shared(wsize,int((2*dp),MPIArg),MPI_INFO_NULL,mpi_comm_intra,& cptr_shm,win_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif call mpi_win_shared_query(win_shm,0_MPIArg,wsize,disp_unit,cptr_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif !map to Fortran array pointer call c_f_pointer(cptr_shm,p_shm,dims) !start read/write epoch for this window call mpi_win_lock_all(MPI_MODE_NOCHECK,win_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif #else ! no shared memory features used call variadic_allocate(p_shm,dims) #endif end subroutine subroutine shared_deallocate_mpi_comp(win_shm, p_shm, ierr) integer(MPIArg):: win_shm complex(dp), dimension(:), pointer :: p_shm integer, intent(out), optional :: ierr integer(MPIArg) :: ierr_, jerr, errorclass, length character(len=255) :: string character(*), parameter :: this_routine = 'shared_deallocate_mpi' #ifdef SHARED_MEM_ nullify(p_shm) call mpi_win_unlock_all(win_shm, ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif call mpi_win_free(win_shm, ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif #else deallocate(p_shm) #endif end subroutine end module module shared_memory_mpi_comp2D use mpi use Parallel_neci use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer use constants use scalar_shared_memory_mpi use util_mod, only: stop_all implicit none interface shared_allocate_mpi module procedure shared_allocate_mpi_comp2D end interface interface shared_deallocate_mpi module procedure shared_deallocate_mpi_comp2D end interface contains subroutine shared_allocate_mpi_comp2D (win_shm, p_shm, dims, ierr) use HElem integer(MPIArg):: win_shm integer, intent(out), optional :: ierr complex(dp), dimension(:,:), pointer :: p_shm integer(int64):: dims(2) integer(MPIArg):: disp_unit integer(MPIArg) :: ierr_, jerr, errorclass, length integer(kind=mpi_address_kind):: wsize character(255) :: string TYPE(C_PTR):: cptr_shm character(*), parameter :: this_routine = 'shared_allocate_mpi' #ifdef SHARED_MEM_ if (iProcIndex_intra.eq.0) then wsize=product(dims)*((2*sizeof_dp)) else wsize=0 end if call mpi_win_allocate_shared(wsize,int((2*sizeof_dp),MPIArg),MPI_INFO_NULL,mpi_comm_intra,& cptr_shm,win_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif call mpi_win_shared_query(win_shm,0_MPIArg,wsize,disp_unit,cptr_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif !map to Fortran array pointer call c_f_pointer(cptr_shm,p_shm,dims) !start read/write epoch for this window call mpi_win_lock_all(MPI_MODE_NOCHECK,win_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif #else ! no shared memory features used call variadic_allocate(p_shm,dims) #endif end subroutine subroutine shared_deallocate_mpi_comp2D(win_shm, p_shm, ierr) integer(MPIArg):: win_shm complex(dp), dimension(:,:), pointer :: p_shm integer, intent(out), optional :: ierr integer(MPIArg) :: ierr_, jerr, errorclass, length character(len=255) :: string character(*), parameter :: this_routine = 'shared_deallocate_mpi' #ifdef SHARED_MEM_ nullify(p_shm) call mpi_win_unlock_all(win_shm, ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif call mpi_win_free(win_shm, ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif #else deallocate(p_shm) #endif end subroutine end module module shared_memory_mpi_arr_int use mpi use Parallel_neci use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer use constants use scalar_shared_memory_mpi use util_mod, only: stop_all implicit none interface shared_allocate_mpi module procedure shared_allocate_mpi_arr_int end interface interface shared_deallocate_mpi module procedure shared_deallocate_mpi_arr_int end interface contains subroutine shared_allocate_mpi_arr_int (win_shm, p_shm, dims, ierr) use HElem integer(MPIArg):: win_shm integer, intent(out), optional :: ierr integer(int32), dimension(:,:), pointer :: p_shm integer(int64):: dims(2) integer(MPIArg):: disp_unit integer(MPIArg) :: ierr_, jerr, errorclass, length integer(kind=mpi_address_kind):: wsize character(255) :: string TYPE(C_PTR):: cptr_shm character(*), parameter :: this_routine = 'shared_allocate_mpi' #ifdef SHARED_MEM_ if (iProcIndex_intra.eq.0) then wsize=product(dims)*(4) else wsize=0 end if call mpi_win_allocate_shared(wsize,int(4,MPIArg),MPI_INFO_NULL,mpi_comm_intra,& cptr_shm,win_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif call mpi_win_shared_query(win_shm,0_MPIArg,wsize,disp_unit,cptr_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif !map to Fortran array pointer call c_f_pointer(cptr_shm,p_shm,dims) !start read/write epoch for this window call mpi_win_lock_all(MPI_MODE_NOCHECK,win_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif #else ! no shared memory features used call variadic_allocate(p_shm,dims) #endif end subroutine subroutine shared_deallocate_mpi_arr_int(win_shm, p_shm, ierr) integer(MPIArg):: win_shm integer(int32), dimension(:,:), pointer :: p_shm integer, intent(out), optional :: ierr integer(MPIArg) :: ierr_, jerr, errorclass, length character(len=255) :: string character(*), parameter :: this_routine = 'shared_deallocate_mpi' #ifdef SHARED_MEM_ nullify(p_shm) call mpi_win_unlock_all(win_shm, ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif call mpi_win_free(win_shm, ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif #else deallocate(p_shm) #endif end subroutine end module module shared_memory_mpi_arr_int64 use mpi use Parallel_neci use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer use constants use scalar_shared_memory_mpi use util_mod, only: stop_all implicit none interface shared_allocate_mpi module procedure shared_allocate_mpi_arr_int64 end interface interface shared_deallocate_mpi module procedure shared_deallocate_mpi_arr_int64 end interface contains subroutine shared_allocate_mpi_arr_int64 (win_shm, p_shm, dims, ierr) use HElem integer(MPIArg):: win_shm integer, intent(out), optional :: ierr integer(int64), dimension(:,:), pointer :: p_shm integer(int64):: dims(2) integer(MPIArg):: disp_unit integer(MPIArg) :: ierr_, jerr, errorclass, length integer(kind=mpi_address_kind):: wsize character(255) :: string TYPE(C_PTR):: cptr_shm character(*), parameter :: this_routine = 'shared_allocate_mpi' #ifdef SHARED_MEM_ if (iProcIndex_intra.eq.0) then wsize=product(dims)*(8) else wsize=0 end if call mpi_win_allocate_shared(wsize,int(8,MPIArg),MPI_INFO_NULL,mpi_comm_intra,& cptr_shm,win_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif call mpi_win_shared_query(win_shm,0_MPIArg,wsize,disp_unit,cptr_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif !map to Fortran array pointer call c_f_pointer(cptr_shm,p_shm,dims) !start read/write epoch for this window call mpi_win_lock_all(MPI_MODE_NOCHECK,win_shm,ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif #else ! no shared memory features used call variadic_allocate(p_shm,dims) #endif end subroutine subroutine shared_deallocate_mpi_arr_int64(win_shm, p_shm, ierr) integer(MPIArg):: win_shm integer(int64), dimension(:,:), pointer :: p_shm integer, intent(out), optional :: ierr integer(MPIArg) :: ierr_, jerr, errorclass, length character(len=255) :: string character(*), parameter :: this_routine = 'shared_deallocate_mpi' #ifdef SHARED_MEM_ nullify(p_shm) call mpi_win_unlock_all(win_shm, ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif call mpi_win_free(win_shm, ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif #else deallocate(p_shm) #endif end subroutine end module module shared_memory_mpi use shared_memory_mpi_bool use shared_memory_mpi_int use shared_memory_mpi_int64 use shared_memory_mpi_doub use shared_memory_mpi_comp use shared_memory_mpi_comp2D use shared_memory_mpi_arr_int use shared_memory_mpi_arr_int64 use scalar_shared_memory_mpi implicit none contains #ifdef SHARED_MEM_ subroutine shared_sync_mpi(win_shm, ierr) integer(MPIArg):: win_shm integer, intent(out), optional :: ierr integer(MPIArg) :: ierr_, jerr, errorclass, length character(len=255) :: string character(*), parameter :: this_routine = 'shared_sync_mpi' call mpi_win_sync(win_shm, ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif call mpi_barrier(mpi_comm_intra, ierr_) if (present(ierr)) ierr = int(ierr_) if (ierr_ /= MPI_SUCCESS) then if (present(ierr)) then return else call mpi_error_class(ierr_, errorclass, jerr) call mpi_error_string(errorclass,string, length, jerr) call stop_all(this_routine, string) end if endif end subroutine shared_sync_mpi #else subroutine shared_sync_mpi(win_shm) integer(MPIArg):: win_shm end subroutine shared_sync_mpi #endif end module