MPI_Gather子矩阵聚合问题：多处理器运行时程序挂起

你的代码在多进程环境下挂起的核心原因是MPI集体操作要求通信域内所有进程同步调用，而代码中多处仅让根进程（rank=0）执行MPI_Gather，其他进程未参与这些操作，导致进程间无法同步，最终引发挂起。

具体问题点 #

1. 主程序iDebug分支的MPI_Gather调用错误 #

你将MPI_Gather放在if (my_rank == 0)块内，只有根进程执行该调用，其他进程未参与。而MPI_Gather是集体通信接口，必须所有进程同时调用，否则会一直等待未执行的进程，导致挂起。

2. print_whole_matr子程序的调用条件错误 #

主程序中调用该子程序的条件是if ((iN <= 30) .and. (my_rank == 0))，仅根进程进入子程序，其他进程无此操作。但子程序内部的MPI_Gather是集体操作，缺少其他进程参与时，根进程会一直等待，引发挂起。

修复后的完整代码 #

主程序修复版本 #

program matrix_manip

IMPLICIT NONE

include 'mpif.h'

integer   my_rank,num_proc  !! local rank of processor, total number of processors
integer   iM,iN,local_n     !! rows x columns, default 3x8 ... then n --> local_n = n/p
integer   status(MPI_STATUS_SIZE)
integer   ierr,iDebug
integer   local_i,local_j,j_my_rank,j,i     !! dumb loop indices

double precision  startTime, endTime, tsec
double precision, allocatable:: local_x(:),local_matr(:,:), print_matr(:,:)

call docommandline(iM,iN)

call MPI_INIT(ierr)

call MPI_Barrier(MPI_COMM_WORLD,ierr)
startTime = MPI_Wtime(ierr)

call MPI_COMM_RANK(MPI_COMM_WORLD, my_rank,  ierr)
call MPI_COMM_SIZE(MPI_COMM_WORLD, num_proc, ierr)

local_n = iN/num_proc
if (abs(local_n*num_proc - iN) .NE. 0) then
  print *,'LARGE MATRIX : iM = ',iM,' iN = ',iN,' num_proc = ',num_proc
  print *,'cannot do integer iN/num_proc, quitting'
  call MPI_FINALIZE(ierr)
  stop
else
  write(*,'(5(A,I4))') ' LARGE MATRIX : ',iM,' x ',iN,' num_proc = ',num_proc,' local_n = ',local_n,' myrank = ',my_rank
end if

!! do this on every processor
allocate(local_x(iN))
allocate(local_matr(iM,local_n))
do local_j = 1,local_n
  do local_i = 1,iM
    j_my_rank = local_n * my_rank + local_j
    local_matr(local_i,local_j) = 10*local_i + j_my_rank
!    print *,my_rank,local_matr(local_i,local_j)
  end do
end do
print *,'here after init local_matr',my_rank

!! do this on all processors, only root handles allocation/printing
iDebug = +1
if (iDebug > 0) then
  call MPI_Barrier(MPI_COMM_WORLD,ierr)
  if (my_rank == 0) then
    allocate(print_matr(iM,iN))
    print *,'in main routine, called MPI_Barrier, allocated space for print_matr ... now gonna do GATHER'
  end if
  ! 所有进程同步调用MPI_Gather
  call MPI_GATHER(local_matr,iM*local_n,MPI_DOUBLE_PRECISION, &  !! everyone sends iM*local_n to root
                  print_matr,iM*local_n,MPI_DOUBLE_PRECISION, &  !! root gets iM*local_n from everyone *orders it correctly*
                  0,MPI_COMM_WORLD,ierr)
  if (my_rank == 0) then
    do j=1,iN
      write(*,'(A,I3,A,I3)') 'column ',j,' of ',iN
      do i=1,iM
        write(*,'(F24.16)') print_matr(i,j)
      end do
    end do
    deallocate(print_matr)
    print *,'finished printing matrix at main'
  end if
end if

!! 所有进程都调用print_whole_matr，仅根进程处理打印逻辑
if (iN <= 30) then
  call print_whole_matr(iM,iN,local_n,local_matr,num_proc,my_rank)
end if

call MPI_Barrier(MPI_COMM_WORLD,ierr)
endTime = MPI_Wtime(ierr);
if (my_rank .EQ. 0) THEN
  tsec = endTime - startTime
  write(*,'(A,I4,A,F10.6)') 'numprocessor = ',num_proc, '     wall clock time (s) ',tsec
end if

deallocate(local_x)
deallocate(local_matr)
call MPI_FINALIZE(ierr)
end

子程序修复版本 #

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine print_whole_matr(iM,iN,local_n,local_matr,num_proc,my_rank)

IMPLICIT NONE

include 'mpif.h'

! input variables
integer iM,iN,local_n
integer num_proc,my_rank
double precision :: local_matr(iM,local_n)

! local variables
double precision, allocatable :: print_matr(:,:)
integer i,j,ierr

if (my_rank == 0) then
  allocate(print_matr(iM,iN))
end if

call MPI_Barrier(MPI_COMM_WORLD,ierr)
! 所有进程同步调用MPI_Gather
call MPI_GATHER(local_matr,iM*local_n,MPI_DOUBLE_PRECISION, &  !! everyone sends iM*local_n to root
                print_matr,iM*local_n,MPI_DOUBLE_PRECISION, &  !! root gets iM*local_n from everyone *orders it correctly*
                0,MPI_COMM_WORLD,ierr)

if (my_rank == 0) then
  do i = 1,iM
    do j = 1,iN
      if (j .lt. iN) then
        write(*,'(F12.6,1X)',advance='no') print_matr(i,j)
      else
        write(*,'(F12.6,1X)') print_matr(i,j)
      end if
    end do
  end do
end if

if (my_rank == 0) then
  deallocate(print_matr)
end if

return
end

关键注意事项 #

• MPI集体通信规则：MPI_Gather、MPI_Barrier这类集体操作，必须保证通信域内所有进程都调用，否则会触发进程挂起等待。
• 数据聚合逻辑：你的按列拆分矩阵的逻辑是正确的，MPI_Gather会按进程rank顺序自动将子矩阵拼接为完整矩阵，符合预期。

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