parallel-processing - 用 MPI_ISEND 和 fortran 拆分数组的问题

Question

我编写了以下代码行，旨在将一维数组Jp（仅存在于主进程上）划分为不同的进程（包括主进程）。每个进程都必须接收一个非连续修改数据块（值在内部循环中更改），我newF使用 MPI_TYPE_INDEXED 函数创建了一个新格式来选择要发送的正确数据部分。我使用 MPI_RECV 或 MPI_IRECV 来接收数据。

问题是这部分代码工作正常，任何数量的任务（从 1 到 8），直到元素的数量Jp很小，当我增加这样的数量（即 n = 5000）时，并非所有进程都收到数据和拆分后的数组JpS显示了我用来初始化它的值（即-10000）。注释的行显示了为解决此问题所做的所有更改，有人知道吗？

program test_send
      use mpi
      implicit none

      integer              :: rank, nproc, mpi_stat
      integer              :: n, m, k, io, i, j
      integer, allocatable :: Jp(:), JpS(:), JpAux(:)
      integer              :: count, n_distro,newF
      integer, allocatable :: sendcounts(:), displ(:), &
                              blocklens(:), blockdisp(:), &
                              request(:)
      integer              :: ARRAY_OF_STATUS(MPI_STATUS_SIZE), error

      data count /3/



      call mpi_init(mpi_stat)
      call mpi_comm_size(mpi_comm_world, nproc, mpi_stat)
      call mpi_comm_rank(mpi_comm_world, rank, mpi_stat)

      n = 400*count


      allocate(sendcounts(nproc), displ(nproc), &
               blocklens(count), blockdisp(count), request(nproc))


if (rank.eq.0) then
allocate(Jp(n+1),JpAux(n+1))
Jp = 0
do i = 1,n+1
  Jp(i) = i
enddo
endif

call mpi_barrier(mpi_comm_world, mpi_stat)

      m = n/count

      n_distro = (m+1)/nproc
      k = 0

      do i = 1,nproc
      if (i<nproc) then
              sendcounts(i) = n_distro
      else
              sendcounts(i) = m - (nproc-1)*n_distro
      endif
      displ(i) = k
      k = k + sendcounts(i)
      enddo

      call mpi_barrier(mpi_comm_world, mpi_stat)
    allocate(JpS(count*sendcounts(rank+1)+1))
      call mpi_barrier(mpi_comm_world, mpi_stat)

!      call mpi_irecv(JpS, (sendcounts(rank+1))*count+1,mpi_int,0,0,mpi_comm_world, request(rank+1), mpi_stat)
!      call mpi_recv(JpS, (sendcounts(rank+1))*count+1,mpi_int,0,0,mpi_comm_world, MPI_STATUS_IGNORE,mpi_stat)
      !call mpi_waitall(1,request,ARRAY_OF_STATUS,error)
!      call mpi_barrier(mpi_comm_world, mpi_stat)

      if (rank.eq.0) then
              do i = 0,nproc-1
               JpAux = -100000
               blocklens = spread(sendcounts(i+1),1,count)
               blockdisp = spread(displ(i+1),1,count) + (/ (k*m, k=0,count-1) /)

               blocklens(count) = blocklens(count)+1
 
               do j = 1,count
               if (j.eq.1) then
                        JpAux(blockdisp(j)+1:blockdisp(j)+blocklens(j)) = Jp(blockdisp(j)+1:blockdisp(j)+blocklens(j))&
                                                -Jp(blockdisp(j)+1)
               else
                        JpAux(blockdisp(j)+1:blockdisp(j)+blocklens(j)) = Jp( blockdisp(j) + 1 : blockdisp(j) + blocklens(j) )&
                                     -Jp( blockdisp(j)+1 ) + JpAux( blockdisp(j-1) + blocklens(j-1))&
                                     +(Jp( blockdisp(j-1)+blocklens(j-1)+1 )-Jp( blockdisp(j-1)+blocklens(j-1)))
               endif
               enddo

               call mpi_type_indexed(count, blocklens, blockdisp, mpi_int, newF, mpi_stat)
               call mpi_type_commit(newF, mpi_stat)
               call mpi_isend(JpAux, 1, newF, i, i, mpi_comm_world, request(i+1), mpi_stat)
               call mpi_type_free(newF, mpi_stat)
      
             enddo

      endif
!    call mpi_wait(request(rank+1), ARRAY_OF_STATUS, mpi_stat)
         call mpi_barrier(mpi_comm_world, mpi_stat)
!call mpi_waitall(1,request,ARRAY_OF_STATUS,error)
      call mpi_recv(JpS, (sendcounts(rank+1))*count+1,mpi_int,0,MPI_ANY_TAG,mpi_comm_world, MPI_STATUS_IGNORE,mpi_stat)
      ! print*, request

      print*, 'rank: ', rank, ', size: ', size(JpS), ', Jp: ', JpS

  
      call mpi_barrier(mpi_comm_world, mpi_stat)
      call mpi_finalize(mpi_stat)

end program test_send

标签： parallel-processingfortranmpi