From b95a04e6a148d15a98c8c7bb19249d5cfd82a08e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Fri, 16 Aug 2024 22:11:52 +0200 Subject: [PATCH 1/4] Integrate Fortuno, convert bcast test --- CMakeLists.txt | 3 + cmake/MpiFxUtils.cmake | 5 +- lib/CMakeLists.txt | 2 +- meson.build | 2 - subprojects/Fortuno.cmake | 24 +++++ subprojects/FortunoMpi.cmake | 24 +++++ test/CMakeLists.txt | 44 +-------- test/meson.build | 24 ----- test/test_bcast.f90 | 72 --------------- test/unit/CMakeLists.txt | 34 +++++++ test/{ => unit}/test_allgather.f90 | 0 test/{ => unit}/test_allgatherv.f90 | 0 test/{ => unit}/test_allreduce.f90 | 0 test/unit/test_bcast.fpp | 111 +++++++++++++++++++++++ test/{ => unit}/test_comm_split.f90 | 0 test/{ => unit}/test_comm_split_type.f90 | 0 test/{ => unit}/test_gather.f90 | 0 test/{ => unit}/test_gatherv.f90 | 0 test/{ => unit}/test_reduce.f90 | 0 test/{ => unit}/test_scatter.f90 | 0 test/{ => unit}/test_scatterv.f90 | 0 test/{ => unit}/test_send_recv.f90 | 0 test/{ => unit}/test_win_shared_mem.f90 | 0 test/unit/testapp.f90 | 12 +++ test/{ => unit}/testhelper.f90 | 0 25 files changed, 213 insertions(+), 144 deletions(-) create mode 100644 subprojects/Fortuno.cmake create mode 100644 subprojects/FortunoMpi.cmake delete mode 100644 test/meson.build delete mode 100644 test/test_bcast.f90 create mode 100644 test/unit/CMakeLists.txt rename test/{ => unit}/test_allgather.f90 (100%) rename test/{ => unit}/test_allgatherv.f90 (100%) rename test/{ => unit}/test_allreduce.f90 (100%) create mode 100644 test/unit/test_bcast.fpp rename test/{ => unit}/test_comm_split.f90 (100%) rename test/{ => unit}/test_comm_split_type.f90 (100%) rename test/{ => unit}/test_gather.f90 (100%) rename test/{ => unit}/test_gatherv.f90 (100%) rename test/{ => unit}/test_reduce.f90 (100%) rename test/{ => unit}/test_scatter.f90 (100%) rename test/{ => unit}/test_scatterv.f90 (100%) rename test/{ => unit}/test_send_recv.f90 (100%) rename test/{ => unit}/test_win_shared_mem.f90 (100%) create mode 100644 test/unit/testapp.f90 rename test/{ => unit}/testhelper.f90 (100%) diff --git a/CMakeLists.txt b/CMakeLists.txt index 67273fa..7906813 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -35,6 +35,9 @@ include(GNUInstallDirs) add_subdirectory(lib) include(CTest) # note: this adds a BUILD_TESTING which defaults to ON if(BUILD_TESTING) + include(FetchContent) + include(subprojects/Fortuno.cmake) + include(subprojects/FortunoMpi.cmake) enable_testing() add_subdirectory(test) endif() diff --git a/cmake/MpiFxUtils.cmake b/cmake/MpiFxUtils.cmake index e94f5a7..566b33b 100644 --- a/cmake/MpiFxUtils.cmake +++ b/cmake/MpiFxUtils.cmake @@ -1,17 +1,18 @@ # Register custom commands for processing source files with fypp (.fpp -> .f90) # # Args: +# fyppflags [in]: Flags to use when invoking the fypp preprocessor (using ${FYPP}) # oldfiles [in]: List of files to preprocess (must have .fpp suffix) # newfiles [out]: List of preprocessed files (will have .f90 suffix). # -function(fypp_preprocess oldfiles newfiles) +function(fypp_preprocess fyppflags oldfiles newfiles) set(_newfiles) foreach(oldfile IN LISTS oldfiles) string(REGEX REPLACE "\\.fpp" ".f90" newfile ${oldfile}) add_custom_command( OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/${newfile} - COMMAND ${FYPP} ${FYPP_FLAGS} ${CMAKE_CURRENT_SOURCE_DIR}/${oldfile} ${CMAKE_CURRENT_BINARY_DIR}/${newfile} + COMMAND ${FYPP} ${fyppflags} ${CMAKE_CURRENT_SOURCE_DIR}/${oldfile} ${CMAKE_CURRENT_BINARY_DIR}/${newfile} MAIN_DEPENDENCY ${CMAKE_CURRENT_SOURCE_DIR}/${oldfile}) list(APPEND _newfiles ${CMAKE_CURRENT_BINARY_DIR}/${newfile}) endforeach() diff --git a/lib/CMakeLists.txt b/lib/CMakeLists.txt index f5d23d5..b565cb9 100644 --- a/lib/CMakeLists.txt +++ b/lib/CMakeLists.txt @@ -21,7 +21,7 @@ set(sources-fpp mpifx_send.fpp mpifx_win.fpp) -fypp_preprocess("${sources-fpp}" sources-f90) +fypp_preprocess("${FYPP_FLAGS}" "${sources-fpp}" sources-f90) # Some MPI frameworks (e.g. MPICH) do not provide all possible argument # combinations explicitely in their mpi module. Consequently, compilers diff --git a/meson.build b/meson.build index 19d724c..77f2662 100644 --- a/meson.build +++ b/meson.build @@ -28,5 +28,3 @@ if install install_dir: get_option('datadir')/'licenses'/meson.project_name() ) endif - -subdir('test') diff --git a/subprojects/Fortuno.cmake b/subprojects/Fortuno.cmake new file mode 100644 index 0000000..b947aef --- /dev/null +++ b/subprojects/Fortuno.cmake @@ -0,0 +1,24 @@ +# Variables influencing how subproject is obtained +set(CMAKE_REQUIRE_FIND_PACKAGE_Fortuno ${MYPROJECT_SUBPROJECT_REQUIRE_FIND}) +set(CMAKE_DISABLE_FIND_PACKAGE_Fortuno ${MYPROJECT_SUBPROJECT_DISABLE_FIND}) +# set FETCHCONTENT_SOURCE_DIR_FORTUNO to use a local source of the subproject + +# Subproject related variables +option( + FORTUNO_BUILD_SHARED_LIBS "Fortuno: Build as shared library" ${MYPROJECT_BUILD_SHARED_LIBS} +) + +# Make subproject available +FetchContent_Declare( + Fortuno + GIT_REPOSITORY "https://github.com/fortuno-repos/fortuno.git" + GIT_TAG "main" + FIND_PACKAGE_ARGS +) +FetchContent_MakeAvailable(Fortuno) + +if (Fortuno_FOUND) + message(STATUS "Subproject Fortuno: using installed version") +else () + message(STATUS "Subproject Fortuno: building from source in ${Fortuno_SOURCE_DIR}") +endif () diff --git a/subprojects/FortunoMpi.cmake b/subprojects/FortunoMpi.cmake new file mode 100644 index 0000000..13441d0 --- /dev/null +++ b/subprojects/FortunoMpi.cmake @@ -0,0 +1,24 @@ +# Variables influencing how subproject is obtained +set(CMAKE_REQUIRE_FIND_PACKAGE_FortunoMpi ${MYPROJECT_SUBPROJECT_REQUIRE_FIND}) +set(CMAKE_DISABLE_FIND_PACKAGE_FortunoMpi ${MYPROJECT_SUBPROJECT_DISABLE_FIND}) +# set FETCHCONTENT_SOURCE_DIR_FORTUNO to use a local source of the subproject + +# Subproject related variables +option( + FORTUNO_MPI_BUILD_SHARED_LIBS "Fortuno: Build as shared library" ${MYPROJECT_BUILD_SHARED_LIBS} +) + +# Make subproject available +FetchContent_Declare( + FortunoMpi + GIT_REPOSITORY "https://github.com/aradi/fortuno-mpi.git" + GIT_TAG "fypp" + FIND_PACKAGE_ARGS +) +FetchContent_MakeAvailable(FortunoMpi) + +if (FortunoMpi_FOUND) + message(STATUS "Subproject FortunoMpi: using installed version") +else () + message(STATUS "Subproject FortunoMpi: building from source in ${fortunompi_SOURCE_DIR}") +endif () diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index 394cd1e..269aea0 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -1,43 +1 @@ -set(tested - test_allgather - test_allgatherv) - -set(targets - ${tested} - test_allreduce - test_bcast - test_comm_split - test_comm_split_type - test_gather - test_gatherv - test_reduce - test_scatter - test_scatterv - test_win_shared_mem) - -set(sources-helper - testhelper.f90) - -add_library(mpifxtesthelp ${sources-helper}) -target_link_libraries(mpifxtesthelp PRIVATE MPI::MPI_Fortran MpiFx) - -foreach(target IN LISTS targets) - add_executable(${target} ${target}.f90) - target_link_libraries(${target} MpiFx mpifxtesthelp) -endforeach() - -foreach(target IN LISTS tested) - add_test(NAME ${target} - COMMAND ${MPIEXEC_EXECUTABLE} - ${MPIEXEC_NUMPROC_FLAG} - ${MPIEXEC_MAX_NUMPROCS} - ${MPIEXEC_PREFLAGS} - ${CMAKE_CURRENT_BINARY_DIR}/${target} - ${MPIEXEC_POSTFLAGS}) - set_tests_properties(${target} PROPERTIES - # test cases generate this on stdOut - PASS_REGULAR_EXPRESSION "TestPASSED") - set_tests_properties(${target} PROPERTIES - # test cases generate this on stdOut - FAIL_REGULAR_EXPRESSION "TestFAILED") -endforeach() +add_subdirectory(unit) diff --git a/test/meson.build b/test/meson.build deleted file mode 100644 index fd98ff5..0000000 --- a/test/meson.build +++ /dev/null @@ -1,24 +0,0 @@ -# SPDX-Identifier: BSD-2-Clause - -tests = [ - 'allgather', - 'allgatherv', - 'allreduce', - 'bcast', - 'comm_split', - 'comm_split_type', - 'gather', - 'gatherv', - 'reduce', - 'scatter', - 'scatterv', - 'win_shared_mem', -] - -foreach t : tests - executable( - 'test_@0@'.format(t), - sources: files('test_@0@.f90'.format(t)), - dependencies: mpifx_dep, - ) -endforeach diff --git a/test/test_bcast.f90 b/test/test_bcast.f90 deleted file mode 100644 index d4e5ba0..0000000 --- a/test/test_bcast.f90 +++ /dev/null @@ -1,72 +0,0 @@ -program test_bcast - use libmpifx_module - implicit none - - integer, parameter :: dp = kind(1.0d0) - integer, parameter :: sp = kind(1.0) - - type(mpifx_comm) :: mycomm - integer :: buffer(3) - logical :: lbuffer(3) - real(dp) :: rbuffer(2, 2) - complex(sp) :: cbuffer - character(5) :: text - - ! Integer vector - call mpifx_init() - call mycomm%init() - buffer(:) = 0 - print "(A,I2.2,A,3I5)", "CHK01:", mycomm%rank, ":", buffer - if (mycomm%lead) then - buffer(:) = [ 1, 2, 3 ] - end if - print "(A,I2.2,A,3I5)", "CHK02:", mycomm%rank, ":", buffer - call mpifx_bcast(mycomm, buffer) - print "(A,I2.2,A,3I5)", "CHK03:", mycomm%rank, ":", buffer - call mpifx_barrier(mycomm) - - ! Logical vector - lbuffer(:) = .false. - print "(A,I2.2,A,3L5)", "CHK04:", mycomm%rank, ":", lbuffer - if (mycomm%lead) then - lbuffer(:) = [ .true., .false., .true. ] - end if - print "(A,I2.2,A,3L5)", "CHK05:", mycomm%rank, ":", lbuffer - call mpifx_bcast(mycomm, lbuffer) - print "(A,I2.2,A,3L5)", "CHK06:", mycomm%rank, ":", lbuffer - call mpifx_barrier(mycomm) - - ! Real rank 2 array - rbuffer(:,:) = 0.0_dp - print "(A,I2.2,A,4F10.6)", "CHK07:", mycomm%rank, ":", rbuffer - if (mycomm%lead) then - rbuffer(:,:) = reshape([ real(dp) :: 1, 2, 3, 4 ], [ 2, 2 ]) - end if - print "(A,I2.2,A,4F10.6)", "CHK08:", mycomm%rank, ":", rbuffer - call mpifx_bcast(mycomm, rbuffer) - print "(A,I2.2,A,4F10.6)", "CHK09:", mycomm%rank, ":", rbuffer - call mpifx_barrier(mycomm) - - ! Complex scalar - cbuffer = cmplx(0, 0, sp) - print "(A,I2.2,A,2F10.6)", "CHK10:", mycomm%rank, ":", cbuffer - if (mycomm%lead) then - cbuffer = cmplx(-1, 1, sp) - end if - print "(A,I2.2,A,2F10.6)", "CHK11:", mycomm%rank, ":", cbuffer - call mpifx_bcast(mycomm, cbuffer) - print "(A,I2.2,A,2F10.6)", "CHK12:", mycomm%rank, ":", cbuffer - - ! Character - text = " " - print "(A,I2.2,A,A6)", "CHK13:", mycomm%rank, ":", text - if (mycomm%lead) then - text = "hello" - end if - print "(A,I2.2,A,A6)", "CHK14:", mycomm%rank, ":", text - call mpifx_bcast(mycomm, text) - print "(A,I2.2,A,A6)", "CHK15:", mycomm%rank, ":", text - - call mpifx_finalize() - -end program test_bcast diff --git a/test/unit/CMakeLists.txt b/test/unit/CMakeLists.txt new file mode 100644 index 0000000..5357b55 --- /dev/null +++ b/test/unit/CMakeLists.txt @@ -0,0 +1,34 @@ +set(fypp_flags ${FYPP_FLAGS}) +get_target_property( + _fortuno_mpi_incdir + Fortuno::fortuno_mpi_include_dir + INTERFACE_INCLUDE_DIRECTORIES +) +list(APPEND fypp_flags "-I${_fortuno_mpi_incdir}" "-I${CMAKE_SOURCE_DIR}/src/dftbp/include") + +set(unit-test-prefix "unit") + +set( + sources-f90 + testapp.f90 +) +set( + sources-fypp + test_bcast.fpp +) +fypp_preprocess("${fypp_flags}" "${sources-fypp}" sources-fypp-f90) + +set(testapp "testapp") +add_executable(${testapp}) +target_sources(${testapp} PRIVATE ${sources-f90} ${sources-fypp-f90}) +target_link_libraries(${testapp} mpifx Fortuno::fortuno_mpi) +add_test( + NAME ${unit-test-prefix} + COMMAND + ${MPIEXEC_EXECUTABLE} + ${MPIEXEC_NUMPROC_FLAG} + ${MPIEXEC_MAX_NUMPROCS} + ${MPIEXEC_PREFLAGS} + ${CMAKE_CURRENT_BINARY_DIR}/${testapp} + ${MPIEXEC_POSTFLAGS} +) diff --git a/test/test_allgather.f90 b/test/unit/test_allgather.f90 similarity index 100% rename from test/test_allgather.f90 rename to test/unit/test_allgather.f90 diff --git a/test/test_allgatherv.f90 b/test/unit/test_allgatherv.f90 similarity index 100% rename from test/test_allgatherv.f90 rename to test/unit/test_allgatherv.f90 diff --git a/test/test_allreduce.f90 b/test/unit/test_allreduce.f90 similarity index 100% rename from test/test_allreduce.f90 rename to test/unit/test_allreduce.f90 diff --git a/test/unit/test_bcast.fpp b/test/unit/test_bcast.fpp new file mode 100644 index 0000000..16540d5 --- /dev/null +++ b/test/unit/test_bcast.fpp @@ -0,0 +1,111 @@ +#:include "fortuno_mpi.fypp" + +module test_bcast + use libmpifx_module, only : mpifx_comm, mpifx_barrier, mpifx_bcast + use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_item, this_rank + $:FORTUNO_MPI_IMPORTS() + implicit none + + private + public :: bcast_test_items + + integer, parameter :: dp = kind(1.0d0) + +contains + + + ! GIVEN zero initialized buffer on all ranks + ! WHEN lead node broadcasts a rank one array of integers + ! THEN buffer on all ranks contains that message + $:TEST("integer_r1") + integer, parameter :: msg(3) = [1, 2, 3] + type(mpifx_comm) :: mycomm + integer :: buffer(size(msg)) + + call mycomm%init(global_comm_id()) + buffer(:) = 0 + if (mycomm%lead) buffer(:) = msg + call mpifx_bcast(mycomm, buffer) + @:ASSERT(all(buffer == msg)) + $:END_TEST() + + + ! GIVEN zero initialized buffer on all ranks + ! WHEN lead node broadcasts a rank one array of logicals + ! THEN buffer on all ranks contains that message + $:TEST("logical_r1") + logical, parameter :: msg(3) = [.true., .false., .true.] + type(mpifx_comm) :: mycomm + logical :: buffer(size(msg)) + + call mycomm%init(global_comm_id()) + buffer(:) = .false. + if (mycomm%lead) buffer(:) = msg + call mpifx_bcast(mycomm, buffer) + @:ASSERT(all(buffer .eqv. msg)) + $:END_TEST() + + + ! GIVEN zero initialized buffer on all ranks + ! WHEN lead node broadcasts a rank two array of reals + ! THEN buffer on all ranks contains that message + $:TEST("real_r2") + real(dp), parameter :: msg(2, 2) = reshape([1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp], [2, 2]) + real(dp), parameter :: tol = 10.0_dp * epsilon(1.0_dp) + type(mpifx_comm) :: mycomm + real(dp) :: buffer(size(msg, dim=1), size(msg, dim=2)) + + call mycomm%init(global_comm_id()) + buffer(:,:) = 0.0_dp + if (mycomm%lead) buffer(:,:) = msg + call mpifx_bcast(mycomm, buffer) + @:ASSERT(all(abs(buffer - msg) < tol)) + $:END_TEST() + + + ! GIVEN zero initialized buffer on all ranks + ! WHEN lead node broadcasts a complex scalar + ! THEN buffer on all ranks contains that message + $:TEST("complex_r0") + complex(dp), parameter :: msg = (-1.0_dp, 1.0_dp) + real(dp), parameter :: tol = 10.0_dp * epsilon(1.0_dp) + type(mpifx_comm) :: mycomm + complex(dp) :: buffer + + call mycomm%init(global_comm_id()) + buffer = (0.0_dp, 0.0_dp) + if (mycomm%lead) buffer = msg + call mpifx_bcast(mycomm, buffer) + @:ASSERT(abs(buffer - msg) < tol) + $:END_TEST() + + + ! GIVEN zero initialized buffer on all ranks + ! WHEN lead node broadcasts a character string + ! THEN buffer on all ranks contains that message + $:TEST("character_string") + character(5), parameter :: msg = "hello" + type(mpifx_comm) :: mycomm + character(len(msg)) :: buffer + + call mycomm%init(global_comm_id()) + buffer = repeat(" ", len(buffer)) + if (mycomm%lead) buffer = msg + call mpifx_bcast(mycomm, buffer) + @:ASSERT(buffer == msg) + $:END_TEST() + + + function bcast_test_items() result(testitems) + type(test_item), allocatable :: testitems(:) + + testitems = [& + suite("bcast", [& + $:TEST_ITEMS() + ])& + ] + @:STOP_ON_MISSING_TEST_ITEMS() + + end function bcast_test_items + +end module test_bcast diff --git a/test/test_comm_split.f90 b/test/unit/test_comm_split.f90 similarity index 100% rename from test/test_comm_split.f90 rename to test/unit/test_comm_split.f90 diff --git a/test/test_comm_split_type.f90 b/test/unit/test_comm_split_type.f90 similarity index 100% rename from test/test_comm_split_type.f90 rename to test/unit/test_comm_split_type.f90 diff --git a/test/test_gather.f90 b/test/unit/test_gather.f90 similarity index 100% rename from test/test_gather.f90 rename to test/unit/test_gather.f90 diff --git a/test/test_gatherv.f90 b/test/unit/test_gatherv.f90 similarity index 100% rename from test/test_gatherv.f90 rename to test/unit/test_gatherv.f90 diff --git a/test/test_reduce.f90 b/test/unit/test_reduce.f90 similarity index 100% rename from test/test_reduce.f90 rename to test/unit/test_reduce.f90 diff --git a/test/test_scatter.f90 b/test/unit/test_scatter.f90 similarity index 100% rename from test/test_scatter.f90 rename to test/unit/test_scatter.f90 diff --git a/test/test_scatterv.f90 b/test/unit/test_scatterv.f90 similarity index 100% rename from test/test_scatterv.f90 rename to test/unit/test_scatterv.f90 diff --git a/test/test_send_recv.f90 b/test/unit/test_send_recv.f90 similarity index 100% rename from test/test_send_recv.f90 rename to test/unit/test_send_recv.f90 diff --git a/test/test_win_shared_mem.f90 b/test/unit/test_win_shared_mem.f90 similarity index 100% rename from test/test_win_shared_mem.f90 rename to test/unit/test_win_shared_mem.f90 diff --git a/test/unit/testapp.f90 b/test/unit/testapp.f90 new file mode 100644 index 0000000..11e316e --- /dev/null +++ b/test/unit/testapp.f90 @@ -0,0 +1,12 @@ +program testapp + use fortuno_mpi, only : execute_mpi_cmd_app + use test_bcast, only : bcast_test_items + implicit none + + call execute_mpi_cmd_app(& + testitems=[& + bcast_test_items()& + ]& + ) + +end program testapp diff --git a/test/testhelper.f90 b/test/unit/testhelper.f90 similarity index 100% rename from test/testhelper.f90 rename to test/unit/testhelper.f90 From c9ba72b083eae6de8c461ba3a9081a70b673ae5c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Sat, 28 Sep 2024 14:21:55 +0200 Subject: [PATCH 2/4] Update to extended testlist interface from Fortuno --- CMakeLists.txt | 1 - subprojects/Fortuno.cmake | 1 + subprojects/FortunoMpi.cmake | 24 ------------------------ test/unit/CMakeLists.txt | 2 +- test/unit/test_bcast.fpp | 19 ++++++++----------- test/unit/testapp.f90 | 12 +++++------- 6 files changed, 15 insertions(+), 44 deletions(-) delete mode 100644 subprojects/FortunoMpi.cmake diff --git a/CMakeLists.txt b/CMakeLists.txt index 7906813..f835aa7 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -37,7 +37,6 @@ include(CTest) # note: this adds a BUILD_TESTING which defaults to ON if(BUILD_TESTING) include(FetchContent) include(subprojects/Fortuno.cmake) - include(subprojects/FortunoMpi.cmake) enable_testing() add_subdirectory(test) endif() diff --git a/subprojects/Fortuno.cmake b/subprojects/Fortuno.cmake index b947aef..4769478 100644 --- a/subprojects/Fortuno.cmake +++ b/subprojects/Fortuno.cmake @@ -7,6 +7,7 @@ set(CMAKE_DISABLE_FIND_PACKAGE_Fortuno ${MYPROJECT_SUBPROJECT_DISABLE_FIND}) option( FORTUNO_BUILD_SHARED_LIBS "Fortuno: Build as shared library" ${MYPROJECT_BUILD_SHARED_LIBS} ) +option(FORTUNO_WITH_MPI "Fortuno: Whether mpi interface should be built" ON) # Make subproject available FetchContent_Declare( diff --git a/subprojects/FortunoMpi.cmake b/subprojects/FortunoMpi.cmake deleted file mode 100644 index 13441d0..0000000 --- a/subprojects/FortunoMpi.cmake +++ /dev/null @@ -1,24 +0,0 @@ -# Variables influencing how subproject is obtained -set(CMAKE_REQUIRE_FIND_PACKAGE_FortunoMpi ${MYPROJECT_SUBPROJECT_REQUIRE_FIND}) -set(CMAKE_DISABLE_FIND_PACKAGE_FortunoMpi ${MYPROJECT_SUBPROJECT_DISABLE_FIND}) -# set FETCHCONTENT_SOURCE_DIR_FORTUNO to use a local source of the subproject - -# Subproject related variables -option( - FORTUNO_MPI_BUILD_SHARED_LIBS "Fortuno: Build as shared library" ${MYPROJECT_BUILD_SHARED_LIBS} -) - -# Make subproject available -FetchContent_Declare( - FortunoMpi - GIT_REPOSITORY "https://github.com/aradi/fortuno-mpi.git" - GIT_TAG "fypp" - FIND_PACKAGE_ARGS -) -FetchContent_MakeAvailable(FortunoMpi) - -if (FortunoMpi_FOUND) - message(STATUS "Subproject FortunoMpi: using installed version") -else () - message(STATUS "Subproject FortunoMpi: building from source in ${fortunompi_SOURCE_DIR}") -endif () diff --git a/test/unit/CMakeLists.txt b/test/unit/CMakeLists.txt index 5357b55..abd4495 100644 --- a/test/unit/CMakeLists.txt +++ b/test/unit/CMakeLists.txt @@ -1,7 +1,7 @@ set(fypp_flags ${FYPP_FLAGS}) get_target_property( _fortuno_mpi_incdir - Fortuno::fortuno_mpi_include_dir + Fortuno::fortuno_include_dir INTERFACE_INCLUDE_DIRECTORIES ) list(APPEND fypp_flags "-I${_fortuno_mpi_incdir}" "-I${CMAKE_SOURCE_DIR}/src/dftbp/include") diff --git a/test/unit/test_bcast.fpp b/test/unit/test_bcast.fpp index 16540d5..61e0503 100644 --- a/test/unit/test_bcast.fpp +++ b/test/unit/test_bcast.fpp @@ -2,13 +2,10 @@ module test_bcast use libmpifx_module, only : mpifx_comm, mpifx_barrier, mpifx_bcast - use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_item, this_rank + use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, this_rank $:FORTUNO_MPI_IMPORTS() implicit none - private - public :: bcast_test_items - integer, parameter :: dp = kind(1.0d0) contains @@ -96,16 +93,16 @@ contains $:END_TEST() - function bcast_test_items() result(testitems) - type(test_item), allocatable :: testitems(:) + function tests() + type(test_list) :: tests - testitems = [& - suite("bcast", [& + tests = test_list([& + suite("bcast", test_list([& $:TEST_ITEMS() - ])& - ] + ]))& + ]) @:STOP_ON_MISSING_TEST_ITEMS() - end function bcast_test_items + end function tests end module test_bcast diff --git a/test/unit/testapp.f90 b/test/unit/testapp.f90 index 11e316e..312a366 100644 --- a/test/unit/testapp.f90 +++ b/test/unit/testapp.f90 @@ -1,12 +1,10 @@ program testapp - use fortuno_mpi, only : execute_mpi_cmd_app - use test_bcast, only : bcast_test_items + use fortuno_mpi, only : execute_mpi_cmd_app, test_list + use test_bcast, only : bcast_tests => tests implicit none - call execute_mpi_cmd_app(& - testitems=[& - bcast_test_items()& - ]& - ) + call execute_mpi_cmd_app(test_list([& + bcast_tests()& + ])) end program testapp From b3086e7176f3fa7663dd9cae5ff2d83c88356d7f Mon Sep 17 00:00:00 2001 From: Justin Bich Date: Fri, 6 Sep 2024 11:34:15 +0200 Subject: [PATCH 3/4] Convert remaining tests to Fortuno --- test/unit/CMakeLists.txt | 13 ++- test/unit/test_allgather.f90 | 69 --------------- test/unit/test_allgather.fpp | 65 ++++++++++++++ test/unit/test_allgatherv.f90 | 116 ------------------------- test/unit/test_allgatherv.fpp | 98 +++++++++++++++++++++ test/unit/test_allreduce.f90 | 42 --------- test/unit/test_allreduce.fpp | 79 +++++++++++++++++ test/unit/test_comm_split.f90 | 17 ---- test/unit/test_comm_split.fpp | 41 +++++++++ test/unit/test_comm_split_type.f90 | 13 --- test/unit/test_comm_split_type.fpp | 33 ++++++++ test/unit/test_gather.f90 | 72 ---------------- test/unit/test_gather.fpp | 88 +++++++++++++++++++ test/unit/test_gatherv.f90 | 127 ---------------------------- test/unit/test_gatherv.fpp | 131 +++++++++++++++++++++++++++++ test/unit/test_reduce.f90 | 43 ---------- test/unit/test_reduce.fpp | 95 +++++++++++++++++++++ test/unit/test_scatter.f90 | 66 --------------- test/unit/test_scatter.fpp | 79 +++++++++++++++++ test/unit/test_scatterv.f90 | 85 ------------------- test/unit/test_scatterv.fpp | 113 +++++++++++++++++++++++++ test/unit/test_send_recv.f90 | 23 ----- test/unit/test_send_recv.fpp | 70 +++++++++++++++ test/unit/testapp.f90 | 30 ++++++- 24 files changed, 931 insertions(+), 677 deletions(-) delete mode 100644 test/unit/test_allgather.f90 create mode 100644 test/unit/test_allgather.fpp delete mode 100644 test/unit/test_allgatherv.f90 create mode 100644 test/unit/test_allgatherv.fpp delete mode 100644 test/unit/test_allreduce.f90 create mode 100644 test/unit/test_allreduce.fpp delete mode 100644 test/unit/test_comm_split.f90 create mode 100644 test/unit/test_comm_split.fpp delete mode 100644 test/unit/test_comm_split_type.f90 create mode 100644 test/unit/test_comm_split_type.fpp delete mode 100644 test/unit/test_gather.f90 create mode 100644 test/unit/test_gather.fpp delete mode 100644 test/unit/test_gatherv.f90 create mode 100644 test/unit/test_gatherv.fpp delete mode 100644 test/unit/test_reduce.f90 create mode 100644 test/unit/test_reduce.fpp delete mode 100644 test/unit/test_scatter.f90 create mode 100644 test/unit/test_scatter.fpp delete mode 100644 test/unit/test_scatterv.f90 create mode 100644 test/unit/test_scatterv.fpp delete mode 100644 test/unit/test_send_recv.f90 create mode 100644 test/unit/test_send_recv.fpp diff --git a/test/unit/CMakeLists.txt b/test/unit/CMakeLists.txt index abd4495..57da1be 100644 --- a/test/unit/CMakeLists.txt +++ b/test/unit/CMakeLists.txt @@ -14,14 +14,25 @@ set( ) set( sources-fypp + test_allgather.fpp + test_allgatherv.fpp + test_allreduce.fpp test_bcast.fpp + test_comm_split_type.fpp + test_comm_split.fpp + test_gather.fpp + test_gatherv.fpp + test_reduce.fpp + test_scatter.fpp + test_scatterv.fpp + test_send_recv.fpp ) fypp_preprocess("${fypp_flags}" "${sources-fypp}" sources-fypp-f90) set(testapp "testapp") add_executable(${testapp}) target_sources(${testapp} PRIVATE ${sources-f90} ${sources-fypp-f90}) -target_link_libraries(${testapp} mpifx Fortuno::fortuno_mpi) +target_link_libraries(${testapp} mpifx Fortuno::fortuno_mpi MPI::MPI_Fortran) add_test( NAME ${unit-test-prefix} COMMAND diff --git a/test/unit/test_allgather.f90 b/test/unit/test_allgather.f90 deleted file mode 100644 index fdd494c..0000000 --- a/test/unit/test_allgather.f90 +++ /dev/null @@ -1,69 +0,0 @@ -!> Test various patterns of allgather -program test_allgather - use libmpifx_module - use testhelper - implicit none - - type(mpifx_comm) :: mycomm - integer :: send0 - integer, allocatable :: send1(:) - integer, allocatable :: recv1(:), recv2(:,:) - character(100) :: formstr - character(*), parameter :: label = "(I2.2,'-',I3.3,'|',1X" - logical :: isPassed - - call mpifx_init() - call mycomm%init() - - ! I0 -> I1 - send0 = mycomm%rank * 2 - allocate(recv1(1 * mycomm%size)) - recv1(:) = 0 - write(*, label // ",A,1X,I0)") 1, mycomm%rank, "Send0 buffer:", send0 - call mpifx_allgather(mycomm, send0, recv1) - write(formstr, "(A,I0,A)") "A,", size(recv1), "(1X,I0))" - write(*, label // formstr) 2, mycomm%rank, "Recv1 buffer:", recv1(:) - if (sum(recv1) /= mycomm%size * (mycomm%size-1)) then - isPassed = .false. - else - isPassed = .true. - end if - call testReturn(mycomm, isPassed) - deallocate(recv1) - - ! I1 -> I1 - allocate(send1(2)) - allocate(recv1(size(send1) * mycomm%size)) - recv1(:) = 0 - send1(:) = [ mycomm%rank, mycomm%rank + 1 ] - write(formstr, "(A,I0,A)") "A,", size(send1), "(1X,I0))" - write(*, label // formstr) 3, mycomm%rank, "Send1 buffer:", send1(:) - call mpifx_allgather(mycomm, send1, recv1) - write(formstr, "(A,I0,A)") "A,", size(recv1), "(1X,I0))" - write(*, label // formstr) 4, mycomm%rank, "Recv1 buffer:", recv1 - if (sum(recv1) /= mycomm%size**2) then - isPassed = .false. - else - isPassed = .true. - end if - call testReturn(mycomm, isPassed) - - ! I1 -> I2 - allocate(recv2(size(send1), mycomm%size)) - recv2(:,:) = 0 - send1(:) = [ mycomm%rank, mycomm%rank + 1 ] - write(formstr, "(A,I0,A)") "A,", size(send1), "(1X,I0))" - write(*, label // formstr) 5, mycomm%rank, "Send1 buffer:", send1(:) - call mpifx_allgather(mycomm, send1, recv2) - write(formstr, "(A,I0,A)") "A,", size(recv2), "(1X,I0))" - write(*, label // formstr) 6, mycomm%rank, "Recv2 buffer:", recv2 - if (sum(recv1) /= mycomm%size**2) then - isPassed = .false. - else - isPassed = .true. - end if - call testReturn(mycomm, isPassed) - - call mpifx_finalize() - -end program test_allgather diff --git a/test/unit/test_allgather.fpp b/test/unit/test_allgather.fpp new file mode 100644 index 0000000..8d3e569 --- /dev/null +++ b/test/unit/test_allgather.fpp @@ -0,0 +1,65 @@ +!> Test various patterns of allgather +#:include "fortuno_mpi.fypp" + +module test_allgather + use libmpifx_module, only : mpifx_comm, mpifx_allgather + use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, is_equal + $:FORTUNO_MPI_IMPORTS() + implicit none + +contains + + $:TEST("I0_to_I1") + type(mpifx_comm) :: mycomm + integer :: send0 + integer, allocatable :: recv1(:) + + call mycomm%init(global_comm_id()) + send0 = mycomm%rank * 2 + allocate(recv1(1 * mycomm%size), source = 0) + call mpifx_allgather(mycomm, send0, recv1) + + @:ASSERT(is_equal(sum(recv1), mycomm%size * (mycomm%size-1))) + $:END_TEST() + + $:TEST("I1_to_I1") + type(mpifx_comm) :: mycomm + integer, allocatable :: send1(:) + integer, allocatable :: recv1(:) + + call mycomm%init(global_comm_id()) + allocate(send1(2), source = 0) + allocate(recv1(size(send1) * mycomm%size), source = 0) + send1(:) = [ mycomm%rank, mycomm%rank + 1 ] + call mpifx_allgather(mycomm, send1, recv1) + + @:ASSERT(is_equal(sum(recv1), mycomm%size**2)) + $:END_TEST() + + $:TEST("I1_to_I2") + type(mpifx_comm) :: mycomm + integer, allocatable :: send1(:) + integer, allocatable :: recv2(:,:) + + call mycomm%init(global_comm_id()) + allocate(send1(2), source = 0) + allocate(recv2(size(send1), mycomm%size), source = 0) + send1(:) = [ mycomm%rank, mycomm%rank + 1 ] + call mpifx_allgather(mycomm, send1, recv2) + + @:ASSERT(is_equal(sum(recv2), mycomm%size**2)) + $:END_TEST() + + function tests() + type(test_list) :: tests + + tests = test_list([& + suite("allgather", test_list([& + $:TEST_ITEMS() + ]))& + ]) + @:STOP_ON_MISSING_TEST_ITEMS() + + end function tests + +end module test_allgather diff --git a/test/unit/test_allgatherv.f90 b/test/unit/test_allgatherv.f90 deleted file mode 100644 index ae46762..0000000 --- a/test/unit/test_allgatherv.f90 +++ /dev/null @@ -1,116 +0,0 @@ -!> Test various patterns of allgatherv -program test_allgatherv - use libmpifx_module - use testhelper - implicit none - - type(mpifx_comm) :: mycomm - integer, parameter :: sp = kind(1.0) - real(sp), allocatable :: send1(:), send2(:,:) - real(sp), allocatable :: recv1(:), recv2(:,:) - real(sp) :: send0 - integer, allocatable :: recvcounts(:) - integer, allocatable :: displs(:) - integer :: ii, nrecv, nCol - character(100) :: formstr - character(*), parameter :: label = "(I2.2,'-',I3.3,'|',1X" - logical :: tPassed - integer :: iCount - - call mpifx_init() - call mycomm%init() - - ! R1 -> R1 - if (mycomm%rank == mycomm%size - 1) then - write(*, *) 'Test gather rank=1 -> rank=1' - end if - allocate(send1(mycomm%rank+1)) - send1 = real(mycomm%rank+1, sp) - ! recv1 size is 1+2+3+...+mycomm%size - nrecv = mycomm%size*(mycomm%size+1)/2 - allocate(recv1(nrecv)) - allocate(recvcounts(mycomm%size)) - do ii = 1, mycomm%size - recvcounts(ii) = ii - end do - call mpifx_allgatherv(mycomm, send1, recv1, recvcounts) - if (mycomm%rank == mycomm%size - 1) then - write(*, *) "Recv1 buffer:", recv1 - end if - ! test what has been gathered - iCount = (2*mycomm%size**3+3*mycomm%size**2+mycomm%size)/6 - if (nint(sum(recv1)) /= iCount) then - tPassed = .false. - else - tPassed = .true. - end if - tPassed = tPassed .and. (abs(sum(recv1)-nint(sum(recv1))) < epsilon(1.0_sp)) - call testReturn(mycomm, tPassed) - deallocate(recvcounts) - deallocate(recv1) - - ! R2 -> R2 - if (mycomm%rank == mycomm%size - 1) then - write(*, *) - write(*, *) 'Test gather rank=2 -> rank=2' - end if - nCol = 5 - allocate(send2(nCol, mycomm%rank+1)) - send2 = real(mycomm%rank + 1, sp) - ! recv1 size is 1+2+3+...+mycomm%size - nrecv = mycomm%size*(mycomm%size+1)/2 - allocate(recv2(nCol, nrecv)) - recv2 = 0 - allocate(recvcounts(mycomm%size)) - do ii = 1, mycomm%size - recvcounts(ii) = nCol*ii - end do - call mpifx_allgatherv(mycomm, send2, recv2, recvcounts) - if (mycomm%rank == mycomm%size - 1) then - write(*, *) "Recv2 buffer:", shape(recv2) - do ii = 1, nrecv - write(*,*)recv2(:,ii) - end do - end if - iCount = 5*mycomm%size*(mycomm%size+1)*(2*mycomm%size+1)/6 - if (nint(sum(recv2)) /= iCount) then - tPassed = .false. - else - tPassed = .true. - end if - tPassed = tPassed .and. (abs(sum(recv2)-nint(sum(recv2))) < epsilon(1.0_sp)) - call testReturn(mycomm, tPassed) - deallocate(recvcounts) - - - ! R0 -> R1 with specified receive pattern - if (mycomm%rank == mycomm%size - 1) then - write(*, *) - write(*, *) 'Test gather scalar -> rank=1' - end if - send0 = real(mycomm%rank + 1, sp) - nrecv = mycomm%size - allocate(recv1(nrecv)) - allocate(recvcounts(mycomm%size)) - recvcounts = 1 - allocate(displs(mycomm%size)) - ! set a non trivial displs vector - do ii = 1, mycomm%size - displs(ii) = mycomm%size - ii - end do - call mpifx_allgatherv(mycomm, send0, recv1, recvcounts, displs) - if (mycomm%rank == mycomm%size - 1) then - write(*, *) "Recv1 buffer:", recv1 - end if - ! test what has been gathered - if (nint(sum(recv1)) /= (mycomm%size*(mycomm%size+1))/2) then - tPassed = .false. - else - tPassed = .true. - end if - tPassed = tPassed .and. (abs(sum(recv1)-nint(sum(recv1))) < epsilon(1.0_sp)) - call testReturn(mycomm, tPassed) - - call mpifx_finalize() - -end program test_allgatherv diff --git a/test/unit/test_allgatherv.fpp b/test/unit/test_allgatherv.fpp new file mode 100644 index 0000000..463ec20 --- /dev/null +++ b/test/unit/test_allgatherv.fpp @@ -0,0 +1,98 @@ +!> Test various patterns of allgatherv +#:include "fortuno_mpi.fypp" + +module test_allgatherv + use libmpifx_module, only : mpifx_comm, mpifx_allgatherv + use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, is_equal + $:FORTUNO_MPI_IMPORTS() + implicit none + +contains + + $:TEST("R1_to_R1") + type(mpifx_comm) :: mycomm + integer, parameter :: sp = kind(1.0) + real(sp), allocatable :: send1(:) + real(sp), allocatable :: recv1(:) + integer, allocatable :: recvcounts(:) + integer :: ii, nrecv + + call mycomm%init(global_comm_id()) + allocate(send1(mycomm%rank+1), source = 0.0_sp) + send1 = real(mycomm%rank+1, sp) + ! recv1 size is 1+2+3+...+mycomm%size + nrecv = mycomm%size*(mycomm%size+1)/2 + allocate(recv1(nrecv), source = 0.0_sp) + allocate(recvcounts(mycomm%size), source = 0) + do ii = 1, mycomm%size + recvcounts(ii) = ii + end do + call mpifx_allgatherv(mycomm, send1, recv1, recvcounts) + + @:ASSERT(is_equal(nint(sum(recv1)), (2*mycomm%size**3+3*mycomm%size**2+mycomm%size)/6)) + @:ASSERT((abs(sum(recv1)-nint(sum(recv1))) < epsilon(1.0_sp))) + $:END_TEST() + + $:TEST("R2_to_R2") + type(mpifx_comm) :: mycomm + integer, parameter :: sp = kind(1.0) + real(sp), allocatable :: send2(:,:) + real(sp), allocatable :: recv2(:,:) + integer, allocatable :: recvcounts(:) + integer :: ii, nrecv, nCol + + call mycomm%init(global_comm_id()) + nCol = 5 + allocate(send2(nCol, mycomm%rank+1), source = 0.0_sp) + send2 = real(mycomm%rank + 1, sp) + nrecv = mycomm%size*(mycomm%size+1)/2 + allocate(recv2(nCol, nrecv), source = 0.0_sp) + allocate(recvcounts(mycomm%size), source = 0) + do ii = 1, mycomm%size + recvcounts(ii) = nCol*ii + end do + call mpifx_allgatherv(mycomm, send2, recv2, recvcounts) + + @:ASSERT(is_equal(nint(sum(recv2)), nCol*mycomm%size*(mycomm%size+1)*(2*mycomm%size+1)/6)) + @:ASSERT((abs(sum(recv2)-nint(sum(recv2))) < epsilon(1.0_sp))) + $:END_TEST() + + $:TEST("R0_to_R1") + ! R0 -> R1 with specified receive pattern + type(mpifx_comm) :: mycomm + integer, parameter :: sp = kind(1.0) + real(sp), allocatable :: recv1(:) + real(sp) :: send0 + integer, allocatable :: recvcounts(:) + integer, allocatable :: displs(:) + integer :: ii, nrecv + + call mycomm%init(global_comm_id()) + send0 = real(mycomm%rank + 1, sp) + nrecv = mycomm%size + allocate(recv1(nrecv), source = 0.0_sp) + allocate(recvcounts(mycomm%size), source = 1) + allocate(displs(mycomm%size), source = 0) + ! set a non trivial displs vector + do ii = 1, mycomm%size + displs(ii) = mycomm%size - ii + end do + call mpifx_allgatherv(mycomm, send0, recv1, recvcounts, displs) + + @:ASSERT(is_equal(nint(sum(recv1)), (mycomm%size*(mycomm%size+1))/2)) + @:ASSERT((abs(sum(recv1)-nint(sum(recv1))) < epsilon(1.0_sp))) + $:END_TEST() + + function tests() + type(test_list) :: tests + + tests = test_list([& + suite("allgatherv", test_list([& + $:TEST_ITEMS() + ]))& + ]) + @:STOP_ON_MISSING_TEST_ITEMS() + + end function tests + +end module test_allgatherv diff --git a/test/unit/test_allreduce.f90 b/test/unit/test_allreduce.f90 deleted file mode 100644 index cfb9df8..0000000 --- a/test/unit/test_allreduce.f90 +++ /dev/null @@ -1,42 +0,0 @@ -program test_allreduce - use libmpifx_module - implicit none - - integer, parameter :: dp = kind(1.0d0) - - type(mpifx_comm) :: mycomm - integer :: vali0, resvali0 - real(dp) :: valr(3), resvalr(3) - - call mpifx_init() - call mycomm%init() - - ! Reduction of a scalar - vali0 = mycomm%rank * 2 - write(*, "(I2.2,'-',I3.3,'|',1X,A,I0)") 1, mycomm%rank, & - & "Value to be operated on:", vali0 - call mpifx_allreduce(mycomm, vali0, resvali0, MPI_SUM) - write(*, "(I2.2,'-',I3.3,'|',1X,A,I0)") 2, mycomm%rank, & - & "Obtained result (sum):", resvali0 - - ! Reduction of an array - valr(:) = [ real(mycomm%rank + 1, dp) * 1.2, & - & real(mycomm%rank + 1, dp) * 4.3, real(mycomm%rank + 1, dp) * 3.8 ] - write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 3, mycomm%rank, & - & "Value to be operated on:", valr(:) - call mpifx_allreduce(mycomm, valr, resvalr, MPI_PROD) - write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 4, mycomm%rank, & - & "Obtained result (prod):", resvalr(:) - - ! In place summation - resvalr(:) = [ real(mycomm%rank + 1, dp) * 1.2, & - & real(mycomm%rank + 1, dp) * 4.3, real(mycomm%rank + 1, dp) * 3.8 ] - write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 5, mycomm%rank, & - & "Value to be operated on:", resvalr(:) - call mpifx_allreduceip(mycomm, resvalr, MPI_SUM) - write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 6, mycomm%rank, & - & "Obtained result (sum):", resvalr(:) - - call mpifx_finalize() - -end program test_allreduce diff --git a/test/unit/test_allreduce.fpp b/test/unit/test_allreduce.fpp new file mode 100644 index 0000000..c2b8d40 --- /dev/null +++ b/test/unit/test_allreduce.fpp @@ -0,0 +1,79 @@ +#:include "fortuno_mpi.fypp" + +module test_allreduce + use mpi, only : MPI_SUM, MPI_PROD + use libmpifx_module, only : mpifx_comm, mpifx_allreduce, mpifx_allreduceip + use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, is_equal + $:FORTUNO_MPI_IMPORTS() + implicit none + +contains + + $:TEST("scalar_sum") + type(mpifx_comm) :: mycomm + integer :: vali0, resvali0 + + call mycomm%init(global_comm_id()) + vali0 = mycomm%rank * 2 + call mpifx_allreduce(mycomm, vali0, resvali0, MPI_SUM) + + @:ASSERT(is_equal(resvali0, mycomm%size * (mycomm%size-1))) + $:END_TEST() + + $:TEST("array_prod") + integer, parameter :: dp = kind(1.0d0) + type(mpifx_comm) :: mycomm + real(dp) :: valr(3), resvalr(3) + integer :: max_none_one_rank, max_valid_rank + + max_valid_rank = 9 + call mycomm%init(global_comm_id()) + + if (mycomm%rank <= max_valid_rank) then + valr(:) = [ real(mycomm%rank + 1, dp) * 1.2, & + & real(mycomm%rank + 1, dp) * 4.3, real(mycomm%rank + 1, dp) * 3.8 ] + else + ! prevents the product from getting to large + valr(:) = [ real(1, dp), real(1, dp), real(1, dp) ] + end if + call mpifx_allreduce(mycomm, valr, resvalr, MPI_PROD) + + if (mycomm%size <= max_valid_rank + 1) then + max_none_one_rank = mycomm%size + else + max_none_one_rank = max_valid_rank + 1 + end if + + @:ASSERT(abs(resvalr(1) - (gamma(real(max_none_one_rank + 1, kind=dp)) * (1.2)**(max_none_one_rank))) < abs((resvalr(1)*1e-6))) + @:ASSERT(abs(resvalr(2) - (gamma(real(max_none_one_rank + 1, kind=dp)) * (4.3)**(max_none_one_rank))) < abs((resvalr(2)*1e-6))) + @:ASSERT(abs(resvalr(3) - (gamma(real(max_none_one_rank + 1, kind=dp)) * (3.8)**(max_none_one_rank))) < abs((resvalr(3)*1e-6))) + $:END_TEST() + + $:TEST("ip_sum") + integer, parameter :: dp = kind(1.0d0) + type(mpifx_comm) :: mycomm + real(dp) :: resvalr(3) + + call mycomm%init(global_comm_id()) + resvalr(:) = [ real(mycomm%rank + 1, dp) * 1.2, & + & real(mycomm%rank + 1, dp) * 4.3, real(mycomm%rank + 1, dp) * 3.8 ] + call mpifx_allreduceip(mycomm, resvalr, MPI_SUM) + + @:ASSERT(abs(resvalr(1) - (mycomm%size * (mycomm%size + 1)) / 2 * 1.2) < abs((resvalr(1)*1e-7))) + @:ASSERT(abs(resvalr(2) - (mycomm%size * (mycomm%size + 1)) / 2 * 4.3) < abs((resvalr(2)*1e-7))) + @:ASSERT(abs(resvalr(3) - (mycomm%size * (mycomm%size + 1)) / 2 * 3.8) < abs((resvalr(3)*1e-7))) + $:END_TEST() + + function tests() + type(test_list) :: tests + + tests = test_list([& + suite("allreduce", test_list([& + $:TEST_ITEMS() + ]))& + ]) + @:STOP_ON_MISSING_TEST_ITEMS() + + end function tests + +end module test_allreduce diff --git a/test/unit/test_comm_split.f90 b/test/unit/test_comm_split.f90 deleted file mode 100644 index c4ff878..0000000 --- a/test/unit/test_comm_split.f90 +++ /dev/null @@ -1,17 +0,0 @@ -program test_comm_split - use libmpifx_module - implicit none - - type(mpifx_comm) :: allproc, groupproc - integer :: groupsize, mygroup - - call mpifx_init() - call allproc%init() - groupsize = allproc%size / 2 - mygroup = allproc%rank / groupsize - call allproc%split(mygroup, allproc%rank, groupproc) - write(*, "(3(A,1X,I0,1X))") "GLOBAL ID:", allproc%rank, "SUBGROUP", & - & mygroup, "SUBGROUP ID", groupproc%rank - call mpifx_finalize() - -end program test_comm_split diff --git a/test/unit/test_comm_split.fpp b/test/unit/test_comm_split.fpp new file mode 100644 index 0000000..ce2e322 --- /dev/null +++ b/test/unit/test_comm_split.fpp @@ -0,0 +1,41 @@ +#:include "fortuno_mpi.fypp" + +module test_comm_split + use libmpifx_module, only : mpifx_comm + use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, is_equal + $:FORTUNO_MPI_IMPORTS() + implicit none + +contains + + $:TEST("split_group") + type(mpifx_comm) :: allproc, groupproc + integer :: groupsize, mygroup + + call allproc%init(global_comm_id()) + groupsize = nint(real(allproc%size / 2)) + mygroup = allproc%rank / groupsize + call allproc%split(mygroup, allproc%rank, groupproc) + + if (allproc%rank < groupsize) then + @:ASSERT(is_equal(mygroup, 0)) + @:ASSERT(is_equal(allproc%rank, groupproc%rank)) + else + @:ASSERT(is_equal(mygroup, 1)) + @:ASSERT(is_equal(allproc%rank, groupproc%rank + groupsize)) + end if + $:END_TEST() + + function tests() + type(test_list) :: tests + + tests = test_list([& + suite("comm_split", test_list([& + $:TEST_ITEMS() + ]))& + ]) + @:STOP_ON_MISSING_TEST_ITEMS() + + end function tests + +end module test_comm_split diff --git a/test/unit/test_comm_split_type.f90 b/test/unit/test_comm_split_type.f90 deleted file mode 100644 index c40491c..0000000 --- a/test/unit/test_comm_split_type.f90 +++ /dev/null @@ -1,13 +0,0 @@ -program test_split_type - use libmpifx_module - implicit none - - type(mpifx_comm) :: allproc, splitproc - - call mpifx_init() - call allproc%init() - call allproc%split_type(MPI_COMM_TYPE_SHARED, allproc%rank, splitproc) - write(*, "(2(A,1X,I0,1X))") "ID:", allproc%rank, "SPLIT ID", splitproc%rank - call mpifx_finalize() - -end program test_split_type diff --git a/test/unit/test_comm_split_type.fpp b/test/unit/test_comm_split_type.fpp new file mode 100644 index 0000000..566ffbe --- /dev/null +++ b/test/unit/test_comm_split_type.fpp @@ -0,0 +1,33 @@ +#:include "fortuno_mpi.fypp" + +module test_comm_split_type + use mpi, only : MPI_COMM_TYPE_SHARED + use libmpifx_module, only : mpifx_comm + use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, is_equal + $:FORTUNO_MPI_IMPORTS() + implicit none + +contains + + $:TEST("split_shared") + type(mpifx_comm) :: allproc, splitproc + + call allproc%init(global_comm_id()) + call allproc%split_type(MPI_COMM_TYPE_SHARED, allproc%rank, splitproc) + + @:ASSERT(is_equal(allproc%rank, splitproc%rank)) + $:END_TEST() + + function tests() + type(test_list) :: tests + + tests = test_list([& + suite("comm_split_type", test_list([& + $:TEST_ITEMS() + ]))& + ]) + @:STOP_ON_MISSING_TEST_ITEMS() + + end function tests + +end module test_comm_split_type diff --git a/test/unit/test_gather.f90 b/test/unit/test_gather.f90 deleted file mode 100644 index 4badc84..0000000 --- a/test/unit/test_gather.f90 +++ /dev/null @@ -1,72 +0,0 @@ -program test_gather - use libmpifx_module - implicit none - - type(mpifx_comm) :: mycomm - integer :: send0 - integer, allocatable :: send1(:) - integer, allocatable :: recv1(:), recv2(:,:) - character(100) :: formstr - character(*), parameter :: label = "(I2.2,'-',I3.3,'|',1X" - - call mpifx_init() - call mycomm%init() - - ! I0 -> I1 - send0 = mycomm%rank * 2 ! Arbitrary number to send - if (mycomm%lead) then - allocate(recv1(1 * mycomm%size)) - recv1(:) = 0 - else - allocate(recv1(0)) - end if - write(*, label // ",A,1X,I0)") 1, mycomm%rank, & - & "Send0 buffer:", send0 - call mpifx_gather(mycomm, send0, recv1) - if (mycomm%lead) then - write(formstr, "(A,I0,A)") "A,", size(recv1), "(1X,I0))" - write(*, label // formstr) 2, mycomm%rank, & - & "Recv1 buffer:", recv1(:) - end if - deallocate(recv1) - - ! I1 -> I1 - allocate(send1(2)) - if (mycomm%lead) then - allocate(recv1(size(send1) * mycomm%size)) - recv1(:) = 0 - else - allocate(recv1(0)) - end if - send1(:) = [ mycomm%rank, mycomm%rank + 1 ] ! Arbitrary numbers to send - write(formstr, "(A,I0,A)") "A,", size(send1), "(1X,I0))" - write(*, label // formstr) 3, mycomm%rank, & - & "Send1 buffer:", send1(:) - call mpifx_gather(mycomm, send1, recv1) - if (mycomm%lead) then - write(formstr, "(A,I0,A)") "A,", size(recv1), "(1X,I0))" - write(*, label // formstr) 4, mycomm%rank, & - & "Recv1 buffer:", recv1 - end if - - ! I1 -> I2 - if (mycomm%lead) then - allocate(recv2(size(send1), mycomm%size)) - recv2(:,:) = 0 - else - allocate(recv2(0, 0)) - end if - send1(:) = [ mycomm%rank, mycomm%rank + 1 ] ! Arbitrary numbers to send - write(formstr, "(A,I0,A)") "A,", size(send1), "(1X,I0))" - write(*, label // formstr) 5, mycomm%rank, & - & "Send1 buffer:", send1(:) - call mpifx_gather(mycomm, send1, recv2) - if (mycomm%lead) then - write(formstr, "(A,I0,A)") "A,", size(recv2), "(1X,I0))" - write(*, label // formstr) 6, mycomm%rank, & - & "Recv2 buffer:", recv2 - end if - - call mpifx_finalize() - -end program test_gather diff --git a/test/unit/test_gather.fpp b/test/unit/test_gather.fpp new file mode 100644 index 0000000..311e266 --- /dev/null +++ b/test/unit/test_gather.fpp @@ -0,0 +1,88 @@ +#:include "fortuno_mpi.fypp" + +module test_gather + use libmpifx_module, only : mpifx_comm, mpifx_gather + use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, is_equal + $:FORTUNO_MPI_IMPORTS() + implicit none + +contains + + $:TEST("I0_to_I1") + type(mpifx_comm) :: mycomm + integer :: send0 + integer, allocatable :: recv1(:) + + call mycomm%init(global_comm_id()) + send0 = mycomm%rank * 2 ! Arbitrary number to send + if (mycomm%lead) then + allocate(recv1(1 * mycomm%size), source = 0) + else + allocate(recv1(0), source = 0) + end if + call mpifx_gather(mycomm, send0, recv1) + + if (mycomm%lead) then + @:ASSERT(is_equal(sum(recv1), mycomm%size * (mycomm%size-1))) + else + @:ASSERT(is_equal(sum(recv1), 0)) + end if + $:END_TEST() + + $:TEST("I1_to_I1") + type(mpifx_comm) :: mycomm + integer, allocatable :: send1(:) + integer, allocatable :: recv1(:) + + call mycomm%init(global_comm_id()) + allocate(send1(2), source = 0) + if (mycomm%lead) then + allocate(recv1(size(send1) * mycomm%size), source = 0) + else + allocate(recv1(0), source = 0) + end if + send1(:) = [ mycomm%rank, mycomm%rank + 1 ] ! Arbitrary numbers to send + call mpifx_gather(mycomm, send1, recv1) + + if (mycomm%lead) then + @:ASSERT(is_equal(sum(recv1), mycomm%size**2)) + else + @:ASSERT(is_equal(sum(recv1), 0)) + end if + $:END_TEST() + + $:TEST("I1_to_I2") + type(mpifx_comm) :: mycomm + integer, allocatable :: send1(:) + integer, allocatable :: recv2(:,:) + + call mycomm%init(global_comm_id()) + allocate(send1(2), source = 0) + if (mycomm%lead) then + allocate(recv2(size(send1), mycomm%size), source = 0) + else + allocate(recv2(0, 0), source = 0) + end if + send1(:) = [ mycomm%rank, mycomm%rank + 1 ] ! Arbitrary numbers to send + call mpifx_gather(mycomm, send1, recv2) + + if (mycomm%lead) then + @:ASSERT(is_equal(sum(recv2), mycomm%size**2)) + else + @:ASSERT(is_equal(sum(recv2), 0)) + end if + $:END_TEST() + + function tests() + type(test_list) :: tests + + tests = test_list([& + suite("gather", test_list([& + $:TEST_ITEMS() + ]))& + ]) + @:STOP_ON_MISSING_TEST_ITEMS() + + end function tests + +end module test_gather diff --git a/test/unit/test_gatherv.f90 b/test/unit/test_gatherv.f90 deleted file mode 100644 index e681496..0000000 --- a/test/unit/test_gatherv.f90 +++ /dev/null @@ -1,127 +0,0 @@ -program test_gatherv - use libmpifx_module - implicit none - - type(mpifx_comm) :: mycomm - integer, parameter :: sp = kind(1.0) - real(sp), allocatable :: send1(:), send2(:,:) - real(sp), allocatable :: recv1(:), recv2(:,:) - real(sp) :: send0 - integer, allocatable :: recvcounts(:) - integer, allocatable :: displs(:) - integer :: ii, nrecv - character(100) :: formstr - character(*), parameter :: label = "(I2.2,'-',I3.3,'|',1X" - - call mpifx_init() - call mycomm%init() - - ! R1 -> R1 - if (mycomm%lead) then - write(*, *) 'Test gather rank=1 -> rank=1' - end if - allocate(send1(mycomm%rank+1)) - send1 = real(mycomm%rank+1, sp) - if (mycomm%lead) then - ! recv1 size is 1+2+3+...+mycomm%size - nrecv = mycomm%size*(mycomm%size+1)/2 - allocate(recv1(nrecv)) - allocate(recvcounts(mycomm%size)) - do ii = 1, mycomm%size - recvcounts(ii) = ii - end do - else - allocate(recv1(0)) - end if - call mpifx_gatherv(mycomm, send1, recv1, recvcounts) - if (mycomm%lead) then - write(*, *) "Recv1 buffer:", recv1 - deallocate(recvcounts) - end if - deallocate(recv1) - - ! R2 -> R2 - if (mycomm%lead) then - write(*, *) - write(*, *) 'Test gather rank=2 -> rank=2' - end if - allocate(send2(10, mycomm%rank+1)) - send2 = real(mycomm%rank + 1, sp) - if (mycomm%lead) then - ! recv1 size is 1+2+3+...+mycomm%size - nrecv = mycomm%size*(mycomm%size+1)/2 - allocate(recv2(10, nrecv)) - recv2 = 0 - allocate(recvcounts(mycomm%size)) - do ii = 1, mycomm%size - recvcounts(ii) = 10*ii - end do - else - allocate(recv2(0,0)) - end if - call mpifx_gatherv(mycomm, send2, recv2, recvcounts) - if (mycomm%lead) then - write(*, *) "Recv2 buffer:", recv2(:,:) - deallocate(recvcounts) - end if - deallocate(recv2) - - ! R0 -> R1 with specified receive pattern - if (mycomm%lead) then - write(*, *) - write(*, *) 'Test gather scalar -> rank=1' - end if - send0 = real(mycomm%rank + 1, sp) - if (mycomm%lead) then - nrecv = mycomm%size - allocate(recv1(nrecv)) - allocate(recvcounts(mycomm%size)) - recvcounts = 1 - allocate(displs(mycomm%size)) - ! set a non trivial displs vector - do ii = 1, mycomm%size - displs(ii) = mycomm%size - ii - end do - else - allocate(recv1(0)) - end if - call mpifx_gatherv(mycomm, send0, recv1, recvcounts, displs) - if (mycomm%lead) then - write(*, *) "Recv1 buffer:", recv1 - deallocate(recvcounts) - deallocate(displs) - end if - deallocate(recv1) - - ! R0 -> R1 with specified receive pattern including gaps - if (mycomm%lead) then - write(*, *) - write(*, *) 'Test gather scalar -> rank=1' - end if - send0 = real(mycomm%rank + 1, sp) - if (mycomm%lead) then - nrecv = mycomm%size - allocate(recv1(2*nrecv)) - allocate(recvcounts(mycomm%size)) - recvcounts = 1 - allocate(displs(mycomm%size)) - ! set a non trivial displs vector - do ii = 1, mycomm%size - displs(ii) = 2*ii-1 - end do - ! mark untouched elements - recv1 = -1 - else - allocate(recv1(0)) - end if - call mpifx_gatherv(mycomm, send0, recv1, recvcounts, displs) - if (mycomm%lead) then - write(*, *) "Recv1 buffer:", recv1 - deallocate(recvcounts) - deallocate(displs) - end if - deallocate(recv1) - - call mpifx_finalize() - -end program test_gatherv diff --git a/test/unit/test_gatherv.fpp b/test/unit/test_gatherv.fpp new file mode 100644 index 0000000..a0a3bbe --- /dev/null +++ b/test/unit/test_gatherv.fpp @@ -0,0 +1,131 @@ +#:include "fortuno_mpi.fypp" + +module test_gatherv + use libmpifx_module, only : mpifx_comm, mpifx_gatherv + use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, is_equal + $:FORTUNO_MPI_IMPORTS() + implicit none + +contains + + $:TEST("R1_to_R1") + type(mpifx_comm) :: mycomm + integer, parameter :: sp = kind(1.0) + real(sp), allocatable :: send1(:) + real(sp), allocatable :: recv1(:) + integer, allocatable :: recvcounts(:) + integer :: ii, nrecv + + call mycomm%init(global_comm_id()) + allocate(send1(mycomm%rank+1), source = 0.0_sp) + send1 = real(mycomm%rank+1, sp) + if (mycomm%lead) then + ! recv1 size is 1+2+3+...+mycomm%size + nrecv = mycomm%size*(mycomm%size+1)/2 + allocate(recv1(nrecv), source = 0.0_sp) + allocate(recvcounts(mycomm%size), source = 0) + do ii = 1, mycomm%size + recvcounts(ii) = ii + end do + else + allocate(recv1(0), source = 0.0_sp) + allocate(recvcounts(0), source = 0) + end if + call mpifx_gatherv(mycomm, send1, recv1, recvcounts) + + if (mycomm%lead) then + @:ASSERT(is_equal(nint(sum(recv1)), (2*mycomm%size**3+3*mycomm%size**2+mycomm%size)/6)) + @:ASSERT((abs(sum(recv1)-nint(sum(recv1))) < epsilon(1.0_sp))) + else + @:ASSERT(is_equal(nint(sum(recv1)), 0)) + @:ASSERT((abs(sum(recv1)-nint(sum(recv1))) < epsilon(1.0_sp))) + end if + $:END_TEST() + + $:TEST("R2_to_R2") + type(mpifx_comm) :: mycomm + integer, parameter :: sp = kind(1.0) + real(sp), allocatable :: send2(:,:) + real(sp), allocatable :: recv2(:,:) + integer, allocatable :: recvcounts(:) + integer :: ii, nrecv, nCol + + call mycomm%init(global_comm_id()) + nCol = 10 + allocate(send2(nCol, mycomm%rank+1), source = 0.0_sp) + send2 = real(mycomm%rank + 1, sp) + if (mycomm%lead) then + ! recv1 size is 1+2+3+...+mycomm%size + nrecv = mycomm%size*(mycomm%size+1)/2 + allocate(recv2(nCol, nrecv), source = 0.0_sp) + allocate(recvcounts(mycomm%size), source = 0) + do ii = 1, mycomm%size + recvcounts(ii) = nCol*ii + end do + else + allocate(recv2(0,0), source = 0.0_sp) + allocate(recvcounts(0), source = 0) + end if + call mpifx_gatherv(mycomm, send2, recv2, recvcounts) + + if (mycomm%lead) then + @:ASSERT(is_equal(nint(sum(recv2)), nCol*mycomm%size*(mycomm%size+1)*(2*mycomm%size+1)/6)) + @:ASSERT((abs(sum(recv2)-nint(sum(recv2))) < epsilon(1.0_sp))) + else + @:ASSERT(is_equal(nint(sum(recv2)), 0)) + @:ASSERT((abs(sum(recv2)-nint(sum(recv2))) < epsilon(1.0_sp))) + end if + $:END_TEST() + + $:TEST("R0_to_R1") + ! R0 -> R1 with specified receive pattern including gaps + type(mpifx_comm) :: mycomm + integer, parameter :: sp = kind(1.0) + real(sp), allocatable :: recv1(:) + real(sp) :: send0 + integer, allocatable :: recvcounts(:) + integer, allocatable :: displs(:) + integer :: ii, nrecv + + call mycomm%init(global_comm_id()) + send0 = real(mycomm%rank + 1, sp) + if (mycomm%lead) then + nrecv = mycomm%size + allocate(recv1(2*nrecv), source = 0.0_sp) + allocate(recvcounts(mycomm%size), source = 1) + allocate(displs(mycomm%size), source = 0) + ! set a non trivial displs vector + do ii = 1, mycomm%size + displs(ii) = 2*ii-1 + end do + ! mark untouched elements + recv1 = -1 + else + allocate(recv1(0), source = 0.0_sp) + allocate(recvcounts(0), source = 0) + allocate(displs(0), source = 0) + end if + call mpifx_gatherv(mycomm, send0, recv1, recvcounts, displs) + + if (mycomm%lead) then + @:ASSERT(is_equal(nint(sum(recv1)), (mycomm%size*(mycomm%size+1))/2 - mycomm%size)) + @:ASSERT((abs(sum(recv1)-nint(sum(recv1))) < epsilon(1.0_sp))) + else + @:ASSERT(is_equal(nint(sum(recv1)), 0)) + @:ASSERT((abs(sum(recv1)-nint(sum(recv1))) < epsilon(1.0_sp))) + end if + $:END_TEST() + + function tests() + type(test_list) :: tests + + tests = test_list([& + suite("gatherv", test_list([& + $:TEST_ITEMS() + ]))& + ]) + @:STOP_ON_MISSING_TEST_ITEMS() + + end function tests + +end module test_gatherv diff --git a/test/unit/test_reduce.f90 b/test/unit/test_reduce.f90 deleted file mode 100644 index b5f515b..0000000 --- a/test/unit/test_reduce.f90 +++ /dev/null @@ -1,43 +0,0 @@ -program test_reduce - use libmpifx_module - implicit none - - integer, parameter :: dp = kind(1.0d0) - - type(mpifx_comm) :: mycomm - integer :: vali0, resvali0 - real(dp) :: valr(3), resvalr(3) - - call mpifx_init() - call mycomm%init() - - ! Reduction of a scalarw - vali0 = mycomm%rank * 2 - write(*, "(I2.2,'-',I3.3,'|',1X,A,I0)") 1, mycomm%rank, & - & "Value to be operated on:", vali0 - call mpifx_reduce(mycomm, vali0, resvali0, MPI_SUM) - write(*, "(I2.2,'-',I3.3,'|',1X,A,I0)") 2, mycomm%rank, & - & "Obtained result (sum):", resvali0 - - ! Reduction of an array - valr(:) = [ real(mycomm%rank + 1, dp) * 1.2, & - & real(mycomm%rank + 1, dp) * 4.3, real(mycomm%rank + 1, dp) * 3.8 ] - resvalr(:) = 0.0_dp - write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 3, mycomm%rank, & - & "Value to be operated on:", valr(:) - call mpifx_reduce(mycomm, valr, resvalr, MPI_PROD) - write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 4, mycomm%rank, & - & "Obtained result (prod):", resvalr(:) - - ! In place summation - resvalr(:) = [ real(mycomm%rank + 1, dp) * 1.2, & - & real(mycomm%rank + 1, dp) * 4.3, real(mycomm%rank + 1, dp) * 3.8 ] - write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 5, mycomm%rank, & - & "Value to be operated on:", resvalr(:) - call mpifx_reduceip(mycomm, resvalr, MPI_SUM) - write(*, "(I2.2,'-',I3.3,'|',1X,A,3F8.2)") 6, mycomm%rank, & - & "Obtained result (sum):", resvalr(:) - - call mpifx_finalize() - -end program test_reduce diff --git a/test/unit/test_reduce.fpp b/test/unit/test_reduce.fpp new file mode 100644 index 0000000..38a495c --- /dev/null +++ b/test/unit/test_reduce.fpp @@ -0,0 +1,95 @@ +#:include "fortuno_mpi.fypp" + +module test_reduce + use mpi, only : MPI_SUM, MPI_PROD + use libmpifx_module, only : mpifx_comm, mpifx_reduce, mpifx_reduceip + use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, is_equal + $:FORTUNO_MPI_IMPORTS() + implicit none + +contains + + $:TEST("scalar_sum") + type(mpifx_comm) :: mycomm + integer :: vali0, resvali0 + + call mycomm%init(global_comm_id()) + vali0 = mycomm%rank * 2 + call mpifx_reduce(mycomm, vali0, resvali0, MPI_SUM) + + if (mycomm%lead) then + @:ASSERT(is_equal(resvali0, mycomm%size * (mycomm%size-1))) + else + @:ASSERT(is_equal(resvali0, 0)) + end if + $:END_TEST() + + $:TEST("array_prod") + integer, parameter :: dp = kind(1.0d0) + type(mpifx_comm) :: mycomm + real(dp) :: valr(3), resvalr(3) + integer :: max_none_one_rank, max_valid_rank + + max_valid_rank = 9 + call mycomm%init(global_comm_id()) + if (mycomm%rank <= max_valid_rank) then + valr(:) = [ real(mycomm%rank + 1, dp) * 1.2, & + & real(mycomm%rank + 1, dp) * 4.3, real(mycomm%rank + 1, dp) * 3.8 ] + else + ! prevents the product from getting to large + valr(:) = [ real(1, dp), real(1, dp), real(1, dp) ] + end if + resvalr(:) = 0.0_dp + call mpifx_reduce(mycomm, valr, resvalr, MPI_PROD) + + if (mycomm%lead) then + if (mycomm%size <= max_valid_rank + 1) then + max_none_one_rank = mycomm%size + else + max_none_one_rank = max_valid_rank + 1 + end if + + @:ASSERT(abs(resvalr(1) - (gamma(real(max_none_one_rank + 1, kind=dp)) * (1.2)**(max_none_one_rank))) < abs((resvalr(1)*1e-6))) + @:ASSERT(abs(resvalr(2) - (gamma(real(max_none_one_rank + 1, kind=dp)) * (4.3)**(max_none_one_rank))) < abs((resvalr(2)*1e-6))) + @:ASSERT(abs(resvalr(3) - (gamma(real(max_none_one_rank + 1, kind=dp)) * (3.8)**(max_none_one_rank))) < abs((resvalr(3)*1e-6))) + else + @:ASSERT(resvalr(1) == 0.0_dp) + @:ASSERT(resvalr(2) == 0.0_dp) + @:ASSERT(resvalr(3) == 0.0_dp) + end if + $:END_TEST() + + $:TEST("ip_sum") + integer, parameter :: dp = kind(1.0d0) + type(mpifx_comm) :: mycomm + real(dp) :: resvalr(3) + + call mycomm%init(global_comm_id()) + resvalr(:) = [ real(mycomm%rank + 1, dp) * 1.2, & + & real(mycomm%rank + 1, dp) * 4.3, real(mycomm%rank + 1, dp) * 3.8 ] + call mpifx_reduceip(mycomm, resvalr, MPI_SUM) + + if (mycomm%lead) then + @:ASSERT(abs(resvalr(1) - (mycomm%size * (mycomm%size + 1)) / 2 * 1.2) < abs((resvalr(1)*1e-7))) + @:ASSERT(abs(resvalr(2) - (mycomm%size * (mycomm%size + 1)) / 2 * 4.3) < abs((resvalr(2)*1e-7))) + @:ASSERT(abs(resvalr(3) - (mycomm%size * (mycomm%size + 1)) / 2 * 3.8) < abs((resvalr(3)*1e-7))) + else + @:ASSERT(resvalr(1) == real(mycomm%rank + 1, dp) * 1.2) + @:ASSERT(resvalr(2) == real(mycomm%rank + 1, dp) * 4.3) + @:ASSERT(resvalr(3) == real(mycomm%rank + 1, dp) * 3.8) + end if + $:END_TEST() + + function tests() + type(test_list) :: tests + + tests = test_list([& + suite("reduce", test_list([& + $:TEST_ITEMS() + ]))& + ]) + @:STOP_ON_MISSING_TEST_ITEMS() + + end function tests + +end module test_reduce diff --git a/test/unit/test_scatter.f90 b/test/unit/test_scatter.f90 deleted file mode 100644 index 7bbbad3..0000000 --- a/test/unit/test_scatter.f90 +++ /dev/null @@ -1,66 +0,0 @@ -program test_scatter - use libmpifx_module - implicit none - - type(mpifx_comm) :: mycomm - integer, allocatable :: send1(:), send2(:,:) - integer :: recv0 - integer, allocatable :: recv1(:) - character(100) :: formstr - character(*), parameter :: label = "(I2.2,'-',I3.3,'|',1X" - integer :: ii - - call mpifx_init() - call mycomm%init() - - ! I1 -> I0 - if (mycomm%lead) then - allocate(send1(mycomm%size)) - send1(:) = [ (ii, ii = 1, size(send1)) ] - write(formstr, "(A,I0,A)") "A,", size(send1), "(1X,I0))" - write(*, label // formstr) 1, mycomm%rank, & - & "Send1 buffer:", send1 - else - allocate(send1(0)) - end if - recv0 = 0 - call mpifx_scatter(mycomm, send1, recv0) - write(formstr, "(A,I0,A)") "A,", 1, "(1X,I0))" - write(*, label // formstr) 2, mycomm%rank, & - & "Recv0 buffer:", recv0 - - ! I1 -> I1 - if (mycomm%lead) then - deallocate(send1) - allocate(send1(2 * mycomm%size)) - send1(:) = [ (ii, ii = 1, size(send1)) ] - write(formstr, "(A,I0,A)") "A,", size(send1), "(1X,I0))" - write(*, label // formstr) 3, mycomm%rank, & - & "Send1 buffer:", send1 - end if - allocate(recv1(2)) - recv1(:) = 0 - call mpifx_scatter(mycomm, send1, recv1) - write(formstr, "(A,I0,A)") "A,", size(recv1), "(1X,I0))" - write(*, label // formstr) 4, mycomm%rank, & - & "Recv1 buffer:", recv1 - - ! I2 -> I1 - if (mycomm%lead) then - allocate(send2(2, mycomm%size)) - send2(:,:) = reshape(send1, [ 2, mycomm%size ]) - write(formstr, "(A,I0,A)") "A,", size(send2), "(1X,I0))" - write(*, label // formstr) 5, mycomm%rank, & - & "Send2 buffer:", send2 - else - allocate(send2(0,0)) - end if - recv1(:) = 0 - call mpifx_scatter(mycomm, send2, recv1) - write(formstr, "(A,I0,A)") "A,", size(recv1), "(1X,I0))" - write(*, label // formstr) 6, mycomm%rank, & - & "Recv1 buffer:", recv1 - - call mpifx_finalize() - -end program test_scatter diff --git a/test/unit/test_scatter.fpp b/test/unit/test_scatter.fpp new file mode 100644 index 0000000..3ade7e0 --- /dev/null +++ b/test/unit/test_scatter.fpp @@ -0,0 +1,79 @@ +#:include "fortuno_mpi.fypp" + +module test_scatter + use libmpifx_module, only : mpifx_comm, mpifx_scatter + use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, is_equal + $:FORTUNO_MPI_IMPORTS() + implicit none + +contains + + $:TEST("I1_to_I0") + type(mpifx_comm) :: mycomm + integer, allocatable :: send1(:) + integer :: recv0 = 0 + integer :: ii + + call mycomm%init(global_comm_id()) + if (mycomm%lead) then + allocate(send1(mycomm%size), source = 0) + send1(:) = [ (ii, ii = 1, size(send1)) ] + else + allocate(send1(0), source = 0) + end if + call mpifx_scatter(mycomm, send1, recv0) + + @:ASSERT(is_equal(recv0, mycomm%rank + 1)) + $:END_TEST() + + $:TEST("I1_to_I1") + type(mpifx_comm) :: mycomm + integer, allocatable :: send1(:) + integer, allocatable :: recv1(:) + integer :: ii + + call mycomm%init(global_comm_id()) + if (mycomm%lead) then + allocate(send1(2 * mycomm%size), source = 0) + send1(:) = [ (ii, ii = 1, size(send1)) ] + end if + allocate(recv1(2), source = 0) + call mpifx_scatter(mycomm, send1, recv1) + + @:ASSERT(is_equal(recv1(1), 2*mycomm%rank + 1)) + @:ASSERT(is_equal(recv1(2), 2*mycomm%rank + 2)) + $:END_TEST() + + $:TEST("I2_to_I1") + type(mpifx_comm) :: mycomm + integer, allocatable :: send2(:,:) + integer, allocatable :: recv1(:) + integer :: ii + + call mycomm%init(global_comm_id()) + if (mycomm%lead) then + allocate(send2(2, mycomm%size), source = 0) + send2(:,:) = reshape([ (ii, ii = 1, 2 * mycomm%size) ], [ 2, mycomm%size ]) + else + allocate(send2(0,0), source = 0) + end if + allocate(recv1(2), source = 0) + call mpifx_scatter(mycomm, send2, recv1) + + @:ASSERT(is_equal(recv1(1), 2*mycomm%rank + 1)) + @:ASSERT(is_equal(recv1(2), 2*mycomm%rank + 2)) + $:END_TEST() + + function tests() + type(test_list) :: tests + + tests = test_list([& + suite("scatter", test_list([& + $:TEST_ITEMS() + ]))& + ]) + @:STOP_ON_MISSING_TEST_ITEMS() + + end function tests + +end module test_scatter diff --git a/test/unit/test_scatterv.f90 b/test/unit/test_scatterv.f90 deleted file mode 100644 index 00777b2..0000000 --- a/test/unit/test_scatterv.f90 +++ /dev/null @@ -1,85 +0,0 @@ -program test_scatterv - use libmpifx_module - implicit none - - type(mpifx_comm) :: mycomm - integer, allocatable :: send1(:), send2(:,:) - integer :: recv0 - integer, allocatable :: recv1(:), sendcount(:), displs(:) - character(100) :: formstr - character(*), parameter :: label = "(I2.2,'-',I3.3,'|',1X" - integer :: ii - - call mpifx_init() - call mycomm%init() - - ! I1 -> I0 - if (mycomm%lead) then - allocate(send1(mycomm%size)) - allocate(sendcount(mycomm%size)) - send1(:) = [ (ii, ii = 1, size(send1)) ] - sendcount(:) = 1 - write(formstr, "(A,I0,A)") "A,", size(send1), "(1X,I0))" - write(*, label // formstr) 1, mycomm%rank, "Send1 buffer:", send1 - else - allocate(send1(0)) - allocate(sendcount(0)) - end if - recv0 = 0 - call mpifx_scatterv(mycomm, send1, sendcount, recv0) - write(formstr, "(A,I0,A)") "A,", 1, "(1X,I0))" - write(*, label // formstr) 2, mycomm%rank, "Recv0 buffer:", recv0 - - ! I1 -> I1 - if (mycomm%lead) then - deallocate(send1) - allocate(send1(2 * mycomm%size)) - sendcount(:) = 2 - send1(:) = [ (ii, ii = 1, size(send1)) ] - write(formstr, "(A,I0,A)") "A,", size(send1), "(1X,I0))" - write(*, label // formstr) 3, mycomm%rank, "Send1 buffer:", send1 - end if - allocate(recv1(2)) - recv1(:) = 0 - call mpifx_scatterv(mycomm, send1, sendcount, recv1) - write(formstr, "(A,I0,A)") "A,", size(recv1), "(1X,I0))" - write(*, label // formstr) 4, mycomm%rank, "Recv1 buffer:", recv1 - - ! I2 -> I1 - if (mycomm%lead) then - allocate(send2(2, mycomm%size)) - sendcount(:) = 2 - send2(:,:) = reshape(send1, [ 2, mycomm%size ]) - write(formstr, "(A,I0,A)") "A,", size(send2), "(1X,I0))" - write(*, label // formstr) 5, mycomm%rank, & - & "Send2 buffer:", send2 - else - allocate(send2(0,0)) - end if - recv1(:) = 0 - call mpifx_scatterv(mycomm, send2, sendcount, recv1) - write(formstr, "(A,I0,A)") "A,", size(recv1), "(1X,I0))" - write(*, label // formstr) 6, mycomm%rank, & - & "Recv1 buffer:", recv1 - - ! I1 -> I1 - if (mycomm%lead) then - deallocate(send1) - allocate(send1(2 * mycomm%size)) - send1(:) = [ (ii, ii = 1, size(send1)) ] - sendcount(:) = 1 - allocate(displs(mycomm%size)) - displs(:) = [ (ii, ii = 1, size(send1), 2) ] - write(formstr, "(A,I0,A)") "A,", size(send1), "(1X,I0))" - write(*, label // formstr) 7, mycomm%rank, "Send1 buffer:", send1 - end if - deallocate(recv1) - allocate(recv1(1)) - recv1(:) = 0 - call mpifx_scatterv(mycomm, send1, sendcount, recv1, displs=displs) - write(formstr, "(A,I0,A)") "A,", size(recv1), "(1X,I0))" - write(*, label // formstr) 8, mycomm%rank, "Recv1 buffer:", recv1 - - call mpifx_finalize() - -end program test_scatterv diff --git a/test/unit/test_scatterv.fpp b/test/unit/test_scatterv.fpp new file mode 100644 index 0000000..6677279 --- /dev/null +++ b/test/unit/test_scatterv.fpp @@ -0,0 +1,113 @@ +#:include "fortuno_mpi.fypp" + +module test_scatterv + use libmpifx_module, only : mpifx_comm, mpifx_scatterv + use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, is_equal + $:FORTUNO_MPI_IMPORTS() + implicit none + +contains + + $:TEST("I1_to_I0") + type(mpifx_comm) :: mycomm + integer, allocatable :: send1(:) + integer :: recv0 = 0 + integer, allocatable :: sendcount(:) + integer :: ii + + call mycomm%init(global_comm_id()) + if (mycomm%lead) then + allocate(sendcount(mycomm%size), source = 1) + allocate(send1(mycomm%size), source = 0) + send1(:) = [ (ii, ii = 1, size(send1)) ] + else + allocate(sendcount(0), source = 0) + allocate(send1(0), source = 0) + end if + call mpifx_scatterv(mycomm, send1, sendcount, recv0) + + @:ASSERT(is_equal(recv0, mycomm%rank + 1)) + $:END_TEST() + + $:TEST("I1_to_I1") + type(mpifx_comm) :: mycomm + integer, allocatable :: send1(:) + integer, allocatable :: recv1(:), sendcount(:) + integer :: ii + + call mycomm%init(global_comm_id()) + if (mycomm%lead) then + allocate(sendcount(mycomm%size), source = 2) + allocate(send1(2 * mycomm%size), source = 0) + send1(:) = [ (ii, ii = 1, size(send1)) ] + else + allocate(sendcount(0), source = 0) + allocate(send1(0), source = 0) + end if + allocate(recv1(2), source = 0) + call mpifx_scatterv(mycomm, send1, sendcount, recv1) + + @:ASSERT(is_equal(recv1(1), 2*mycomm%rank + 1)) + @:ASSERT(is_equal(recv1(2), 2*mycomm%rank + 2)) + $:END_TEST() + + $:TEST("I2_to_I1") + type(mpifx_comm) :: mycomm + integer, allocatable :: send2(:,:) + integer :: recv0 + integer, allocatable :: recv1(:), sendcount(:) + integer :: ii + + call mycomm%init(global_comm_id()) + if (mycomm%lead) then + allocate(sendcount(mycomm%size), source = 2) + allocate(send2(2, mycomm%size), source = 0) + send2(:,:) = reshape([ (ii, ii = 1, 2 * mycomm%size) ], [ 2, mycomm%size ]) + else + allocate(sendcount(0), source = 0) + allocate(send2(0,0), source = 0) + end if + allocate(recv1(2), source = 0) + call mpifx_scatterv(mycomm, send2, sendcount, recv1) + + @:ASSERT(is_equal(recv1(1), 2*mycomm%rank + 1)) + @:ASSERT(is_equal(recv1(2), 2*mycomm%rank + 2)) + $:END_TEST() + + $:TEST("I1_to_I1_disp") + type(mpifx_comm) :: mycomm + integer, allocatable :: send1(:) + integer, allocatable :: recv1(:), sendcount(:), displs(:) + integer :: ii + + call mycomm%init(global_comm_id()) + if (mycomm%lead) then + allocate(sendcount(mycomm%size), source = 1) + allocate(send1(2 * mycomm%size), source = 0) + send1(:) = [ (ii, ii = 1, size(send1)) ] + allocate(displs(mycomm%size), source = 0) + displs(:) = [ (ii, ii = 1, size(send1), 2) ] + else + allocate(sendcount(0), source = 0) + allocate(send1(0), source = 0) + allocate(displs(0), source = 0) + end if + allocate(recv1(1), source = 0) + call mpifx_scatterv(mycomm, send1, sendcount, recv1, displs=displs) + + @:ASSERT(is_equal(recv1(1), 2*mycomm%rank + 2)) + $:END_TEST() + + function tests() + type(test_list) :: tests + + tests = test_list([& + suite("scatterv", test_list([& + $:TEST_ITEMS() + ]))& + ]) + @:STOP_ON_MISSING_TEST_ITEMS() + + end function tests + +end module test_scatterv diff --git a/test/unit/test_send_recv.f90 b/test/unit/test_send_recv.f90 deleted file mode 100644 index ae228a1..0000000 --- a/test/unit/test_send_recv.f90 +++ /dev/null @@ -1,23 +0,0 @@ -program test_send_recv - use libmpifx_module - implicit none - - character(100) :: msg - type(mpifx_comm) :: mycomm - integer :: source - - call mpifx_init() - call mycomm%init() - if (.not. mycomm%lead) then - write(msg, "(A,I0,A)") "Hello from process ", mycomm%rank, "!" - call mpifx_send(mycomm, msg, mycomm%leadrank) - else - write(*, "(A)") "Lead node:" - do source = 1, mycomm%size - 1 - call mpifx_recv(mycomm, msg, source) - write(*,"(A,A)") "Message received: ", trim(msg) - end do - end if - call mpifx_finalize() - -end program test_send_recv diff --git a/test/unit/test_send_recv.fpp b/test/unit/test_send_recv.fpp new file mode 100644 index 0000000..7195808 --- /dev/null +++ b/test/unit/test_send_recv.fpp @@ -0,0 +1,70 @@ +#:include "fortuno_mpi.fypp" + +module test_send_recv + use libmpifx_module, only : mpifx_comm, mpifx_recv, mpifx_send + use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, is_equal + $:FORTUNO_MPI_IMPORTS() + implicit none + +contains + + $:TEST("send_to_lead") + character(5) :: msg, expected + type(mpifx_comm) :: mycomm + integer :: source + logical :: tPassed = .true. + + call mycomm%init(global_comm_id()) + if (.not. mycomm%lead) then + write(msg, "(i0)") mycomm%rank + call mpifx_send(mycomm, msg, mycomm%leadrank) + else + do source = 1, mycomm%size - 1 + write(expected, "(i0)") source + call mpifx_recv(mycomm, msg, source) + tPassed = tPassed .and. (msg == expected) + end do + end if + + @:ASSERT(tPassed) + $:END_TEST() + + $:TEST("to_lower_neighbour") + character(5) :: msg, expected + type(mpifx_comm) :: mycomm + integer :: destination + integer :: source + + call mycomm%init(global_comm_id()) + if (mycomm%rank - 1 >= 0) then + destination = mycomm%rank - 1 + else + destination = mycomm%size - 1 + end if + write(msg, "(i0)") mycomm%rank + call mpifx_send(mycomm, msg, destination) + + if (mycomm%rank == mycomm%size - 1) then + source = 0 + else + source = mycomm%rank + 1 + end if + write(expected, "(i0)") source + call mpifx_recv(mycomm, msg, source) + + @:ASSERT(msg == expected) + $:END_TEST() + + function tests() + type(test_list) :: tests + + tests = test_list([& + suite("send_recv", test_list([& + $:TEST_ITEMS() + ]))& + ]) + @:STOP_ON_MISSING_TEST_ITEMS() + + end function tests + +end module test_send_recv diff --git a/test/unit/testapp.f90 b/test/unit/testapp.f90 index 312a366..44df4f9 100644 --- a/test/unit/testapp.f90 +++ b/test/unit/testapp.f90 @@ -1,10 +1,34 @@ program testapp use fortuno_mpi, only : execute_mpi_cmd_app, test_list + use test_allgather, only : allgather_tests => tests + use test_allgatherv, only : allgatherv_tests => tests + use test_allreduce, only : allreduce_tests => tests use test_bcast, only : bcast_tests => tests + use test_comm_split_type, only : comm_split_type_tests => tests + use test_comm_split, only : comm_split_tests => tests + use test_gather, only : gather_tests => tests + use test_gatherv, only : gatherv_tests => tests + use test_reduce, only : reduce_tests => tests + use test_scatter, only : scatter_tests => tests + use test_scatterv, only : scatterv_tests => tests + use test_send_recv, only : send_recv_tests => tests implicit none - call execute_mpi_cmd_app(test_list([& - bcast_tests()& - ])) + call execute_mpi_cmd_app( + test_list([& + allgather_tests(),& + allgatherv_tests(),& + allreduce_tests(),& + bcast_tests(),& + comm_split_type_tests(),& + comm_split_testS(),& + gather_tests(),& + gatherv_tests(),& + reduce_tests(),& + scatter_tests(),& + scatterv_tests(),& + send_recv_tests()& + ]& + ) end program testapp From cc2af6ec9fa0bb904c92492b2ab6cb428156bce4 Mon Sep 17 00:00:00 2001 From: Justin Bich Date: Thu, 31 Oct 2024 16:13:49 +0100 Subject: [PATCH 4/4] Improve asserts --- subprojects/Fortuno.cmake | 6 ++++-- test/unit/test_allgatherv.fpp | 14 +++++++------- test/unit/test_allreduce.fpp | 18 +++++++++--------- test/unit/test_bcast.fpp | 4 ++-- test/unit/test_gatherv.fpp | 23 ++++++++++------------- test/unit/test_reduce.fpp | 27 ++++++++++++--------------- test/unit/test_scatter.fpp | 8 +++----- test/unit/test_scatterv.fpp | 8 +++----- test/unit/testapp.f90 | 4 ++-- 9 files changed, 52 insertions(+), 60 deletions(-) diff --git a/subprojects/Fortuno.cmake b/subprojects/Fortuno.cmake index 4769478..204f355 100644 --- a/subprojects/Fortuno.cmake +++ b/subprojects/Fortuno.cmake @@ -12,8 +12,10 @@ option(FORTUNO_WITH_MPI "Fortuno: Whether mpi interface should be built" ON) # Make subproject available FetchContent_Declare( Fortuno - GIT_REPOSITORY "https://github.com/fortuno-repos/fortuno.git" - GIT_TAG "main" + # GIT_REPOSITORY "https://github.com/fortuno-repos/fortuno.git" + # GIT_TAG "main" + GIT_REPOSITORY "https://github.com/aradi/fortuno.git" + GIT_TAG "isequal" FIND_PACKAGE_ARGS ) FetchContent_MakeAvailable(Fortuno) diff --git a/test/unit/test_allgatherv.fpp b/test/unit/test_allgatherv.fpp index 463ec20..a47fc37 100644 --- a/test/unit/test_allgatherv.fpp +++ b/test/unit/test_allgatherv.fpp @@ -3,7 +3,7 @@ module test_allgatherv use libmpifx_module, only : mpifx_comm, mpifx_allgatherv - use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, is_equal + use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, is_close, is_equal $:FORTUNO_MPI_IMPORTS() implicit none @@ -29,8 +29,8 @@ contains end do call mpifx_allgatherv(mycomm, send1, recv1, recvcounts) - @:ASSERT(is_equal(nint(sum(recv1)), (2*mycomm%size**3+3*mycomm%size**2+mycomm%size)/6)) - @:ASSERT((abs(sum(recv1)-nint(sum(recv1))) < epsilon(1.0_sp))) + @:ASSERT(is_close(sum(recv1), (2*mycomm%size**3+3*mycomm%size**2+mycomm%size)/6.0_sp, & + & atol=epsilon(1.0_sp), rtol=0.0_sp)) $:END_TEST() $:TEST("R2_to_R2") @@ -53,8 +53,8 @@ contains end do call mpifx_allgatherv(mycomm, send2, recv2, recvcounts) - @:ASSERT(is_equal(nint(sum(recv2)), nCol*mycomm%size*(mycomm%size+1)*(2*mycomm%size+1)/6)) - @:ASSERT((abs(sum(recv2)-nint(sum(recv2))) < epsilon(1.0_sp))) + @:ASSERT(is_close(sum(recv2), nCol*mycomm%size*(mycomm%size+1)*(2*mycomm%size+1)/6.0_sp, & + & atol=epsilon(1.0_sp), rtol=0.0_sp)) $:END_TEST() $:TEST("R0_to_R1") @@ -79,8 +79,8 @@ contains end do call mpifx_allgatherv(mycomm, send0, recv1, recvcounts, displs) - @:ASSERT(is_equal(nint(sum(recv1)), (mycomm%size*(mycomm%size+1))/2)) - @:ASSERT((abs(sum(recv1)-nint(sum(recv1))) < epsilon(1.0_sp))) + @:ASSERT(is_close(sum(recv1), (mycomm%size*(mycomm%size+1))/2.0_sp, & + & atol=epsilon(1.0_sp), rtol=0.0_sp)) $:END_TEST() function tests() diff --git a/test/unit/test_allreduce.fpp b/test/unit/test_allreduce.fpp index c2b8d40..402d844 100644 --- a/test/unit/test_allreduce.fpp +++ b/test/unit/test_allreduce.fpp @@ -3,7 +3,7 @@ module test_allreduce use mpi, only : MPI_SUM, MPI_PROD use libmpifx_module, only : mpifx_comm, mpifx_allreduce, mpifx_allreduceip - use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, is_equal + use fortuno_mpi, only : all_close, global_comm_id, suite => mpi_suite_item, test_list, is_equal $:FORTUNO_MPI_IMPORTS() implicit none @@ -22,11 +22,11 @@ contains $:TEST("array_prod") integer, parameter :: dp = kind(1.0d0) + integer, parameter :: max_valid_rank = 9 type(mpifx_comm) :: mycomm real(dp) :: valr(3), resvalr(3) - integer :: max_none_one_rank, max_valid_rank + integer :: max_none_one_rank - max_valid_rank = 9 call mycomm%init(global_comm_id()) if (mycomm%rank <= max_valid_rank) then @@ -44,9 +44,9 @@ contains max_none_one_rank = max_valid_rank + 1 end if - @:ASSERT(abs(resvalr(1) - (gamma(real(max_none_one_rank + 1, kind=dp)) * (1.2)**(max_none_one_rank))) < abs((resvalr(1)*1e-6))) - @:ASSERT(abs(resvalr(2) - (gamma(real(max_none_one_rank + 1, kind=dp)) * (4.3)**(max_none_one_rank))) < abs((resvalr(2)*1e-6))) - @:ASSERT(abs(resvalr(3) - (gamma(real(max_none_one_rank + 1, kind=dp)) * (3.8)**(max_none_one_rank))) < abs((resvalr(3)*1e-6))) + @:ASSERT(all_close(resvalr, [gamma(real(max_none_one_rank + 1, kind=dp)) * (1.2)**(max_none_one_rank), & + & gamma(real(max_none_one_rank + 1, kind=dp)) * (4.3)**(max_none_one_rank), & + & gamma(real(max_none_one_rank + 1, kind=dp)) * (3.8)**(max_none_one_rank)], rtol=1e-6_dp)) $:END_TEST() $:TEST("ip_sum") @@ -59,9 +59,9 @@ contains & real(mycomm%rank + 1, dp) * 4.3, real(mycomm%rank + 1, dp) * 3.8 ] call mpifx_allreduceip(mycomm, resvalr, MPI_SUM) - @:ASSERT(abs(resvalr(1) - (mycomm%size * (mycomm%size + 1)) / 2 * 1.2) < abs((resvalr(1)*1e-7))) - @:ASSERT(abs(resvalr(2) - (mycomm%size * (mycomm%size + 1)) / 2 * 4.3) < abs((resvalr(2)*1e-7))) - @:ASSERT(abs(resvalr(3) - (mycomm%size * (mycomm%size + 1)) / 2 * 3.8) < abs((resvalr(3)*1e-7))) + @:ASSERT(all_close(resvalr, [mycomm%size * (mycomm%size + 1) / 2 * 1.2_dp, & + & mycomm%size * (mycomm%size + 1) / 2 * 4.3_dp, mycomm%size * (mycomm%size + 1) / 2 * 3.8_dp], & + & rtol=1e-7_dp)) $:END_TEST() function tests() diff --git a/test/unit/test_bcast.fpp b/test/unit/test_bcast.fpp index 61e0503..469dbae 100644 --- a/test/unit/test_bcast.fpp +++ b/test/unit/test_bcast.fpp @@ -2,7 +2,7 @@ module test_bcast use libmpifx_module, only : mpifx_comm, mpifx_barrier, mpifx_bcast - use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, this_rank + use fortuno_mpi, only : all_close, global_comm_id, suite => mpi_suite_item, test_list, this_rank $:FORTUNO_MPI_IMPORTS() implicit none @@ -56,7 +56,7 @@ contains buffer(:,:) = 0.0_dp if (mycomm%lead) buffer(:,:) = msg call mpifx_bcast(mycomm, buffer) - @:ASSERT(all(abs(buffer - msg) < tol)) + @:ASSERT(all_close(buffer, msg, rtol=tol)) $:END_TEST() diff --git a/test/unit/test_gatherv.fpp b/test/unit/test_gatherv.fpp index a0a3bbe..a006db5 100644 --- a/test/unit/test_gatherv.fpp +++ b/test/unit/test_gatherv.fpp @@ -2,7 +2,7 @@ module test_gatherv use libmpifx_module, only : mpifx_comm, mpifx_gatherv - use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, is_equal + use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, is_close, is_equal $:FORTUNO_MPI_IMPORTS() implicit none @@ -34,11 +34,10 @@ contains call mpifx_gatherv(mycomm, send1, recv1, recvcounts) if (mycomm%lead) then - @:ASSERT(is_equal(nint(sum(recv1)), (2*mycomm%size**3+3*mycomm%size**2+mycomm%size)/6)) - @:ASSERT((abs(sum(recv1)-nint(sum(recv1))) < epsilon(1.0_sp))) + @:ASSERT(is_close(sum(recv1), (2*mycomm%size**3+3*mycomm%size**2+mycomm%size)/6.0_sp, & + & atol=epsilon(1.0_sp), rtol=0.0_sp)) else - @:ASSERT(is_equal(nint(sum(recv1)), 0)) - @:ASSERT((abs(sum(recv1)-nint(sum(recv1))) < epsilon(1.0_sp))) + @:ASSERT(is_close(sum(recv1), 0.0_sp, atol=epsilon(1.0_sp), rtol=0.0_sp)) end if $:END_TEST() @@ -69,11 +68,10 @@ contains call mpifx_gatherv(mycomm, send2, recv2, recvcounts) if (mycomm%lead) then - @:ASSERT(is_equal(nint(sum(recv2)), nCol*mycomm%size*(mycomm%size+1)*(2*mycomm%size+1)/6)) - @:ASSERT((abs(sum(recv2)-nint(sum(recv2))) < epsilon(1.0_sp))) + @:ASSERT(is_close(sum(recv2), nCol*mycomm%size*(mycomm%size+1)*(2*mycomm%size+1)/6.0_sp, & + & atol=epsilon(1.0_sp), rtol=0.0_sp)) else - @:ASSERT(is_equal(nint(sum(recv2)), 0)) - @:ASSERT((abs(sum(recv2)-nint(sum(recv2))) < epsilon(1.0_sp))) + @:ASSERT(is_close(sum(recv2), 0.0_sp, atol=epsilon(1.0_sp), rtol=0.0_sp)) end if $:END_TEST() @@ -108,11 +106,10 @@ contains call mpifx_gatherv(mycomm, send0, recv1, recvcounts, displs) if (mycomm%lead) then - @:ASSERT(is_equal(nint(sum(recv1)), (mycomm%size*(mycomm%size+1))/2 - mycomm%size)) - @:ASSERT((abs(sum(recv1)-nint(sum(recv1))) < epsilon(1.0_sp))) + @:ASSERT(is_close(sum(recv1), (mycomm%size*(mycomm%size+1))/2.0_sp - mycomm%size, & + & atol=epsilon(1.0_sp), rtol=0.0_sp)) else - @:ASSERT(is_equal(nint(sum(recv1)), 0)) - @:ASSERT((abs(sum(recv1)-nint(sum(recv1))) < epsilon(1.0_sp))) + @:ASSERT(is_close(sum(recv1), 0.0_sp, atol=epsilon(1.0_sp), rtol=0.0_sp)) end if $:END_TEST() diff --git a/test/unit/test_reduce.fpp b/test/unit/test_reduce.fpp index 38a495c..6f25939 100644 --- a/test/unit/test_reduce.fpp +++ b/test/unit/test_reduce.fpp @@ -3,7 +3,7 @@ module test_reduce use mpi, only : MPI_SUM, MPI_PROD use libmpifx_module, only : mpifx_comm, mpifx_reduce, mpifx_reduceip - use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, is_equal + use fortuno_mpi, only : all_close, global_comm_id, suite => mpi_suite_item, test_list, is_equal $:FORTUNO_MPI_IMPORTS() implicit none @@ -26,11 +26,11 @@ contains $:TEST("array_prod") integer, parameter :: dp = kind(1.0d0) + integer, parameter :: max_valid_rank = 9 type(mpifx_comm) :: mycomm real(dp) :: valr(3), resvalr(3) - integer :: max_none_one_rank, max_valid_rank + integer :: max_none_one_rank - max_valid_rank = 9 call mycomm%init(global_comm_id()) if (mycomm%rank <= max_valid_rank) then valr(:) = [ real(mycomm%rank + 1, dp) * 1.2, & @@ -49,13 +49,11 @@ contains max_none_one_rank = max_valid_rank + 1 end if - @:ASSERT(abs(resvalr(1) - (gamma(real(max_none_one_rank + 1, kind=dp)) * (1.2)**(max_none_one_rank))) < abs((resvalr(1)*1e-6))) - @:ASSERT(abs(resvalr(2) - (gamma(real(max_none_one_rank + 1, kind=dp)) * (4.3)**(max_none_one_rank))) < abs((resvalr(2)*1e-6))) - @:ASSERT(abs(resvalr(3) - (gamma(real(max_none_one_rank + 1, kind=dp)) * (3.8)**(max_none_one_rank))) < abs((resvalr(3)*1e-6))) + @:ASSERT(all_close(resvalr, [gamma(real(max_none_one_rank + 1, kind=dp)) * (1.2)**(max_none_one_rank), & + & gamma(real(max_none_one_rank + 1, kind=dp)) * (4.3)**(max_none_one_rank), & + & gamma(real(max_none_one_rank + 1, kind=dp)) * (3.8)**(max_none_one_rank)], rtol=1e-6_dp)) else - @:ASSERT(resvalr(1) == 0.0_dp) - @:ASSERT(resvalr(2) == 0.0_dp) - @:ASSERT(resvalr(3) == 0.0_dp) + @:ASSERT(all_close(resvalr, [0.0_dp, 0.0_dp, 0.0_dp], rtol=0.0_dp)) end if $:END_TEST() @@ -70,13 +68,12 @@ contains call mpifx_reduceip(mycomm, resvalr, MPI_SUM) if (mycomm%lead) then - @:ASSERT(abs(resvalr(1) - (mycomm%size * (mycomm%size + 1)) / 2 * 1.2) < abs((resvalr(1)*1e-7))) - @:ASSERT(abs(resvalr(2) - (mycomm%size * (mycomm%size + 1)) / 2 * 4.3) < abs((resvalr(2)*1e-7))) - @:ASSERT(abs(resvalr(3) - (mycomm%size * (mycomm%size + 1)) / 2 * 3.8) < abs((resvalr(3)*1e-7))) + @:ASSERT(all_close(resvalr, [mycomm%size * (mycomm%size + 1) / 2 * 1.2_dp, & + & mycomm%size * (mycomm%size + 1) / 2 * 4.3_dp, mycomm%size * (mycomm%size + 1) / 2 * 3.8_dp], & + & rtol=1e-7_dp)) else - @:ASSERT(resvalr(1) == real(mycomm%rank + 1, dp) * 1.2) - @:ASSERT(resvalr(2) == real(mycomm%rank + 1, dp) * 4.3) - @:ASSERT(resvalr(3) == real(mycomm%rank + 1, dp) * 3.8) + @:ASSERT(all_close(resvalr, [real(mycomm%rank + 1, dp) * 1.2, real(mycomm%rank + 1, dp) * 4.3, & + & real(mycomm%rank + 1, dp) * 3.8], rtol=0.0_dp)) end if $:END_TEST() diff --git a/test/unit/test_scatter.fpp b/test/unit/test_scatter.fpp index 3ade7e0..f1e3f48 100644 --- a/test/unit/test_scatter.fpp +++ b/test/unit/test_scatter.fpp @@ -2,7 +2,7 @@ module test_scatter use libmpifx_module, only : mpifx_comm, mpifx_scatter - use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, is_equal + use fortuno_mpi, only : all_equal, global_comm_id, suite => mpi_suite_item, test_list, is_equal $:FORTUNO_MPI_IMPORTS() implicit none @@ -40,8 +40,7 @@ contains allocate(recv1(2), source = 0) call mpifx_scatter(mycomm, send1, recv1) - @:ASSERT(is_equal(recv1(1), 2*mycomm%rank + 1)) - @:ASSERT(is_equal(recv1(2), 2*mycomm%rank + 2)) + @:ASSERT(all_equal(recv1, [2*mycomm%rank + 1, 2*mycomm%rank + 2])) $:END_TEST() $:TEST("I2_to_I1") @@ -60,8 +59,7 @@ contains allocate(recv1(2), source = 0) call mpifx_scatter(mycomm, send2, recv1) - @:ASSERT(is_equal(recv1(1), 2*mycomm%rank + 1)) - @:ASSERT(is_equal(recv1(2), 2*mycomm%rank + 2)) + @:ASSERT(all_equal(recv1, [2*mycomm%rank + 1, 2*mycomm%rank + 2])) $:END_TEST() function tests() diff --git a/test/unit/test_scatterv.fpp b/test/unit/test_scatterv.fpp index 6677279..825f0f8 100644 --- a/test/unit/test_scatterv.fpp +++ b/test/unit/test_scatterv.fpp @@ -2,7 +2,7 @@ module test_scatterv use libmpifx_module, only : mpifx_comm, mpifx_scatterv - use fortuno_mpi, only : global_comm_id, suite => mpi_suite_item, test_list, is_equal + use fortuno_mpi, only : all_equal, global_comm_id, suite => mpi_suite_item, test_list, is_equal $:FORTUNO_MPI_IMPORTS() implicit none @@ -47,8 +47,7 @@ contains allocate(recv1(2), source = 0) call mpifx_scatterv(mycomm, send1, sendcount, recv1) - @:ASSERT(is_equal(recv1(1), 2*mycomm%rank + 1)) - @:ASSERT(is_equal(recv1(2), 2*mycomm%rank + 2)) + @:ASSERT(all_equal(recv1, [2*mycomm%rank + 1, 2*mycomm%rank + 2])) $:END_TEST() $:TEST("I2_to_I1") @@ -70,8 +69,7 @@ contains allocate(recv1(2), source = 0) call mpifx_scatterv(mycomm, send2, sendcount, recv1) - @:ASSERT(is_equal(recv1(1), 2*mycomm%rank + 1)) - @:ASSERT(is_equal(recv1(2), 2*mycomm%rank + 2)) + @:ASSERT(all_equal(recv1, [2*mycomm%rank + 1, 2*mycomm%rank + 2])) $:END_TEST() $:TEST("I1_to_I1_disp") diff --git a/test/unit/testapp.f90 b/test/unit/testapp.f90 index 44df4f9..4b17466 100644 --- a/test/unit/testapp.f90 +++ b/test/unit/testapp.f90 @@ -14,7 +14,7 @@ program testapp use test_send_recv, only : send_recv_tests => tests implicit none - call execute_mpi_cmd_app( + call execute_mpi_cmd_app(& test_list([& allgather_tests(),& allgatherv_tests(),& @@ -29,6 +29,6 @@ program testapp scatterv_tests(),& send_recv_tests()& ]& - ) + )) end program testapp