如何编写一个函数以在Fortran中返回分配的共享内存数组？

Question

我想创建一个子程序，该子程序接受一个ALLOCATABLE数组并返回一个MPI共享内存数组。

我有一堆用MPI编写的代码，我们使用ALLOCATABLE数组。现在，这些数组中的许多数组在节点之间都是相同的，因此最好将它们存储在某种类型的共享内存对象中。现在，我发现了这个示例（MPI Fortran code: how to share data on node via openMP?），它可以作为独立代码使用，但是当我尝试将其实现为子例程时，我从C_F_POINTER调用中遇到了Segmentation Fault。

驱动程序例行程序

PROGRAM TEST_SUBROUTINE
   ! Libraries
   USE MPI

   IMPLICIT NONE

   ! Variables
   INTEGER :: ier, myid, numprocs
   INTEGER :: myid_shar, numprocs_shar
   INTEGER :: MPI_COMM_SHARMEM, win_a
   DOUBLE PRECISION, POINTER :: A(:)

   ! Code
    CALL MPI_INIT(ier)
    CALL MPI_COMM_RANK( MPI_COMM_WORLD, myid, ier )
    CALL MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ier)
    myid_shar=0
    CALL MPI_COMM_SPLIT_TYPE(MPI_COMM_WORLD, MPI_COMM_TYPE_SHARED, 0, MPI_INFO_NULL, MPI_COMM_SHARMEM, ier)
    CALL MPI_COMM_RANK( MPI_COMM_SHARMEM, myid_shar, ier )
    CALL MPI_COMM_SIZE( MPI_COMM_SHARMEM, numprocs_shar, ier)

    CALL mpialloc_1d_dbl(A,numprocs_shar,myid_shar,0,MPI_COMM_SHARMEM,win_a)

    A(myid_shar+1) = myid_shar
    CALL MPI_WIN_FENCE(0, win_a, ier)

    IF (myid == 0) THEN
       PRINT *,A(1)
       PRINT *,A(2)
       PRINT *,A(3)
       PRINT *,A(4)
    END IF

    ! FREE Window
    CALL MPI_WIN_FENCE(0, win_a, ier)
    CALL MPI_BARRIER(MPI_COMM_SHARMEM, ier)
    CALL MPI_WIN_FREE(win_a,ier)

    ! FREE MPI_COMM_SHARMEM
    CALL MPI_BARRIER(MPI_COMM_SHARMEM, ier)
    CALL MPI_COMM_FREE(MPI_COMM_SHARMEM,ier)

    ! END MPI
    CALL MPI_BARRIER(MPI_COMM_WORLD, ier)
    CALL MPI_FINALIZE(ier)

END PROGRAM TEST_SUBROUTINE

子例程看起来像（请注意，我尝试过使用数组变量，但是运气不佳）

SUBROUTINE mpialloc_1d_dbl(array,n1,subid,mymaster,share_comm,win)
    ! Libraries
    USE MPI
    USE ISO_C_BINDING

    IMPLICIT NONE

    ! Arguments
    DOUBLE PRECISION, POINTER, INTENT(inout) :: array(:)
    INTEGER, INTENT(in) :: n1
    INTEGER, INTENT(in) :: subid
    INTEGER, INTENT(in) :: mymaster
    INTEGER, INTENT(inout) :: share_comm
    INTEGER, INTENT(inout) :: win

    ! Variables
    INTEGER :: disp_unit, ier
    INTEGER :: array_shape(1)
    INTEGER(KIND=MPI_ADDRESS_KIND) :: window_size
    TYPE(C_PTR) :: baseptr

    ier = 0
    array_shape(1) = n1
    disp_unit = 8_MPI_ADDRESS_KIND
    window_size = 0_MPI_ADDRESS_KIND
    IF (subid == mymaster) window_size = INT(n1,MPI_ADDRESS_KIND)
    CALL MPI_BARRIER(share_comm, ier)
    CALL MPI_WIN_ALLOCATE_SHARED(window_size, disp_unit, MPI_INFO_NULL, share_comm, baseptr, win ,ier)
    IF (subid /= mymaster) CALL MPI_WIN_SHARED_QUERY(win, 0, window_size, disp_unit, baseptr, ier)
    CALL C_F_POINTER(baseptr, array, array_shape)
    CALL MPI_WIN_FENCE(0, win, ier)

    RETURN

END SUBROUTINE mpialloc_1d_dbl

我想要的是一个子例程，该例程的行为类似于简单的ALLOCATE语句，返回共享内存POINTER和FENCE调用的窗口变量。

Answer 1

好的，所以这里的错误与调用Fortran 90样式子例程有关。请参阅此链接以获取部分说明（http://www.cs.rpi.edu/~szymansk/OOF90/bugs.html#8）现在在上面的示例中，我实际上只是将子例程放在程序的末尾。这具有充当隐式接口语句的作用（至少在GFORTRAN和INTEL编译器中）。因此，我的伪代码运行良好，但是在我的生产代码中，该子例程作为许多其他代码所调用的通用库的一部分而添加。如果将我的伪代码链接到该库，该库是伪代码中子例程的复制粘贴，则该代码将像生产代码中那样崩溃。但是，如果我添加了一个INTERFACE块，一切都会很好。

那我离开哪里了？对于“原因”，我不想编写另一个专门的模块，但是似乎无论如何我都必须将所有各种共享内存子例程放入其中。另一种选择是将接口块添加到共享内存的每一位，以分配子代码（空白）。

这是固定的代码，但是您需要单独编译子例程和程序，并进行链接，以查看拥有/不拥有INTERFACE块的效果。

主程序：

PROGRAM TEST_SUBROUTINE
   ! Libraries
   USE MPI

   IMPLICIT NONE

   INTERFACE
      SUBROUTINE mpialloc_1d_dbl(array,n1,subid,mymaster,share_comm,win)
      DOUBLE PRECISION, POINTER, INTENT(inout) :: array(:)
      INTEGER, INTENT(in) :: n1
      INTEGER, INTENT(in) :: subid
      INTEGER, INTENT(in) :: mymaster
      INTEGER, INTENT(inout) :: share_comm
      INTEGER, INTENT(inout) :: win
      END SUBROUTINE mpialloc_1d_dbl
   END INTERFACE

   ! Variables
   INTEGER :: ier, myid, numprocs
   INTEGER :: myid_shar, numprocs_shar
   INTEGER :: MPI_COMM_SHARMEM, win_a
   DOUBLE PRECISION, POINTER :: A(:)

   ! Code
    CALL MPI_INIT(ier)
    CALL MPI_COMM_RANK( MPI_COMM_WORLD, myid, ier )
    CALL MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ier)
    myid_shar=0
    CALL MPI_COMM_SPLIT_TYPE(MPI_COMM_WORLD, MPI_COMM_TYPE_SHARED, 0, MPI_INFO_NULL, MPI_COMM_SHARMEM, ier)
    CALL MPI_COMM_RANK( MPI_COMM_SHARMEM, myid_shar, ier )
    CALL MPI_COMM_SIZE( MPI_COMM_SHARMEM, numprocs_shar, ier)

    CALL mpialloc_1d_dbl(A,numprocs_shar,myid_shar,0,MPI_COMM_SHARMEM,win_a)

    A(myid_shar+1) = myid_shar
    CALL MPI_WIN_FENCE(0, win_a, ier)

    IF (myid == 0) THEN
       PRINT *,A(1)
       PRINT *,A(2)
       PRINT *,A(3)
       PRINT *,A(4)
    END IF

    ! FREE Window
    CALL MPI_WIN_FENCE(0, win_a, ier)
    CALL MPI_BARRIER(MPI_COMM_SHARMEM, ier)
    CALL MPI_WIN_FREE(win_a,ier)

    ! FREE MPI_COMM_SHARMEM
    CALL MPI_BARRIER(MPI_COMM_SHARMEM, ier)
    CALL MPI_COMM_FREE(MPI_COMM_SHARMEM,ier)

    ! END MPI
    CALL MPI_BARRIER(MPI_COMM_WORLD, ier)
    CALL MPI_FINALIZE(ier)

END PROGRAM TEST_SUBROUTINE

子例程：

SUBROUTINE mpialloc_1d_dbl(array,n1,subid,mymaster,share_comm,win)
    ! Libraries
    USE MPI
    USE ISO_C_BINDING

    IMPLICIT NONE

    ! Arguments
    DOUBLE PRECISION, POINTER, INTENT(inout) :: array(:)
    INTEGER, INTENT(in) :: n1
    INTEGER, INTENT(in) :: subid
    INTEGER, INTENT(in) :: mymaster
    INTEGER, INTENT(inout) :: share_comm
    INTEGER, INTENT(inout) :: win

    ! Variables
    INTEGER :: disp_unit, ier
    INTEGER :: array_shape(1)
    INTEGER(KIND=MPI_ADDRESS_KIND) :: window_size
    TYPE(C_PTR) :: baseptr

    ier = 0
    array_shape(1) = n1
    disp_unit = 8_MPI_ADDRESS_KIND
    window_size = 0_MPI_ADDRESS_KIND
    IF (subid == mymaster) window_size = INT(n1,MPI_ADDRESS_KIND)
    CALL MPI_BARRIER(share_comm, ier)
    CALL MPI_WIN_ALLOCATE_SHARED(window_size, disp_unit, MPI_INFO_NULL, share_comm, baseptr, win ,ier)
    IF (subid /= mymaster) CALL MPI_WIN_SHARED_QUERY(win, 0, window_size, disp_unit, baseptr, ier)
    CALL C_F_POINTER(baseptr, array, array_shape)
    CALL MPI_WIN_FENCE(0, win, ier)

    RETURN

END SUBROUTINE mpialloc_1d_dbl