Fortran中使用MPI_Allgather同步多数组数据出错，求排查

问题描述 #

需要将多数组任务分配给不同进程计算，之后让所有进程同步数据，使用MPI_Allgather后结果不符合预期。示例代码如下：

program main
use mpi
implicit none

integer           :: nproc,rank,ierr,i
integer,parameter :: n = 3
integer,parameter :: m = 2
double precision  :: x(n,m),y(n,m),z(m)

! Initializing MPI
call mpi_init(ierr)
call mpi_comm_rank(mpi_comm_world, rank,  ierr)
call mpi_comm_size(mpi_comm_world, nproc, ierr)

! Initial values for x
x = 0.0
y = 1.0

! Do the following m times
do i = 1,m
    
    ! Distribute work in 2 processes
    if (rank == 0) then
        x(:,i) = x(:,i) + i
    end if

    if (rank == 1) then
        y(:,i) = y(:,i) * (i+1.0)
    end if

    ! MPI barrier
    call mpi_barrier(mpi_comm_world, ierr)

    ! Gathering (MPI), so all processes have the same data
    call mpi_allgather(mpi_in_place, n, mpi_double_precision, x(:,i), n, mpi_double_precision, mpi_comm_world, ierr)
    call mpi_allgather(mpi_in_place, n, mpi_double_precision, y(:,i), n, mpi_double_precision, mpi_comm_world, ierr)
    
    ! MPI barrier
    call mpi_barrier(mpi_comm_world, ierr)
    
    ! Using data from both processes
    z(i) = sum(x(:,i)) + sum(y(:,i))

    if (rank == 0)  then
        print *, i, z(i)
    end if

end do

! Finalizing MPI
call mpi_finalize(ierr)

end program main

预期进程0输出：

1   9.00000000000000
       2   15.0000000000000

实际结果错误，需排查问题原因。

错误原因分析 #

• MPI_Allgather功能与使用场景不匹配
  MPI_Allgather的作用是将每个进程发送缓冲区的数据，收集到所有进程的接收缓冲区中，接收缓冲区总容量需要等于进程数 × 发送数据量。但你的需求是让所有进程获取单个进程计算的完整数据（x(:,i)由进程0计算，y(:,i)由进程1计算），这种场景下MPI_Bcast（广播）才是正确选择，MPI_Allgather会将多个进程的不同数据拼接，导致数据混乱。

• MPI_IN_PLACE使用错误
  MPI_IN_PLACE仅适用于发送缓冲区与接收缓冲区重叠，且所有进程都有需要汇总的有效数据的场景。但这里进程1的x(:,i)是初始值0，进程0的y(:,i)是初始值1，用MPI_IN_PLACE会导致有效数据被无效的初始值覆盖。

• 接收缓冲区容量不足
  调用MPI_Allgather时，接收缓冲区x(:,i)仅能容纳n个元素，但实际需要接收nproc × n个元素（每个进程发送n个double），这会导致缓冲区溢出或数据覆盖，破坏原有有效数据。

修正方案 #

将MPI_Allgather替换为MPI_Bcast，针对每个数组的计算进程进行广播：

program main
use mpi
implicit none

integer           :: nproc,rank,ierr,i
integer,parameter :: n = 3
integer,parameter :: m = 2
double precision  :: x(n,m),y(n,m),z(m)

! Initializing MPI
call mpi_init(ierr)
call mpi_comm_rank(mpi_comm_world, rank,  ierr)
call mpi_comm_size(mpi_comm_world, nproc, ierr)

! Initial values for x
x = 0.0
y = 1.0

! Do the following m times
do i = 1,m
    
    ! Distribute work in 2 processes
    if (rank == 0) then
        x(:,i) = x(:,i) + i
    end if

    if (rank == 1) then
        y(:,i) = y(:,i) * (i+1.0)
    end if

    ! MPI barrier
    call mpi_barrier(mpi_comm_world, ierr)

    ! 广播进程0计算的x(:,i)到所有进程
    call mpi_bcast(x(:,i), n, mpi_double_precision, 0, mpi_comm_world, ierr)
    ! 广播进程1计算的y(:,i)到所有进程
    call mpi_bcast(y(:,i), n, mpi_double_precision, 1, mpi_comm_world, ierr)
    
    ! MPI barrier（可选，因为MPI_Bcast本身是同步操作）
    call mpi_barrier(mpi_comm_world, ierr)
    
    ! Using data from both processes
    z(i) = sum(x(:,i)) + sum(y(:,i))

    if (rank == 0)  then
        print *, i, z(i)
    end if

end do

! Finalizing MPI
call mpi_finalize(ierr)

end program main

说明 #

• MPI_Bcast会将指定根进程的数据发送到通信域内的所有进程，完美匹配你“单个进程计算，所有进程同步数据”的需求。
• 原代码中的MPI_Barrier在MPI_Bcast后可省略，因为MPI_Bcast本身是阻塞式同步操作，所有进程会在广播完成后才继续执行。

内容的提问来源于stack exchange，提问作者Looper