Question

这个问题类似于this one，其复杂性是收集的矩阵的大小在行长度上不相等，但它们在列长度上是相等的。（我也看过this question和this one，但无法弄清楚。）

背景

我正在执行一个计算，在计算结束之前，我不知道结果矩阵的行数。系列地，我分配了一个非常大的矩阵，它被填满并在计算结束时（当我知道行的极限时）我切断了这个大数组的末尾，我留下了我想要的结果。使用MPI，我应用相同的逻辑：

在每个进程中，我有一个填满的大型数组
最后计算我需要在各自的限制下切断每个阵列（每个过程的限制是不同的）
然后我需要将每个进程的结果数组收集到一个然后提供给根进程的数组中，以便继续执行该程序的其余部分。

到目前为止尝试

在尝试理解MPI_GATHERV如何工作以及如何在我的情况下使用它时，我编辑了this question答案中给出的代码，以便接受来自每个进程的可变大小的数组。

program main
use mpi
implicit none
integer :: ierr, myRank, nProcs
integer :: sendsubarray, recvsubarray, resizedrecvsubarray
integer, dimension(2) :: starts,sizes,subsizes
integer, dimension(:), allocatable :: counts, disps
integer, parameter :: nx_glb=20, ny_glb=5, ny=5
integer :: nx
integer, dimension(:), allocatable :: nx_all  
character, dimension(:,:), target, allocatable :: mat, matG
character :: c
integer :: i, j
integer(kind=mpi_address_kind) :: start, extent

call mpi_init(ierr)
call mpi_comm_rank(mpi_comm_world, myRank, ierr)
call mpi_comm_size(mpi_comm_world, nProcs, ierr)
allocate(nx_all(nProcs))
nx_all = (/5, 4, 5, 5/)
nx = nx_all(myRank+1)  
sizes(1)=nx; sizes(2)=ny
subsizes(1)=nx; subsizes(2)=ny
starts(1)=0; starts(2)=0
call mpi_type_create_subarray(2, sizes, subsizes, starts,    mpi_order_fortran, &
                            mpi_character, sendsubarray, ierr)
call mpi_type_commit(sendsubarray,ierr)
allocate(mat(1:nx,1:ny))
mat='.'
forall (i=1:nx,j=1:ny) mat(i,j)=ACHAR(ICHAR('0')+myRank)

if(myRank.eq.0) then
 allocate(matG(nx_glb,ny_glb))
 matG='.'
 sizes(1)=nx_glb; sizes(2)=ny_glb
 subsizes(1)=nx; subsizes(2)=ny
 starts(1)=0; starts(2)=0
 call mpi_type_create_subarray(2, sizes, subsizes, starts, mpi_order_fortran, &
                               mpi_character, recvsubarray, ierr)
 call mpi_type_commit(recvsubarray, ierr)
 extent = sizeof(c)
 start = 0
 call mpi_type_create_resized(recvsubarray, start, extent, resizedrecvsubarray, ierr)
 call mpi_type_commit(resizedrecvsubarray,ierr)
end if

allocate(counts(4),disps(4))
counts(1:4) = (/1, 1, 1, 1/)
disps(1:4) = (/0, 5, 10, 15/)
call mpi_barrier(mpi_comm_world,ierr)
print *, mat, "process", myRank    
call mpi_gatherv(mat,1,sendsubarray,matG,counts,disps,resizedrecvsubarray, &
                 0,mpi_comm_world,ierr)
do p=0,nProcs
  if (myRank == p) then
     print *, 'Local array for rank ', myRank
     do i=1, nx
      print *, (mat(i,j),j=1,ny)
     end do
  endif
enddo
call MPI_Barrier(MPI_COMM_WORLD,ierr)
if(myRank.eq.0) then
 print * , matG, "process", myRank    
 print *, 'Global array: '
 do i=1, nx_glb
  print *, (matG(i,j),j=1, ny_glb)
 end do
end if

call mpi_finalize(ierr)

end program main

理想的结果（注意等级1如何减少一行）：

Local array for rank 0
00000
00000
00000
00000
00000
Local array for rank 1
11111
11111
11111
11111
Local array for rank 2
22222
22222
22222
22222
22222
Local array for rank 3
33333
33333
33333
33333
33333

Global array: 
00000
00000
00000
00000
00000
11111
11111
11111
11111
22222
22222
22222
22222
22222
33333
33333
33333
33333
33333

实际结果（请注意我在本地的预期行为方式，但在全局矩阵中，额外的1s行在那里，最后有点）：

Local array for rank 0
00000
00000
00000
00000
00000
Local array for rank 1
11111
11111
11111
11111
Local array for rank 2
22222
22222
22222
22222
22222
Local array for rank 3
33333
33333
33333
33333
33333

Global array: 
00000
00000
00000
00000
00000
1111.
1111.
1111.
1111.
1111.
22222
22222
22222
22222
22222
33333
33333
33333
33333
33333

据我所知，在内存中，矩阵被保存为数组，因此我得到的全局数组如下所示：

0000011111222223333300000111112222233333000001111122222333330000011111222223333300000.....2222233333

问题（S）

如何删除点（代表排名1的空行）？如何将其显示为具有正确行数的矩阵？

修改全局数组中出现额外行的原因是因为根进程中创建的recvsubarray的维度为5x5，尽管来自进程1的transmitubarray的维度为4x5。现在的问题是，如何根据接收信息的等级来定义具有可变维度的recvsubarray？

Answer 1

通过将全局矩阵定义为在第一维（nx）而不是第二维（ny）中更大，你已经使你的生活变得非常艰难。 Fortran存储数组的方式，具有更大的ny更自然，因为它对应于将所有子矩阵按顺序存储在内存中。

如果您愿意交换nx和ny，那么您不需要使用任何复杂的派生类型。事实上，我怀疑你可以使用Scatterv做这个模式，因为该函数需要单个接收类型，但每个输入矩阵都有不同的模式（由于你选择了nx和ny的排序）。

此代码与交换的nx和ny似乎正常工作。虚线在最后 - 我猜你总是会有一些点，因为你分配的空间比子矩阵占用的空间要多。

program main
use mpi
implicit none
integer :: ierr, myRank, nProcs
integer :: sendsubarray, recvsubarray, resizedrecvsubarray
integer, dimension(2) :: starts,sizes,subsizes
integer, dimension(:), allocatable :: counts, disps
integer, parameter :: ny_glb=20, nx_glb=5, nx=5
integer :: ny
integer, dimension(:), allocatable :: ny_all
character, dimension(:,:), target, allocatable :: mat, matG
character :: c
integer :: i, j, p
integer(kind=mpi_address_kind) :: start, extent

call mpi_init(ierr)
call mpi_comm_rank(mpi_comm_world, myRank, ierr)
call mpi_comm_size(mpi_comm_world, nProcs, ierr)
allocate(ny_all(nProcs))
ny_all = (/5, 4, 5, 5/)
ny = ny_all(myRank+1)
allocate(mat(1:nx,1:ny))
mat='.'
forall (i=1:nx,j=1:ny) mat(i,j)=ACHAR(ICHAR('0')+myRank)

if(myRank.eq.0) then
 allocate(matG(nx_glb,ny_glb))
 matG='.'
end if

allocate(counts(4),disps(4))
counts(:) = nx*ny_all(:)

disps(1)=0
do i = 2, 4
  disps(i) = disps(i-1)+counts(i-1)
end do

call mpi_barrier(mpi_comm_world,ierr)
print *, mat, "process", myRank
call mpi_gatherv(mat,nx*ny,MPI_CHARACTER,matG,counts,disps,MPI_CHARACTER, &
                 0,mpi_comm_world,ierr)
do p=0,nProcs
  if (myRank == p) then
     print *, 'Local array for rank ', myRank
     do i=1, nx
      print *, (mat(i,j),j=1,ny)
     end do
  endif
enddo
call MPI_Barrier(MPI_COMM_WORLD,ierr)
if(myRank.eq.0) then
 print * , matG, "process", myRank
 print *, 'Global array: '
 do i=1, nx_glb
  print *, (matG(i,j),j=1, ny_glb)
 end do
end if

call mpi_finalize(ierr)

end program main

以下是一些输出：

 Global array: 
 0000011112222233333.
 0000011112222233333.
 0000011112222233333.
 0000011112222233333.
 0000011112222233333.

00000000000000000000000001111111111111111111122222222222222222222222223333333333333333333333333 .....

希望这很有用。

Answer 2

这就是我解决上述问题的方法（答案是由同事给我的，所以归功于他）：

由于最终矩阵的一个维度是固定的，并且由于矩阵无论如何都存储在数组中，因此mpi_gather与mpi_type_vector而不是mpi_type_create_subarray一起使用会更好。因此，程序结构如下：a）确定每个等级中子矩阵的感兴趣的大小，b）将其转换为向量，c）从每个等级收集向量并且d）将向量重新整形为最终矩阵。这样，就不需要收集不需要的信息（由上面问题中的点表示），因此在使用mpi_gather之后无需删除它们。

因此，为了将不同长度但不变宽度的子阵列收集到全局矩阵中，以下代码可以解决这个问题：

program main
  use mpi
  implicit none
  integer :: ierr, myRank, iProcs, nProcs, master
  integer :: ix, iy, ip
  integer :: nx, nxSum, offset, newtype
  integer, parameter :: ny=5
  integer, allocatable:: vec(:), vecG(:), nxAll(:), displs(:), rcounts(:), matG(:,:)

  call mpi_init(ierr)
  call mpi_comm_rank(mpi_comm_world, myRank, ierr)
  call mpi_comm_size(mpi_comm_world, nProcs, ierr)

  master = 0

  nx = myRank+1
  allocate(vec(nx*ny))
  do ix = 1,nx
     do iy = 1,ny
        ip = (ix-1)*ny + iy
        vec(ip) = myRank
     enddo
  enddo

  call mpi_barrier(mpi_comm_world,ierr)

  allocate(nxAll(nProcs))
  call mpi_gather(nx, 1, mpi_integer, nxAll, 1, mpi_integer, &
       master, mpi_comm_world, ierr)

  if (myRank == master) then
     ! print *, 'nxAll = ', nxAll, 'sum(nxAll) = ',sum(nxAll)
     nxSum = sum(nxAll)        
     allocate(vecG(nxSum*ny))

     allocate(displs(nProcs),rcounts(nProcs))
     offset = 0
     do iProcs = 1,nProcs
        displs(iProcs) = offset
        rcounts(iProcs) = nxAll(iProcs)*ny
        offset = offset + rcounts(iProcs)
        ! print *,'iProcs',iProcs,'displs = ',displs(iProcs),'rcounts',rcounts(iProcs)
     enddo

  endif

  call mpi_type_vector(nx*ny, 1, 1, mpi_integer,newtype,ierr)
  call mpi_type_commit(newtype,ierr)

  call mpi_gatherv(vec,1,newtype,vecG,rcounts,displs,mpi_integer, &
       master,mpi_comm_world,ierr)    


  if (myRank == master) then
     print *, 'Global vector, vecG = ',vecG

     ! Reshape into matrix
     print *, 'Global matrix'
     allocate(matG(nxSum,ny))
     do ix = 1,nxSum
        do iy = 1,ny
           ip = (ix-1)*ny + iy
           matG(ix,iy) = vecG(ip)
        enddo
        print *, (matG(ix,iy),iy=1,ny)
     enddo

  endif

  call mpi_finalize(ierr)

end program main

收集不等大小的数组时在Fortran中使用MPI_GATHERV

2 个答案: