使用MPI_Gather在Fortran中发送2D数组

时间:2013-07-07 02:03:31

标签: fortran mpi

我想使用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

1 个答案:

答案 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