Parallel processing 用MPI求解泊松方程时代码卡住

我用MPI实现了一个简单的一维泊松方程并行求解器，以便熟悉MPI库。我将代码设计为使用未指定数量的处理器运行（包括仅使用1个）

当在1或2个处理器上运行时，代码运行并产生良好的结果。但是，它在使用4个处理器的

mpi\u send

和

mpi\u recv

调用中卡住了。因此，我期望我的鬼点交换的实现是错误的

由于代码太大，无法包含在这里，因此我只包含了Jacobi方案和数据交换：

do iter=1,max_iter                                                                                    
    !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~             
    ! Initial guess, on interior points only                                                          
    Ujacob(min_x+1:max_x-1) = 0._dp                                                                   
    Ujacob_all(0:grid_nx-1) = 0._dp                                                                   

    !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~             
    ! Store solution vector from last iteration                                                       
    Uold    (:) = Ujacob    (:)                                                                       
    Uold_all(:) = Ujacob_all(:)                                                                       

    !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~             
    ! Jacobi scheme                                                                                   
    do ii=min_x+1,max_x-1                                                                             
        !Ujacob(ii) = 0.5_dp * (Uold  (ii-1) + Uold  (ii+1) - grid_delta_x**2 * Urhs(ii))             
    end do                                                                                            

    !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~             
    ! Gather Ujacob vector                                                                            
    call mpi_allgather(Ujacob(0:proc_nx-1), proc_nx, mpi_float,                         &             
                    &  Ujacob_all,          proc_nx, mpi_float, mpi_comm_world, ierror)               

    !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~             
    ! Compute error and check if less than tolerance value                                            
    error = sqrt((sum(Ujacob_all - Uold_all)**2) / dble(grid_nx))                                     

    if(error < error_tol) return                                                                      
    !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~             
    ! Exchange data points                                                                            

    ! Interior processors                                                                         
    if(Xsrc /= -1 .AND. Xdes /= -1) then
        call mpi_send(Ujacob(        0), 1, mpi_float, Xsrc, 200, mpi_comm_world, ierror)         
        call mpi_send(Ujacob(proc_nx-1), 1, mpi_float, Xdes, 100, mpi_comm_world, ierror)         

        call mpi_recv(Ujacob(     -1), 1, mpi_float, Xsrc, 100, mpi_comm_world, stat, ierror)     
        call mpi_recv(Ujacob(proc_nx), 1, mpi_float, Xdes, 200, mpi_comm_world, stat, ierror)
    ! First processor                                                                             
    elseif(Xsrc == -1) then                                                                    
        call mpi_send(Ujacob(proc_nx-1), 1, mpi_float, Xdes, 100, mpi_comm_world, ierror)         
        call mpi_recv(Ujacob(proc_nx  ), 1, mpi_float, Xdes, 200, mpi_comm_world, stat, ierror)
    ! Last processor                                                                              
    elseif(Xdes == -1) then                                                                   
        call mpi_send(Ujacob( 0), 1, mpi_float, Xsrc, 200, mpi_comm_world, ierror)                
        call mpi_recv(Ujacob(-1), 1, mpi_float, Xsrc, 100, mpi_comm_world, stat, ierror)          
    end if                                                                                                           
end do  

此外，我还检查了处理器秩0和

nprocs-1

是否确实对应于左边界和右边界处理器

---

我已经检查过标签是否设置好了。此外，您可以随意评论任何您认为可以改进的内容。

@Hristo正确的是，您的代码在原则上存在概念上的缺陷。但是，几乎每个MPI实现都会为包含单个实数的消息缓冲MPI_发送（当然这不是保证的），因此这不是代码的问题

我认为您的标签不匹配-边缘案例应将标签反转：

  elseif(Xsrc == -1) then                                                                    
        call mpi_send(Ujacob(proc_nx-1), 1, mpi_float, Xdes, 200, mpi_comm_world, ierror)         
        call mpi_recv(Ujacob(proc_nx  ), 1, mpi_float, Xdes, 100, mpi_comm_world, stat, ierror)
    ! Last processor                                                                              
    elseif(Xdes == -1) then                                                                   
        call mpi_send(Ujacob( 0), 1, mpi_float, Xsrc, 100, mpi_comm_world, ierror)                
        call mpi_recv(Ujacob(-1), 1, mpi_float, Xsrc, 200, mpi_comm_world, stat, ierror)          
    end if      

关于代码的其他一些评论：

• 使用allgather计算错误项的效率非常低：您应该只对局部元素求和，然后使用MPI_Allreduce计算全局错误
• 对于Fortran代码，应该使用MPI_REAL而不是MPI_FLOAT
• 我看不出我们的代码如何在单个进程上运行——在这里，该进程将执行第一个elseif子句，然后尝试发送到一个不存在的列组

---

一旦你检查了你的标签现在是正确的，你就应该修复@Hristo指出的问题。

我想看看你如何设置

Xsrc

和

Xdes

@d_1999是的，请看edit你的halo交换在概念上是有缺陷的，因为你依赖

MPI_SEND

进行缓冲，这可能并不总是如此。使用

MPI\u SENDRECV

可在不阻塞的情况下同时发送和接收。另外，不要使用如此复杂的逻辑进行发送和接收。只需对边界列组的不存在邻居使用

MPI\u PROC\u NULL

而不是

-1

，并始终在两个方向上执行sendrecv。发送到

MPI\u PROC\u NULL

或从中接收都是不可操作的。我认为您在编辑的上一个分支中有一个输入错误。计算速度快，通信速度慢-不是这样。你不会看到任何小数组的加速。事实上，标签是正确的。主要问题是由于定义

Xsrc

和

Xdes

时输入错误。我修复了它以及我遇到的其他效率低下的问题——见上面的评论。不过我有个问题。您所说的“几乎每个MPI实现都将缓冲

MPI_SEND

以处理包含单个实数的消息”是什么意思？问题在于发送是同步的（即在发布匹配的接收之前不会完成）还是异步的（无论是否有匹配的接收都会完成）.Ssend保证同步，Bsend保证异步。但是，Send可以是其中之一。这是@HristoIliev提出的观点-如果Send是同步的，那么您的代码将死锁，因为所有进程都在发送，而没有任何进程在接收。异步发送需要稍后制作副本并传递。对于小消息，MPI通常需要副本；对于大型邮件，将没有空间，因此它使用同步发送。

  elseif(Xsrc == -1) then                                                                    
        call mpi_send(Ujacob(proc_nx-1), 1, mpi_float, Xdes, 200, mpi_comm_world, ierror)         
        call mpi_recv(Ujacob(proc_nx  ), 1, mpi_float, Xdes, 100, mpi_comm_world, stat, ierror)
    ! Last processor                                                                              
    elseif(Xdes == -1) then                                                                   
        call mpi_send(Ujacob( 0), 1, mpi_float, Xsrc, 100, mpi_comm_world, ierror)                
        call mpi_recv(Ujacob(-1), 1, mpi_float, Xsrc, 200, mpi_comm_world, stat, ierror)          
    end if