mpi_test.F90

Go to the documentation of this file.

!! Copyright (C) 2022 S. Ohlmann
!!
!! This program is free software; you can redistribute it and/or modify
!! it under the terms of the GNU General Public License as published by
!! the Free Software Foundation; either version 2, or (at your option)
!! any later version.
!!
!! This program is distributed in the hope that it will be useful,
!! but WITHOUT ANY WARRANTY; without even the implied warranty of
!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!! GNU General Public License for more details.
!!
!! You should have received a copy of the GNU General Public License
!! along with this program; if not, write to the Free Software
!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
!! 02110-1301, USA.
!!
 
#include "global.h"
 
module mpi_test_oct_m
  use global_oct_m
  use math_oct_m
  use messages_oct_m
  use mpi_oct_m
  use profiling_oct_m
  implicit none
  private
 
  public :: test_mpiwrappers
 
contains
 
  subroutine test_mpiwrappers
    if (test_scatterv()) then
      write(message(1), *) "scatterv: PASS"
    else
      write(message(1), *) "scatterv: FAIL"
    end if
    call messages_info(1)
 
    if (test_gatherv()) then
      write(message(1), *) "gatherv: PASS"
    else
      write(message(1), *) "gatherv: FAIL"
    end if
    call messages_info(1)
 
    if (test_allgatherv()) then
      write(message(1), *) "allgatherv: PASS"
    else
      write(message(1), *) "allgatherv: FAIL"
    end if
    call messages_info(1)
 
    if (test_alltoallv()) then
      write(message(1), *) "alltoallv: PASS"
    else
      write(message(1), *) "alltoallv: FAIL"
    end if
    call messages_info(1)
  end subroutine test_mpiwrappers
 
  logical function test_scatterv()
    real(real64), allocatable :: sendbuf(:), irecvbuf(:), lrecvbuf(:)
    integer, allocatable :: sendcnts(:), recvcounts(:)
    integer(int32), allocatable :: isdispls(:)
    integer(int64), allocatable :: lsdispls(:)
    integer, parameter :: N = 10003
    integer :: ii
    logical :: equal, allequal
 
    safe_allocate(sendcnts(1:mpi_world%size))
    safe_allocate(isdispls(1:mpi_world%size))
    safe_allocate(lsdispls(1:mpi_world%size))
    safe_allocate(recvcounts(1:1))
    do ii = 1, mpi_world%size
      isdispls(ii) = (ii-1) * n / mpi_world%size
      lsdispls(ii) = (ii-1) * n / mpi_world%size
      sendcnts(ii) = ii * n / mpi_world%size - isdispls(ii)
    end do
    if (mpi_world%is_root()) then
      safe_allocate(sendbuf(1:n))
      do ii = 1, n
        sendbuf(ii) = ii
      end do
    else
      ! MPI_Scatterv ignores sendbuf on non-root ranks, but an unallocated
      ! array must not be passed to the assumed-shape dummy argument
      safe_allocate(sendbuf(1:1))
    end if
    recvcounts(1) = sendcnts(mpi_world%rank+1)
    safe_allocate(irecvbuf(1:recvcounts(1)))
    safe_allocate(lrecvbuf(1:recvcounts(1)))
 
    call mpi_world%scatterv(sendbuf, sendcnts, isdispls, mpi_double_precision, irecvbuf, recvcounts(1), mpi_double_precision, 0)
    call mpi_world%scatterv(sendbuf, sendcnts, lsdispls, mpi_double_precision, lrecvbuf, recvcounts(1), mpi_double_precision, 0)
 
    equal = all(is_close(irecvbuf, lrecvbuf))
    call mpi_world%allreduce(equal, allequal, 1, mpi_logical, mpi_land)
    test_scatterv = allequal
 
    safe_deallocate_a(sendcnts)
    safe_deallocate_a(isdispls)
    safe_deallocate_a(lsdispls)
    safe_deallocate_a(recvcounts)
    safe_deallocate_a(sendbuf)
    safe_deallocate_a(irecvbuf)
    safe_deallocate_a(lrecvbuf)
  end function test_scatterv
 
  logical function test_gatherv()
    real(real64), allocatable :: sendbuf(:), irecvbuf(:), lrecvbuf(:)
    integer, allocatable :: sendcnts(:), recvcounts(:)
    integer(int32), allocatable :: irdispls(:)
    integer(int64), allocatable :: lrdispls(:)
    integer, parameter :: N = 10003
    integer :: ii
    logical :: equal, allequal
 
    safe_allocate(recvcounts(1:mpi_world%size))
    safe_allocate(irdispls(1:mpi_world%size))
    safe_allocate(lrdispls(1:mpi_world%size))
    safe_allocate(sendcnts(1:1))
    do ii = 1, mpi_world%size
      irdispls(ii) = (ii-1) * n / mpi_world%size
      lrdispls(ii) = (ii-1) * n / mpi_world%size
      recvcounts(ii) = ii * n / mpi_world%size - irdispls(ii)
    end do
    if (mpi_world%is_root()) then
      safe_allocate(irecvbuf(1:n))
      safe_allocate(lrecvbuf(1:n))
    else
      ! MPI_Gatherv ignores recvbuf on non-root ranks, but unallocated
      ! arrays must not be passed to the assumed-shape dummy arguments
      safe_allocate(irecvbuf(1:1))
      safe_allocate(lrecvbuf(1:1))
    end if
    sendcnts(1) = recvcounts(mpi_world%rank+1)
    safe_allocate(sendbuf(1:sendcnts(1)))
    do ii = 1, sendcnts(1)
      sendbuf(ii) = ii
    end do
 
    call mpi_world%gatherv(sendbuf, sendcnts(1), mpi_double_precision, irecvbuf, recvcounts, irdispls, mpi_double_precision, 0)
    call mpi_world%gatherv(sendbuf, sendcnts(1), mpi_double_precision, lrecvbuf, recvcounts, lrdispls, mpi_double_precision, 0)
 
    equal = .true.
    if (mpi_world%is_root()) then
      equal = all(is_close(irecvbuf, lrecvbuf))
    end if
    call mpi_world%allreduce(equal, allequal, 1, mpi_logical, mpi_land)
    test_gatherv = allequal
 
    safe_deallocate_a(recvcounts)
    safe_deallocate_a(irdispls)
    safe_deallocate_a(lrdispls)
    safe_deallocate_a(sendcnts)
    safe_deallocate_a(irecvbuf)
    safe_deallocate_a(lrecvbuf)
    safe_deallocate_a(sendbuf)
  end function test_gatherv
 
  logical function test_allgatherv()
    real(real64), allocatable :: sendbuf(:), irecvbuf(:), lrecvbuf(:)
    integer, allocatable :: sendcnts(:), recvcounts(:)
    integer(int32), allocatable :: irdispls(:)
    integer(int64), allocatable :: lrdispls(:)
    integer, parameter :: n = 10003
    integer :: ii
    logical :: equal, allequal
 
    safe_allocate(recvcounts(1:mpi_world%size))
    safe_allocate(irdispls(1:mpi_world%size))
    safe_allocate(lrdispls(1:mpi_world%size))
    safe_allocate(sendcnts(1:1))
    do ii = 1, mpi_world%size
      irdispls(ii) = (ii-1) * n / mpi_world%size
      lrdispls(ii) = (ii-1) * n / mpi_world%size
      recvcounts(ii) = ii * n / mpi_world%size - irdispls(ii)
    end do
    safe_allocate(irecvbuf(1:n))
    safe_allocate(lrecvbuf(1:n))
    sendcnts(1) = recvcounts(mpi_world%rank+1)
    safe_allocate(sendbuf(1:sendcnts(1)))
    do ii = 1, sendcnts(1)
      sendbuf(ii) = ii
    end do
 
    call mpi_world%allgatherv(sendbuf, sendcnts(1), mpi_double_precision, irecvbuf, recvcounts, irdispls, mpi_double_precision)
    call mpi_world%allgatherv(sendbuf, sendcnts(1), mpi_double_precision, lrecvbuf, recvcounts, lrdispls, mpi_double_precision)
 
    equal = all(is_close(irecvbuf, lrecvbuf))
    call mpi_world%allreduce(equal, allequal, 1, mpi_logical, mpi_land)
    test_allgatherv = allequal
 
    safe_deallocate_a(recvcounts)
    safe_deallocate_a(irdispls)
    safe_deallocate_a(lrdispls)
    safe_deallocate_a(sendcnts)
    safe_deallocate_a(irecvbuf)
    safe_deallocate_a(lrecvbuf)
    safe_deallocate_a(sendbuf)
  end function test_allgatherv
 
  logical function test_alltoallv()
    real(real64), allocatable :: sendbuf(:), irecvbuf(:), lrecvbuf(:)
    integer, allocatable :: sendcnts(:), recvcounts(:)
    integer(int32), allocatable :: isdispls(:), irdispls(:)
    integer(int64), allocatable :: lsdispls(:), lrdispls(:)
    integer, parameter :: n = 10003
    integer :: ii
    logical :: equal, allequal
 
    safe_allocate(sendcnts(1:mpi_world%size))
    safe_allocate(isdispls(1:mpi_world%size))
    safe_allocate(lsdispls(1:mpi_world%size))
    safe_allocate(irdispls(1:mpi_world%size))
    safe_allocate(lrdispls(1:mpi_world%size))
    safe_allocate(recvcounts(1:mpi_world%size))
    do ii = 1, mpi_world%size
      isdispls(ii) = (ii-1) * n / mpi_world%size
      lsdispls(ii) = (ii-1) * n / mpi_world%size
      sendcnts(ii) = ii * n / mpi_world%size - isdispls(ii)
    end do
    safe_allocate(sendbuf(1:n))
    do ii = 1, n
      sendbuf(ii) = ii
    end do
    call mpi_world%alltoall(sendcnts, 1, mpi_integer, recvcounts, 1, mpi_integer)
    safe_allocate(irecvbuf(1:sum(recvcounts)))
    safe_allocate(lrecvbuf(1:sum(recvcounts)))
    irdispls(1) = 0
    lrdispls(1) = 0
    do ii = 2, mpi_world%size
      irdispls(ii) = irdispls(ii-1) + recvcounts(ii-1)
      lrdispls(ii) = lrdispls(ii-1) + recvcounts(ii-1)
    end do
 
    call mpi_world%alltoallv(sendbuf, sendcnts, isdispls, mpi_double_precision, &
      irecvbuf, recvcounts, irdispls, mpi_double_precision)
    call mpi_world%alltoallv(sendbuf, sendcnts, lsdispls, mpi_double_precision, &
      lrecvbuf, recvcounts, lrdispls, mpi_double_precision)
 
    equal = all(is_close(irecvbuf, lrecvbuf))
    call mpi_world%allreduce(equal, allequal, 1, mpi_logical, mpi_land)
    test_alltoallv = allequal
 
    safe_deallocate_a(sendcnts)
    safe_deallocate_a(isdispls)
    safe_deallocate_a(lsdispls)
    safe_deallocate_a(irdispls)
    safe_deallocate_a(lrdispls)
    safe_deallocate_a(recvcounts)
    safe_deallocate_a(sendbuf)
    safe_deallocate_a(irecvbuf)
    safe_deallocate_a(lrecvbuf)
  end function test_alltoallv
end module mpi_test_oct_m