Shared MPI (MPI-3) Deallocate Error

[Gary_L_]

Good day,

I'm working with Shared MPI (MPI-3) in Fortran and I came across an odd deallocation error, so I'm reaching out to the community for assistance. I've followed the Shared MPI Fortran example provided on StackOverflow that works very well when the shared arrays are declared and destroyed from the main program; however, should one of these arrays be created/destroyed within a routine, a deallocation error occurs. To illustrate this point, I've created a simple working example, which needs 3 files: main, mod_setup, mod_work (code provided below).

In main, variable b is created (a 2D matrix size m x n) using mpi_win_allocate_shared; b is passed to the setup module, and variable a is created (3D matrix sized m x n x n) also using mpi_win_allocate_shared. Both a and b are then passed to the work module where a simple update is performed on the data and work returns without error. Before returning from setup, variable a is deallocated using mpi_win_free, which returns an error code of 0, but then when exiting setup, a deallocation error is thrown (for variable a).

This error should not occur because mpi_win_free is expected to perform the deallocation, correct? Can shared arrays only be allocated from the main program? Is there a way to avoid this error?

Thank you for your assistance,
Gary

Output:

[glaws003@turing1 simp]$ make
mpiifort -fpe0 -traceback mod_work.F -c
mpiifort -fpe0 -traceback mod_setup.F -c
mpiifort -fpe0 -traceback main.F -I. -c
mpiifort -fpe0 -traceback mod_work.o mod_setup.o main.o -o simp.x

[glaws003@turing1 simp]$ mpirun -np 2 ./simp.x
 srank:           1 of            2
 srank:           0 of            2
 start:           1 end:      500000
 start:      500001 end:     1000000
 SMPI deallocation- a with error code:           0
forrtl: severe (173): A pointer passed to DEALLOCATE points to an object that cannot be deallocated
Image              PC                Routine            Line        Source             
simp.x             000000000040B7E8  Unknown               Unknown  Unknown
simp.x             000000000040465F  mod_setup_mp_setu          59  mod_setup.F
simp.x             0000000000404927  MAIN__                     50  main.F
simp.x             0000000000403BDE  Unknown               Unknown  Unknown
libc-2.12.so       0000003134E1ED1D  __libc_start_main     Unknown  Unknown
simp.x             0000000000403AE9  Unknown               Unknown  Unknown

main.F

! A Simple Working Example of an SMPI Deallocation Error
!
      program smpi_deallocation_error
      use mod_setup
      use, intrinsic :: iso_c_binding
      include 'mpif.h'
      integer, parameter :: rtype = selected_real_kind(15, 307)
      !
      integer :: m=1000000, n=11, rnk
      integer :: rank,nranks,scomm,srank,nsranks,mpierr
      real(rtype), dimension(:, :), allocatable :: b
      integer :: bwin,disp_unit=1,smpi_root=1
      integer, dimension(2) :: shp
      type(c_ptr)           :: array_ptr
      integer(kind=mpi_address_kind)   :: ln
      common/mpi_blk/ rank,nranks,scomm,srank,nsranks,mpierr
      !
      ! MPI Initialization
      call mpi_init(mpierr)
      call mpi_comm_rank(mpi_comm_world,rank,mpierr)
      call mpi_comm_size(mpi_comm_world,nranks,mpierr)
      !
      ! SMPI Initialization 
      call mpi_comm_split_type(mpi_comm_world,mpi_comm_type_shared, 
     & 0,mpi_info_null,scomm,mpierr)
      call mpi_comm_rank(scomm,srank,mpierr)
      call mpi_comm_size(scomm,nsranks,mpierr)
      write(*,*) 'srank:',srank,'of ',nsranks
      !
      shp(1) = m
      shp(2) = n
      ! 1.    declare size of memory window
      if (srank == smpi_root) then    ! If master shared proc
         ln=int(shp(1)*shp(2),mpi_address_kind)*8_mpi_address_kind
      else                              ! If slave shared proc
         ln=0_mpi_address_kind
      end if
      ! 
      ! 2.    allocate memory (if smpi rank 0)
      call mpi_win_allocate_shared(ln,disp_unit,mpi_info_null,scomm,
     & array_ptr,bwin,mpierr)
      !
      ! 3.    query memory window (if smpi > 0)
      if (srank > smpi_root) then
         call mpi_win_shared_query(bwin,smpi_root,ln,disp_unit,
     & array_ptr,mpierr)
      end if
      !
      ! 4.    convert C pointer to Fortran pointer
      call c_f_pointer(array_ptr,b,shp)
      !
      call setup_work(n, m, b)
      !
      ! Clean up SMPI memory windows
      call mpi_win_free(bwin,mpierr)
      write(*,*) 'SMPI deallocation- b has error code:',mpierr
      call mpi_finalize(mpierr)
      !
      end program smpi_deallocation_error

mod_setup.F

! A Simple Working Example of an SMPI Deallocation Error
!
      module mod_setup
        use mod_work
        use, intrinsic :: iso_c_binding
        include 'mpif.h'
        private
        public :: setup_work
        !
      contains
        !
      subroutine setup_work(n, m, b)
        integer, parameter :: rtype = selected_real_kind(15, 307)
        integer,   intent(in) :: n, m
        real(rtype), dimension(1:m,1:n), intent(inout) :: b
        !
        real(rtype), allocatable, dimension(:,:,:)  :: a
        !
        integer :: i,j,k,awin,disp_unit=1,smpi_root=1
        integer :: rank,nranks,scomm,srank,nsranks,mpierr
        integer, dimension(3) :: shp
        type(c_ptr)           :: array_ptr
        integer(kind=mpi_address_kind)   :: ln
        common/mpi_blk/ rank,nranks,scomm,srank,nsranks,mpierr
        !
      continue
        !
        shp(1) = m
        shp(2) = n
        shp(3) = n
        ! 1.    declare size of memory window
        if (srank == smpi_root) then    ! If master shared proc
          ln=int(shp(1)*shp(2)*shp(3),mpi_address_kind)
     & *8_mpi_address_kind
        else                              ! If slave shared proc
           ln=0_mpi_address_kind
        end if
        ! 
        ! 2.    allocate memory (if smpi rank 0)
        call mpi_win_allocate_shared(ln,disp_unit,mpi_info_null,scomm,
     & array_ptr,awin,mpierr)
        !
        ! 3.    query memory window (if smpi > 0)
        if (srank > smpi_root) then
           call mpi_win_shared_query(awin,smpi_root,ln,disp_unit,
     & array_ptr,mpierr)
        end if
        !
        ! 4.    convert C pointer to Fortran pointer
        call c_f_pointer(array_ptr,a,shp)
        !
        ! Do work
        call do_work(n, m, a, b)
        !
        ! Clean up SMPI memory windows
        call mpi_win_free(awin,mpierr)
        write(*,*) 'SMPI deallocation- a with error code:',mpierr
        !
        ! SMPI error occurs as this routine ends
      end subroutine setup_work 
      !
      end module mod_setup

mod_work.F

! A Simple Working Example of an SMPI Deallocation Error
!
      module mod_work
        include 'mpif.h'
        private
        public :: do_work
        !
      contains
        !
      subroutine do_work(n, m, a, b)
        integer, parameter :: rtype = selected_real_kind(15, 307)
        integer,   intent(in) :: n, m
        real(rtype), dimension(1:m,1:n,1:n), intent(inout) :: a
        real(rtype), dimension(1:m,1:n), intent(inout) :: b
        !
        integer :: i,j,k,ms,me
        integer :: rank,nranks,scomm,srank,nsranks,mpierr
        common/mpi_blk/ rank,nranks,scomm,srank,nsranks,mpierr
        !
      continue
        !
        ! Divide work among shared MPI ranks
        ms = 1 + (srank * (m/nsranks))
        me = (1 + srank) * (m/nsranks)
        if (srank == nsranks-1) then  me = m end if
        write(*,*) 'start:',ms,'end:',me
        !
        do k=1,n
          do j=1,n
            do i=ms,me
              a(i,j,k) = i + j * k
              if (k == 1) then
                b(i,j) = i + j
              end if
            end do
          end do
        end do
        !
      end subroutine do_work
      !
      end module mod_work