我想使用MPI_GATHER发送2d数据块。例如：我在每个节点上有2x3阵列，如果我有4个节点，我想在root上使用8x3阵列。对于1d数组，MPI_GATHER根据MPI排名对数据进行排序，但对于2d数据，它会造成混乱！
按顺序放置块的干净方法是什么？
我期待这段代码的输出：
program testmpi
use mpi
implicit none
integer :: send (2,3)
integer :: rec (4,3)
integer :: ierror,my_rank,i,j
call MPI_Init(ierror)
MPI_DATA_TYPE type_col
! find out process rank
call MPI_Comm_rank(MPI_COMM_WORLD, my_rank, ierror)
if (my_rank==0) then
send=1
do i=1,2
print*,(send(i,j),j=1,3)
enddo
endif
if (my_rank==1) then
send=5
! do 1,2
! print*,(send(i,j),j=1,3)
! enddo
endif
call MPI_GATHER(send,6,MPI_INTEGER,rec,6,MPI_INTEGER,0,MPI_COMM_WORLD,ierror)
if (my_rank==0) then
print*,'<><><><><>rec'
do i=1,4
print*,(rec(i,j),j=1,3)
enddo
endif
call MPI_Finalize(ierror)
end program testmpi
是这样的：
1 1 1
1 1 1
5 5 5
5 5 5
但它看起来像这样：
1 1 5
1 1 5
1 5 5
1 5 5
答案 0 :(得分：26)
以下是this answer的字面Fortran翻译。我原以为这是不必要的，但数组索引和内存布局的多重差异可能意味着值得做一个Fortran版本。
首先让我说你通常不想这样做 - 分散并收集一些＆＃34; master＆＃34;的大量数据。处理。通常情况下，您希望每个任务都能在其自己的拼图中挣扎，并且您的目标是永远不要让一个处理器需要一个全局视图＆＃34;整个数据;只要您需要，就可以限制可扩展性和问题大小。如果您正在为I / O执行此操作 - 一个进程读取数据，然后将其分散，然后将其收集回来进行编写，您最终希望查看MPI-IO。
提出问题，但是，MPI有很好的方法可以将任意数据从内存中拉出来，并将其分散/收集到一组处理器中。不幸的是，这需要相当数量的MPI概念--MPI类型，范围和集体操作。在这个问题的答案中讨论了许多基本思想 - MPI_Type_create_subarray and MPI_Gather。
考虑一个1d整数全局数组，任务0具有你要分发给许多MPI任务的数组，这样它们每个都可以在本地数组中获得一个部分。假设你有4个任务，全局数组是[0,1,2,3,4,5,6,7]。您可以让任务0发送四条消息（包括一条消息）以分发它，当它需要重新组装时，接收四条消息将它们捆绑在一起;但这显然在大量流程中非常耗时。有针对这些操作的优化例程 - 分散/收集操作。所以在这个1d案例中，你可以这样做：
integer, dimension(8) :: global ! only root has this
integer, dimension(2) :: local ! everyone has this
integer, parameter :: root = 0
integer :: rank, comsize
integer :: i, ierr
call MPI_Init(ierr)
call MPI_Comm_size(MPI_COMM_WORLD, comsize, ierr)
call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr)
if (rank == root) then
global = [ (i, i=1,8) ]
endif
call MPI_Scatter(global, 2, MPI_INTEGER, & ! send everyone 2 ints from global
local, 2, MPI_INTEGER, & ! each proc recieves 2 into
root, & ! sending process is root,
MPI_COMM_WORLD, ierr) ! all procs in COMM_WORLD participate
在此之后，处理器＆＃39;数据看起来像
task 0: local:[1,2] global: [1,2,3,4,5,6,7,8]
task 1: local:[3,4] global: [garbage]
task 2: local:[5,6] global: [garbage]
task 3: local:[7,8] global: [garbage]
也就是说，分散操作采用全局数组并将连续的2-int块发送给所有处理器。
要重新组装数组，我们使用MPI_Gather（）操作，它的工作方式完全相同但反之亦然：
local = local + rank
call MPI_Gather (local, 2, MPI_INTEGER, & ! everyone sends 2 ints from local
global, 2, MPI_INTEGER, & ! root receives 2 ints each proc into global
root, & ! receiving process is root,
MPI_COMM_WORLD, ierr) ! all procs in COMM_WORLD participate
现在阵列看起来像：
task 0: local:[1,2] global: [1,2,4,5,7,8,10,11]
task 1: local:[4,5] global: [garbage-]
task 2: local:[7,8] global: [garbage-]
task 3: local:[10,11] global: [garbage-]
Gather带回所有数据。
如果数据点的数量不能平均分配进程数，会发生什么情况，我们需要向每个进程发送不同数量的项？然后，您需要一个广义的scatter版本MPI_Scatterv，它允许您指定每个处理器的计数，以及位移 - 在该数据片段的全局数组中的位置。所以，让我们用相同的4个任务来说，你有一个包含9个字符的字符数组[a，b，c，d，e，f，g，h，i]，你将分配每个进程2除了最后一个字符，有三个字符。然后你需要
character, dimension(9) :: global
character, dimension(3) :: local
integer, dimension(4) :: counts
integer, dimension(4) :: displs
if (rank == root) then
global = [ (achar(i+ichar('a')), i=0,8) ]
endif
local = ['-','-','-']
counts = [2,2,2,3]
displs = [0,2,4,6]
mycounts = counts(rank+1)
call MPI_Scatterv(global, counts, displs, & ! proc i gets counts(i) chars from displs(i)
MPI_CHARACTER, &
local, mycounts, MPI_CHARACTER, & ! I get mycounts chars into
root, & ! root rank does sending
MPI_COMM_WORLD, ierr) ! all procs in COMM_WORLD participate
现在数据看起来像
task 0: local:"ab-" global: "abcdefghi"
task 1: local:"cd-" global: *garbage*
task 2: local:"ef-" global: *garbage*
task 3: local:"ghi" global: *garbage*
您现在使用scatterv来分发不规则数据量。在每种情况下的位移是两个*等级（以字符测量;位移是以散布的形式发送的类型或者为聚集接收的类型的单位;它通常不是以字节或其他形式）从开始时的数组，计数是[2,2,2,3]。如果它是我们想要的3个字符的第一个处理器，我们将设置计数= [3,2,2,2]并且位移将是[0,3,5,7]。 Gatherv再次完全相同但反过来; count和displs数组将保持不变。
现在，对于2D，这有点棘手。如果我们想要发送2d阵列的2d子锁，我们现在发送的数据不再是连续的。如果我们向4个处理器发送（比方说）6x6阵列的3x3子块，我们发送的数据就会出现漏洞：
2D Array
---------
|000|222|
|000|222|
|000|222|
|---+---|
|111|333|
|111|333|
|111|333|
---------
Actual layout in memory
[000111000111000111222333222333222333]
（请注意，所有高性能计算都归结为了解内存中数据的布局。）
如果我们要发送标记为＆＃34; 1＆＃34;的数据到任务1，我们需要跳过三个值，发送三个值，跳过三个值，发送三个值，跳过三个值，发送三个值。第二个复杂因素是次区域停止和开始;请注意该地区＆＃34; 1＆＃34;不会从哪个区域开始＃0; 0＆＃34;停止;在区域＆＃34; 0＆＃34;的最后一个元素之后，内存中的下一个位置是中途通过区域＆＃34; 1＆＃34;。
让我们首先解决第一个布局问题 - 如何只提取我们想要发送的数据。我们总是可以复制所有的＆＃34; 0＆＃34;区域数据到另一个，连续的数组，并发送;如果我们仔细计划出来，我们甚至可以这样做，以便我们可以在结果上调用MPI_Scatter。但我们不必以这种方式转换整个主数据结构。
到目前为止，我们使用的所有MPI数据类型都是简单的 - MPI_INTEGER指定（比方说）连续4个字节。但是，MPI允许您创建自己的数据类型，以描述内存中任意复杂的数据布局。这种情况 - 数组的矩形子区域 - 足够常见there's a specific call for that。对于我们上面描述的二维情况，
integer :: newtype;
integer, dimension(2) :: sizes, subsizes, starts
sizes = [6,6] ! size of global array
subsizes = [3,3] ! size of sub-region
starts = [0,0] ! let's say we're looking at region "0"
! which begins at offset [0,0]
call MPI_Type_create_subarray(2, sizes, subsizes, starts, MPI_ORDER_FORTRAN, MPI_INTEGER, newtype, ierr)
call MPI_Type_commit(newtype, ierr)
这会创建一个只挑选区域的类型＆＃34; 0＆＃34;来自全局数组。请注意，即使在Fortran中，start参数也是从数组的开头给出的 offset （例如，从0开始），而不是索引（例如，从1开始）。
我们现在可以将这段数据发送到另一个处理器
call MPI_Send(global, 1, newtype, dest, tag, MPI_COMM_WORLD, ierr) ! send region "0"
并且接收进程可以将其接收到本地阵列中。请注意，如果接收过程仅将其接收到3x3阵列中，则无法描述它作为一种新类型接收的内容;不再描述内存布局，因为在一行的结尾和下一行的开头之间没有大的跳跃。相反，它只是接收一个3 * 3 = 9个整数的块：
call MPI_Recv(local, 3*3, MPI_INTEGER, 0, tag, MPI_COMM_WORLD, ierr)
请注意，我们也可以为其他子区域执行此操作，方法是为其他块创建不同的类型（具有不同的启动数组），或者仅从特定块的第一个位置开始发送：
if (rank == root) then
call MPI_Send(global(4,1), 1, newtype, 1, tag, MPI_COMM_WORLD, ierr)
call MPI_Send(global(1,4), 1, newtype, 2, tag, MPI_COMM_WORLD, ierr)
call MPI_Send(global(4,4), 1, newtype, 3, tag, MPI_COMM_WORLD, ierr)
local = global(1:3, 1:3)
else
call MPI_Recv(local, 3*3, MPI_INTEGER, 0, tag, MPI_COMM_WORLD, rstatus, ierr)
endif
既然我们已经了解了如何指定子区域，那么在使用分散/聚集操作之前，还有一件事需要讨论，那就是＆＃34; size＆＃34;这些类型。我们不能只使用这些类型的MPI_Scatter（）（甚至是scatterv），因为这些类型的范围是15个整数;也就是说，它们结束后它们的结尾是15个整数 - 它们结束的地方与下一个块开始的位置没有很好的排列，所以我们不能只使用分散 - 它会选择错误的地方开始向下一个处理器发送数据。
当然，我们可以使用MPI_Scatterv（）并自己指定位移，这就是我们要做的事情 - 除了位移以发送类型大小为单位，并且没有＆＃39 ; t帮助我们;这些块从全局数组开始处的（0,3,18,21）个整数的偏移开始，并且一个块从它开始的位置结束15个整数这一事实并不能让我们用整数倍表示这些位移。一点都不。
为了解决这个问题，MPI允许您为这些计算设置类型的范围。它不会截断类型;它只是用于确定下一个元素在最后一个元素的位置开始的位置。对于类似这些类型的类型，它们通常很方便将范围设置为小于内存中距离类型实际末端的距离。
我们可以将范围设定为对我们来说方便的任何事物。我们可以将范围设为1整数，然后以整数为单位设置位移。但是，在这种情况下，我喜欢将范围设置为3个整数 - 子列的大小 - 这样，阻止＆＃34; 1＆＃34;在块＆＃34; 0＆＃34;之后立即开始，并阻止＆＃34; 3＆＃34;在块＆＃34; 2＆＃34;之后立即开始。不幸的是，当从街区跳下来时它并没有那么好的工作＃2;＆＃34;阻止＆＃34; 3＆＃34;，但这无济于事。
因此，为了在这种情况下分散子块，我们执行以下操作：
integer(kind=MPI_ADDRESS_KIND) :: extent
starts = [0,0]
sizes = [6, 6]
subsizes = [3, 3]
call MPI_Type_create_subarray(2, sizes, subsizes, starts, &
MPI_ORDER_FORTRAN, MPI_INTEGER, &
newtype, ierr)
call MPI_Type_size(MPI_INTEGER, intsize, ierr)
extent = 3*intsize
call MPI_Type_create_resized(newtype, 0, extent, resizedtype, ierr)
call MPI_Type_commit(resizedtype, ierr)
我们在这里创建了与以前相同的块类型，但我们已经调整了它的大小;我们没有改变类型＆＃34;开始＆＃34; （0）但我们已经改变了＃34;结束的时间＃34; （3个整数）。我们之前没有提到这一点，但MPI_Type_commit需要能够使用该类型;但是你只需要提交实际使用的最终类型，而不是任何中间步骤。您完成后使用MPI_Type_free释放已提交的类型。
所以现在，最后，我们可以分散块：上面的数据操作有点复杂，但一旦完成，scatterv就像以前一样：
counts = 1 ! we will send one of these new types to everyone
displs = [0,1,6,7] ! the starting point of everyone's data
! in the global array, in block extents
call MPI_Scatterv(global, counts, displs, & ! proc i gets counts(i) types from displs(i)
resizedtype, &
local, 3*3, MPI_INTEGER, & ! I'm receiving 3*3 int
root, MPI_COMM_WORLD, ierr) !... from (root, MPI_COMM_WORLD)
现在我们已经完成了一些分散，聚集和MPI衍生类型之后。
下面是一个示例代码，其中显示了带有字符数组的聚集和分散操作。运行程序：
$ mpirun -np 4 ./scatter2d
global array is:
000222
000222
000222
111333
111333
111333
Rank 0 received:
000
000
000
Rank 1 received:
111
111
111
Rank 2 received:
222
222
222
Rank 3 received:
333
333
333
Rank 0 sending:
111
111
111
Rank 1 sending:
222
222
222
Rank 2 sending:
333
333
333
Rank 3 sending:
444
444
444
Root received:
111333
111333
111333
222444
222444
222444
，代码如下：
program scatter
use mpi
implicit none
integer, parameter :: gridsize = 6 ! size of array
integer, parameter :: procgridsize = 2 ! size of process grid
character, allocatable, dimension (:,:) :: global, local
integer, dimension(procgridsize**2) :: counts, displs
integer, parameter :: root = 0
integer :: rank, comsize
integer :: localsize
integer :: i, j, row, col, ierr, p, charsize
integer, dimension(2) :: sizes, subsizes, starts
integer :: newtype, resizedtype
integer, parameter :: tag = 1
integer, dimension(MPI_STATUS_SIZE) :: rstatus
integer(kind=MPI_ADDRESS_KIND) :: extent, begin
call MPI_Init(ierr)
call MPI_Comm_size(MPI_COMM_WORLD, comsize, ierr)
call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr)
if (comsize /= procgridsize**2) then
if (rank == root) then
print *, 'Only works with np = ', procgridsize**2, ' for now.'
endif
call MPI_Finalize(ierr)
stop
endif
localsize = gridsize/procgridsize
allocate( local(localsize, localsize) )
if (rank == root) then
allocate( global(gridsize, gridsize) )
forall( col=1:procgridsize, row=1:procgridsize )
global((row-1)*localsize+1:row*localsize, &
(col-1)*localsize+1:col*localsize) = &
achar(ichar('0')+(row-1)+(col-1)*procgridsize)
end forall
print *, 'global array is: '
do i=1,gridsize
print *, global(i,:)
enddo
endif
starts = [0,0]
sizes = [gridsize, gridsize]
subsizes = [localsize, localsize]
call MPI_Type_create_subarray(2, sizes, subsizes, starts, &
MPI_ORDER_FORTRAN, MPI_CHARACTER, &
newtype, ierr)
call MPI_Type_size(MPI_CHARACTER, charsize, ierr)
extent = localsize*charsize
begin = 0
call MPI_Type_create_resized(newtype, begin, extent, resizedtype, ierr)
call MPI_Type_commit(resizedtype, ierr)
counts = 1 ! we will send one of these new types to everyone
forall( col=1:procgridsize, row=1:procgridsize )
displs(1+(row-1)+procgridsize*(col-1)) = (row-1) + localsize*procgridsize*(col-1)
endforall
call MPI_Scatterv(global, counts, displs, & ! proc i gets counts(i) types from displs(i)
resizedtype, &
local, localsize**2, MPI_CHARACTER, & ! I'm receiving localsize**2 chars
root, MPI_COMM_WORLD, ierr) !... from (root, MPI_COMM_WORLD)
do p=1, comsize
if (rank == p-1) then
print *, 'Rank ', rank, ' received: '
do i=1, localsize
print *, local(i,:)
enddo
endif
call MPI_Barrier(MPI_COMM_WORLD, ierr)
enddo
local = achar( ichar(local) + 1 )
do p=1, comsize
if (rank == p-1) then
print *, 'Rank ', rank, ' sending: '
do i=1, localsize
print *, local(i,:)
enddo
endif
call MPI_Barrier(MPI_COMM_WORLD, ierr)
enddo
call MPI_Gatherv( local, localsize**2, MPI_CHARACTER, & ! I'm sending localsize**2 chars
global, counts, displs, resizedtype,&
root, MPI_COMM_WORLD, ierr)
if (rank == root) then
print *, ' Root received: '
do i=1,gridsize
print *, global(i,:)
enddo
endif
call MPI_Type_free(newtype,ierr)
if (rank == root) deallocate(global)
deallocate(local)
call MPI_Finalize(ierr)
end program scatter
这是一般的解决方案。对于你的特殊情况，我们只是按行追加，我们不需要Gatherv，我们可以只使用一个聚集，因为在这种情况下，所有的位移是相同的 - 之前，在2d块如果我们有一个排量下降＆＃39;然后跳过那个位移，当你走过＆＃39;跨越＆＃39;到下一列的块。在这里，位移始终与前一个位移相同，因此我们不需要明确地给出位移。所以最终的代码如下：
program testmpi
use mpi
implicit none
integer, dimension(:,:), allocatable :: send, recv
integer, parameter :: nsendrows = 2, nsendcols = 3
integer, parameter :: root = 0
integer :: ierror, my_rank, comsize, i, j, ierr
integer :: blocktype, resizedtype
integer, dimension(2) :: starts, sizes, subsizes
integer (kind=MPI_Address_kind) :: start, extent
integer :: intsize
call MPI_Init(ierror)
call MPI_Comm_rank(MPI_COMM_WORLD, my_rank, ierror)
call MPI_Comm_size(MPI_COMM_WORLD, comsize, ierror)
allocate( send(nsendrows, nsendcols) )
send = my_rank
if (my_rank==root) then
! we're going to append the local arrays
! as groups of send rows
allocate( recv(nsendrows*comsize, nsendcols) )
endif
! describe what these subblocks look like inside the full concatenated array
sizes = [ nsendrows*comsize, nsendcols ]
subsizes = [ nsendrows, nsendcols ]
starts = [ 0, 0 ]
call MPI_Type_create_subarray( 2, sizes, subsizes, starts, &
MPI_ORDER_FORTRAN, MPI_INTEGER, &
blocktype, ierr)
start = 0
call MPI_Type_size(MPI_INTEGER, intsize, ierr)
extent = intsize * nsendrows
call MPI_Type_create_resized(blocktype, start, extent, resizedtype, ierr)
call MPI_Type_commit(resizedtype, ierr)
call MPI_Gather( send, nsendrows*nsendcols, MPI_INTEGER, & ! everyone send 3*2 ints
recv, 1, resizedtype, & ! root gets 1 resized type from everyone
root, MPI_COMM_WORLD, ierr)
if (my_rank==0) then
print*,'<><><><><>recv'
do i=1,nsendrows*comsize
print*,(recv(i,j),j=1,nsendcols)
enddo
endif
call MPI_Finalize(ierror)
end program testmpi
使用3个进程运行此命令：
$ mpirun -np 3 ./testmpi
<><><><><>recv
0 0 0
0 0 0
1 1 1
1 1 1
2 2 2
2 2 2