CODEWITHSUNDEEP
fortranmpi
Felix
Felix

Reputation: 429

Fortran + MPI: Issue with Gatherv

I am trying to distribute a 2D array using Scatterv, which works fine. However, the corresponding Gatherv operation gives an error: message truncated. Can someone explain what I am doing wrong.

program scatterv
use mpi
implicit none

integer, allocatable, dimension(:,:) :: array
integer, allocatable, dimension(:) :: chunk
integer, allocatable, dimension(:) :: displacement
integer, allocatable, dimension(:) :: sendcounts
integer :: mpi_ierr, mpi_rank, mpi_size
integer, parameter :: kWidth=4

call MPI_INIT(mpi_ierr)
call MPI_COMM_RANK(MPI_COMM_WORLD, mpi_rank, mpi_ierr)
call MPI_COMM_SIZE(MPI_COMM_WORLD, mpi_size, mpi_ierr)

if (mpi_rank == 0) then
    allocate(array(mpi_size, kWidth))
    allocate(displacement(mpi_size))
    allocate(sendcounts(mpi_size))
    displacement = (/0, 0, 0, 0, 0, 0, 0, 0, 0, 0/)
    sendcounts = (/2, 10, 5, 8, 5, 2, 2, 2, 2, 2/)
endif

allocate(chunk(mpi_size))

call MPI_SCATTERV(array, sendcounts, displacement, MPI_INTEGER, chunk, mpi_size, MPI_INTEGER, 0, MPI_COMM_WORLD, mpi_ierr)

...

call MPI_GATHERV(chunk, mpi_size, MPI_INTEGER, array, sendcounts, displacement, MPI_INTEGER, 0, MPI_COMM_WORLD, mpi_ierr)

if (mpi_rank == 0) then
    deallocate(array)
    deallocate(displacement)
end if
deallocate(chunk)

call MPI_FINALIZE(mpi_ierr)
end program scatterv

Upvotes: 1

Views: 224

Answers (2)

Hristo Iliev
Hristo Iliev

Reputation: 74455

There are multiple errors in the code presented here.

1) All displacements are equal:

if (mpi_rank == 0) then
    ...
    displacement = (/0, 0, 0, 0, 0, 0, 0, 0, 0, 0/)
    sendcounts = (/2, 10, 5, 8, 5, 2, 2, 2, 2, 2/)
endif

The MPI standard mandates that no location in the send buffer should be read twice and no location in the receive buffer should be written twice. In order words, all chunks must be disjoint. Displacements are allowed to be equal only if the corresponding send counts are 0 (zero).

Some (if not most) MPI libraries do not enforce this condition for performance reasons. It might work, it might not work, all depending on the device used to transfer the data. Even if it works, it is still not correct MPI.

2) The receive count in MPI_SCATTERV does not match the chunk size:

call MPI_COMM_SIZE(MPI_COMM_WORLD, mpi_size, mpi_ierr)
...
sendcounts = (/2, 10, 5, 8, 5, 2, 2, 2, 2, 2/)
...
call MPI_SCATTERV(array, sendcounts, displacement, MPI_INTEGER, &
                  chunk, mpi_size, MPI_INTEGER, &
                  0, MPI_COMM_WORLD, mpi_ierr)

While for point-to-point operations one could provide a buffer that is larger than what the message actually occupies, with collective operations this is not the case - the amount of data sent to a process must match the size of the receive buffer as specified by the process. Some implementations are fine with with larger buffers but programs that rely on that are not correct.

The only reason the scatter operation works is that you have 10 MPI processes (judging from the size of the array initialiser) and the largest chunk size is also 10.

3) The same applies in reverse to the gather operation. But in that case all send counts except one (for rank 1) are bigger than the expected chunk size.

The corrected version of the program should look like this:

call MPI_INIT(mpi_ierr)
call MPI_COMM_RANK(MPI_COMM_WORLD, mpi_rank, mpi_ierr)
call MPI_COMM_SIZE(MPI_COMM_WORLD, mpi_size, mpi_ierr)

allocate(sendcounts(mpi_size))
sendcounts = (/2, 10, 5, 8, 5, 2, 2, 2, 2, 2/)

if (mpi_rank == 0) then
    allocate(array(mpi_size, kWidth))
    allocate(displacement(mpi_size))
    displacement = (/0, 2, 12, 17, 25, 27, 29, 31, 33, 35/)
endif

allocate(chunk(mpi_size))

call MPI_SCATTERV(array, sendcounts, displacement, MPI_INTEGER, &
                  chunk, sendcounts(mpi_rank+1), MPI_INTEGER, &
                  0, MPI_COMM_WORLD, mpi_ierr)

...

call MPI_GATHERV(chunk, sendcounts(mpi_rank+1), MPI_INTEGER, &
                 array, sendcounts, displacement, MPI_INTEGER, &
                 0, MPI_COMM_WORLD, mpi_ierr)

if (mpi_rank == 0) then
    deallocate(array)
    deallocate(displacement)
end if

deallocate(chunk)
deallocate(sendcounts)

call MPI_FINALIZE(mpi_ierr)

Note the use of +1 in sendcounts(mpi_rank+1). MPI ranks are numbered staring from 0 while Fortran array indexes start from 1 unless specified otherwise.

Also, you should not use the mpi_ prefix for naming your own subroutines/functions/modules/variables in order to prevent name clashes with true MPI symbols.

Upvotes: 3

Wesley Bland
Wesley Bland

Reputation: 9072

The problem is that amount of data sent is greater than the amount of data that the root told MPI it expects. You created an array called sendcounts that has some counts that the root process will use to assign spaces in the array to different ranks, however each process is sending mpi_size, which is probably bigger than some of the sendcounts (like 2 for instance). You need to make sure that the numbers match up. You can find an example code here.

Upvotes: 2

Related Questions