From: Augustin Degomme Date: Tue, 16 Jul 2013 16:53:10 +0000 (+0200) Subject: Add (some) mpich3 f77 tests X-Git-Tag: v3_9_90~130^2~5 X-Git-Url: http://info.iut-bm.univ-fcomte.fr/pub/gitweb/simgrid.git/commitdiff_plain/9deda161a84a426d0ea75ec4bd9b8cdc3a4b28fb Add (some) mpich3 f77 tests --- diff --git a/buildtools/Cmake/AddTests.cmake b/buildtools/Cmake/AddTests.cmake index 5bd343e5f6..e38d36e5af 100644 --- a/buildtools/Cmake/AddTests.cmake +++ b/buildtools/Cmake/AddTests.cmake @@ -464,7 +464,8 @@ if(NOT enable_memcheck) ADD_TEST(smpi-mpich3-datatype-raw ${CMAKE_COMMAND} -E chdir ${CMAKE_BINARY_DIR}/teshsuite/smpi/mpich3-test/datatype ${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/runtests -mpiexec=${CMAKE_BINARY_DIR}/smpi_script/bin/smpirun -srcdir=${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/datatype -tests=testlist -execarg=--cfg=contexts/factory:raw) ADD_TEST(smpi-mpich3-group-raw ${CMAKE_COMMAND} -E chdir ${CMAKE_BINARY_DIR}/teshsuite/smpi/mpich3-test/group ${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/runtests -mpiexec=${CMAKE_BINARY_DIR}/smpi_script/bin/smpirun -srcdir=${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/group -tests=testlist -execarg=--cfg=contexts/factory:raw) ADD_TEST(smpi-mpich3-pt2pt-raw ${CMAKE_COMMAND} -E chdir ${CMAKE_BINARY_DIR}/teshsuite/smpi/mpich3-test/pt2pt ${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/runtests -mpiexec=${CMAKE_BINARY_DIR}/smpi_script/bin/smpirun -srcdir=${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/pt2pt -tests=testlist -execarg=--cfg=contexts/factory:raw) - set_tests_properties(smpi-mpich3-attr-raw smpi-mpich3-coll-thread smpi-mpich3-coll-ompi-thread smpi-mpich3-coll-mpich-thread smpi-mpich3-comm-raw smpi-mpich3-init-raw smpi-mpich3-datatype-raw smpi-mpich3-pt2pt-raw smpi-mpich3-group-raw PROPERTIES PASS_REGULAR_EXPRESSION "tests passed!") + ADD_TEST(smpi-mpich3-thread-f77 ${CMAKE_COMMAND} -E chdir ${CMAKE_BINARY_DIR}/teshsuite/smpi/mpich3-test/f77/ ${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/runtests -mpiexec=${CMAKE_BINARY_DIR}/smpi_script/bin/smpirun -srcdir=${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/ -tests=testlist -execarg=--cfg=contexts/factory:thread) + set_tests_properties(smpi-mpich3-thread-f77 smpi-mpich3-attr-raw smpi-mpich3-coll-thread smpi-mpich3-coll-ompi-thread smpi-mpich3-coll-mpich-thread smpi-mpich3-comm-raw smpi-mpich3-init-raw smpi-mpich3-datatype-raw smpi-mpich3-pt2pt-raw smpi-mpich3-group-raw PROPERTIES PASS_REGULAR_EXPRESSION "tests passed!") endif() endif() diff --git a/buildtools/Cmake/DefinePackages.cmake b/buildtools/Cmake/DefinePackages.cmake index 830933efd3..a6b4b421d2 100644 --- a/buildtools/Cmake/DefinePackages.cmake +++ b/buildtools/Cmake/DefinePackages.cmake @@ -925,6 +925,18 @@ set(TESHSUITE_CMAKEFILES_TXT teshsuite/xbt/CMakeLists.txt ) +if(SMPI_F2C) + set(TESHSUITE_CMAKEFILES_TXT + ${TESHSUITE_CMAKEFILES_TXT} + teshsuite/smpi/mpich3-test/f77/comm/CMakeLists.txt + teshsuite/smpi/mpich3-test/f77/coll/CMakeLists.txt + teshsuite/smpi/mpich3-test/f77/pt2pt/CMakeLists.txt + teshsuite/smpi/mpich3-test/f77/datatype/CMakeLists.txt + teshsuite/smpi/mpich3-test/f77/ext/CMakeLists.txt + teshsuite/smpi/mpich3-test/f77/init/CMakeLists.txt + ) +endif() + set(TOOLS_CMAKEFILES_TXT tools/CMakeLists.txt tools/graphicator/CMakeLists.txt diff --git a/buildtools/Cmake/MakeExe.cmake b/buildtools/Cmake/MakeExe.cmake index 72800dca29..fac59a6a1c 100644 --- a/buildtools/Cmake/MakeExe.cmake +++ b/buildtools/Cmake/MakeExe.cmake @@ -93,8 +93,13 @@ add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/datatype) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/group) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/init) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/pt2pt) +add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/comm) +add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/coll) +add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/pt2pt) +add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/ext) +add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/datatype) +add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/init) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/xbt) - add_subdirectory(${CMAKE_HOME_DIRECTORY}/testsuite/surf) add_subdirectory(${CMAKE_HOME_DIRECTORY}/testsuite/xbt) diff --git a/teshsuite/smpi/mpich3-test/CMakeLists.txt b/teshsuite/smpi/mpich3-test/CMakeLists.txt index 802e555a6a..82b588bc1c 100644 --- a/teshsuite/smpi/mpich3-test/CMakeLists.txt +++ b/teshsuite/smpi/mpich3-test/CMakeLists.txt @@ -40,6 +40,7 @@ set(txt_files ${CMAKE_CURRENT_SOURCE_DIR}/hostfile ${CMAKE_CURRENT_SOURCE_DIR}/checktests ${CMAKE_CURRENT_SOURCE_DIR}/util/mtest.c + ${CMAKE_CURRENT_SOURCE_DIR}/f77/testlist ${CMAKE_CURRENT_SOURCE_DIR}/include/mpitestconf.h ${CMAKE_CURRENT_SOURCE_DIR}/include/mpitest.h PARENT_SCOPE) diff --git a/teshsuite/smpi/mpich3-test/f77/attr/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f77/attr/CMakeLists.txt new file mode 100644 index 0000000000..4ac5709bca --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/CMakeLists.txt @@ -0,0 +1,79 @@ +cmake_minimum_required(VERSION 2.6) + +if(enable_smpi) + if(WIN32) + set(CMAKE_C_FLAGS "-include ${CMAKE_HOME_DIRECTORY}/include/smpi/smpi_main.h") + else() + set(CMAKE_C_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpicc") + set(CMAKE_Fortran_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpiff") + endif() + + set(EXECUTABLE_OUTPUT_PATH "${CMAKE_CURRENT_BINARY_DIR}") + set(MPICH_FLAGS "-DHAVE_STDLIB_H=1 -DHAVE_UNISTD_H=1 -DHAVE_STRING_H=1 -DUSE_STDARG=1 -DHAVE_LONG_DOUBLE=1 -DHAVE_PROTOTYPES=1 -DHAVE_SIGNAL_H=1 -DHAVE_SIGACTION=1 -DHAVE_SLEEP=1 -DHAVE_SYSCONF=1 -Wno-error=unused-variable -Wno-implicit") + include_directories("${CMAKE_HOME_DIRECTORY}/include/smpi") + include_directories("${CMAKE_CURRENT_BINARY_DIR}/../../include/") + + add_executable(attrmpi1f attrmpi1f.f ../util/mtestf.f) + add_executable(baseattr2f baseattr2f.f ../util/mtestf.f) + add_executable(baseattrf baseattrf.f ../util/mtestf.f) + add_executable(commattr2f commattr2f.f ../util/mtestf.f) + add_executable(commattr3f commattr3f.f ../util/mtestf.f) + add_executable(commattrf commattrf.f ../util/mtestf.f) + add_executable(typeattr2f typeattr2f.f ../util/mtestf.f) + add_executable(typeattr3f typeattr3f.f ../util/mtestf.f) + add_executable(typeattrf typeattrf.f ../util/mtestf.f) + + target_link_libraries(attrmpi1f simgrid) + target_link_libraries(baseattr2f simgrid) + target_link_libraries(baseattrf simgrid) + target_link_libraries(commattr2f simgrid) + target_link_libraries(commattr3f simgrid) + target_link_libraries(commattrf simgrid) + target_link_libraries(typeattr2f simgrid) + target_link_libraries(typeattr3f simgrid) + target_link_libraries(typeattrf simgrid) + + + set_target_properties(attrmpi1f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(baseattr2f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(baseattrf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(commattr2f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(commattr3f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(commattrf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typeattr2f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typeattr3f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typeattrf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + +endif() + +set(tesh_files + ${tesh_files} + PARENT_SCOPE + ) +set(xml_files + ${xml_files} + PARENT_SCOPE + ) +set(examples_src + ${examples_src} + ${CMAKE_CURRENT_SOURCE_DIR}/attraints.h + ${CMAKE_CURRENT_SOURCE_DIR}/attrmpi1f.f + ${CMAKE_CURRENT_SOURCE_DIR}/baseattr2f.f + ${CMAKE_CURRENT_SOURCE_DIR}/baseattrf.f + ${CMAKE_CURRENT_SOURCE_DIR}/commattr2f.f + ${CMAKE_CURRENT_SOURCE_DIR}/commattr3f.f + ${CMAKE_CURRENT_SOURCE_DIR}/commattrf.f + ${CMAKE_CURRENT_SOURCE_DIR}/typeattr2f.f + ${CMAKE_CURRENT_SOURCE_DIR}/typeattr3f.f + ${CMAKE_CURRENT_SOURCE_DIR}/typeattrf.f + PARENT_SCOPE + ) +set(bin_files + ${bin_files} + PARENT_SCOPE + ) +set(txt_files + ${txt_files} + ${CMAKE_CURRENT_SOURCE_DIR}/testlist + PARENT_SCOPE + ) diff --git a/teshsuite/smpi/mpich3-test/f77/attr/attraints.h b/teshsuite/smpi/mpich3-test/f77/attr/attraints.h new file mode 100644 index 0000000000..182b04567a --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/attraints.h @@ -0,0 +1,6 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + integer extrastate, valin, valout, val diff --git a/teshsuite/smpi/mpich3-test/f77/attr/attrmpi1f.f b/teshsuite/smpi/mpich3-test/f77/attr/attrmpi1f.f new file mode 100644 index 0000000000..44e5b5e3e1 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/attrmpi1f.f @@ -0,0 +1,62 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer value, wsize, wrank, extra, mykey + integer rvalue, svalue, ncomm + logical flag + integer ierr, errs +C + errs = 0 + call mtest_init( ierr ) + call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr ) + call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr ) +C +C Simple attribute put and get +C + call mpi_keyval_create( MPI_NULL_COPY_FN, MPI_NULL_DELETE_FN, + $ mykey, extra,ierr ) + call mpi_attr_get( MPI_COMM_WORLD, mykey, value, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, + $ "Did not get flag==.false. for attribute that was not set" + endif +C + value = 1234567 + svalue = value + call mpi_attr_put( MPI_COMM_WORLD, mykey, value, ierr ) + value = -9876543 + call mpi_attr_get( MPI_COMM_WORLD, mykey, rvalue, flag, ierr ) + if (.not. flag) then + errs = errs + 1 + print *, "Did not find attribute after set" + else + if (rvalue .ne. svalue) then + errs = errs + 1 + print *, "Attribute value ", rvalue, " should be ", svalue + endif + endif + value = -123456 + svalue = value + call mpi_attr_put( MPI_COMM_WORLD, mykey, value, ierr ) + value = 987654 + call mpi_attr_get( MPI_COMM_WORLD, mykey, rvalue, flag, ierr ) + if (.not. flag) then + errs = errs + 1 + print *, "Did not find attribute after set (neg)" + else + if (rvalue .ne. svalue) then + errs = errs + 1 + print *, "Neg Attribute value ", rvalue," should be ",svalue + endif + endif +C + call mpi_keyval_free( mykey, ierr ) + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/attr/baseattr2f.f b/teshsuite/smpi/mpich3-test/f77/attr/baseattr2f.f new file mode 100644 index 0000000000..59d69bc94c --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/baseattr2f.f @@ -0,0 +1,113 @@ +C -*- Mode: Fortran; -*- +C +C +C (C) 2001 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer ierr, errs + logical flag + integer value, commsize, commrank + + errs = 0 + call mpi_init( ierr ) + + call mpi_comm_size( MPI_COMM_WORLD, commsize, ierr ) + call mpi_comm_rank( MPI_COMM_WORLD, commrank, ierr ) + + call mpi_attr_get( MPI_COMM_WORLD, MPI_TAG_UB, value, flag, ierr + $ ) + if (.not. flag) then + errs = errs + 1 + print *, "Could not get TAG_UB" + else + if (value .lt. 32767) then + errs = errs + 1 + print *, "Got too-small value (", value, ") for TAG_UB" + endif + endif + + call mpi_attr_get( MPI_COMM_WORLD, MPI_HOST, value, flag, ierr ) + if (.not. flag) then + errs = errs + 1 + print *, "Could not get HOST" + else + if ((value .lt. 0 .or. value .ge. commsize) .and. value .ne. + $ MPI_PROC_NULL) then + errs = errs + 1 + print *, "Got invalid value ", value, " for HOST" + endif + endif + + call mpi_attr_get( MPI_COMM_WORLD, MPI_IO, value, flag, ierr ) + if (.not. flag) then + errs = errs + 1 + print *, "Could not get IO" + else + if ((value .lt. 0 .or. value .ge. commsize) .and. value .ne. + $ MPI_ANY_SOURCE .and. value .ne. MPI_PROC_NULL) then + errs = errs + 1 + print *, "Got invalid value ", value, " for IO" + endif + endif + + call mpi_attr_get( MPI_COMM_WORLD, MPI_WTIME_IS_GLOBAL, value, + $ flag, ierr ) + if (flag) then +C Wtime need not be set + if (value .lt. 0 .or. value .gt. 1) then + errs = errs + 1 + print *, "Invalid value for WTIME_IS_GLOBAL (got ", value, + $ ")" + endif + endif + + call mpi_attr_get( MPI_COMM_WORLD, MPI_APPNUM, value, flag, ierr + $ ) +C appnum need not be set + if (flag) then + if (value .lt. 0) then + errs = errs + 1 + print *, "MPI_APPNUM is defined as ", value, + $ " but must be nonnegative" + endif + endif + + call mpi_attr_get( MPI_COMM_WORLD, MPI_UNIVERSE_SIZE, value, + $ flag, ierr ) +C MPI_UNIVERSE_SIZE need not be set + if (flag) then + if (value .lt. commsize) then + errs = errs + 1 + print *, "MPI_UNIVERSE_SIZE = ", value, + $ ", less than comm world (", commsize, ")" + endif + endif + + call mpi_attr_get( MPI_COMM_WORLD, MPI_LASTUSEDCODE, value, flag + $ , ierr ) +C Last used code must be defined and >= MPI_ERR_LASTCODE + if (flag) then + if (value .lt. MPI_ERR_LASTCODE) then + errs = errs + 1 + print *, "MPI_LASTUSEDCODE points to an integer (", + $ MPI_ERR_LASTCODE, ") smaller than MPI_ERR_LASTCODE (", + $ value, ")" + endif + else + errs = errs + 1 + print *, "MPI_LASTUSECODE is not defined" + endif + +C Check for errors + if (errs .eq. 0) then + print *, " No Errors" + else + print *, " Found ", errs, " errors" + endif + + call MPI_Finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/attr/baseattrf.f b/teshsuite/smpi/mpich3-test/f77/attr/baseattrf.f new file mode 100644 index 0000000000..36f520d855 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/baseattrf.f @@ -0,0 +1,63 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer value, commsize + logical flag + integer ierr, errs + + errs = 0 + call mpi_init( ierr ) + + call mpi_comm_size( MPI_COMM_WORLD, commsize, ierr ) + call mpi_attr_get( MPI_COMM_WORLD, MPI_UNIVERSE_SIZE, value, flag + $ , ierr) + ! MPI_UNIVERSE_SIZE need not be set + if (flag) then + if (value .lt. commsize) then + print *, "MPI_UNIVERSE_SIZE is ", value, " less than world " + $ , commsize + errs = errs + 1 + endif + endif + + call mpi_attr_get( MPI_COMM_WORLD, MPI_LASTUSEDCODE, value, flag, + $ ierr ) + ! Last used code must be defined and >= MPI_ERR_LASTCODE + if (flag) then + if (value .lt. MPI_ERR_LASTCODE) then + errs = errs + 1 + print *, "MPI_LASTUSEDCODE points to an integer + $ (", value, ") smaller than MPI_ERR_LASTCODE (", + $ MPI_ERR_LASTCODE, ")" + endif + else + errs = errs + 1 + print *, "MPI_LASTUSECODE is not defined" + endif + + call mpi_attr_get( MPI_COMM_WORLD, MPI_APPNUM, value, flag, ierr ) + ! appnum need not be set + if (flag) then + if (value .lt. 0) then + errs = errs + 1 + print *, "MPI_APPNUM is defined as ", value, + $ " but must be nonnegative" + endif + endif + + ! Check for errors + if (errs .eq. 0) then + print *, " No Errors" + else + print *, " Found ", errs, " errors" + endif + + call MPI_Finalize( ierr ) + + end + diff --git a/teshsuite/smpi/mpich3-test/f77/attr/commattr2f.f b/teshsuite/smpi/mpich3-test/f77/attr/commattr2f.f new file mode 100644 index 0000000000..92d47f9343 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/commattr2f.f @@ -0,0 +1,103 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C This is a modified version of commattrf.f that uses two of the +C default functions +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + include 'attraints.h' + integer comm1, comm2 + integer keyval + logical flag +C +C The only difference between the MPI-2 and MPI-1 attribute caching +C routines in Fortran is that the take an address-sized integer +C instead of a simple integer. These still are not pointers, +C so the values are still just integers. +C + errs = 0 + call mtest_init( ierr ) + call mpi_comm_dup( MPI_COMM_WORLD, comm1, ierr ) +C + extrastate = 1001 + call mpi_comm_create_keyval( MPI_COMM_DUP_FN, + & MPI_COMM_NULL_DELETE_FN, keyval, + & extrastate, ierr ) + flag = .true. + call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' get attr returned true when no attr set' + endif + + valin = 2003 + call mpi_comm_set_attr( comm1, keyval, valin, ierr ) + flag = .false. + valout = -1 + call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr ) + if (valout .ne. 2003) then + errs = errs + 1 + print *, 'Unexpected value (should be 2003)', valout, + & ' from attr' + endif + + valin = 2001 + call mpi_comm_set_attr( comm1, keyval, valin, ierr ) + flag = .false. + valout = -1 + call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr ) + if (valout .ne. 2001) then + errs = errs + 1 + print *, 'Unexpected value (should be 2001)', valout, + & ' from attr' + endif + +C +C Test the copy function + valin = 5001 + call mpi_comm_set_attr( comm1, keyval, valin, ierr ) + call mpi_comm_dup( comm1, comm2, ierr ) + flag = .false. + call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr ) + if (valout .ne. 5001) then + errs = errs + 1 + print *, 'Unexpected output value in comm ', valout + endif + flag = .false. + call mpi_comm_get_attr( comm2, keyval, valout, flag, ierr ) + if (valout .ne. 5001) then + errs = errs + 1 + print *, 'Unexpected output value in comm2 ', valout + endif +C Test the delete function + call mpi_comm_free( comm2, ierr ) +C +C Test the attr delete function + call mpi_comm_dup( comm1, comm2, ierr ) + valin = 6001 + extrastate = 1001 + call mpi_comm_set_attr( comm2, keyval, valin, ierr ) + call mpi_comm_delete_attr( comm2, keyval, ierr ) + flag = .true. + call mpi_comm_get_attr( comm2, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' Delete_attr did not delete attribute' + endif + call mpi_comm_free( comm2, ierr ) +C + ierr = -1 + call mpi_comm_free_keyval( keyval, ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + call mtestprinterror( ierr ) + endif + call mpi_comm_free( comm1, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/attr/commattr3f.f b/teshsuite/smpi/mpich3-test/f77/attr/commattr3f.f new file mode 100644 index 0000000000..cfa5ffb203 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/commattr3f.f @@ -0,0 +1,84 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2004 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C This tests the null copy function (returns flag false; thus the +C attribute should not be propagated to a dup'ed communicator +C This is must like the test in commattr2f +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + include 'attraints.h' + integer comm1, comm2 + integer keyval + logical flag +C +C The only difference between the MPI-2 and MPI-1 attribute caching +C routines in Fortran is that the take an address-sized integer +C instead of a simple integer. These still are not pointers, +C so the values are still just integers. +C + errs = 0 + call mtest_init( ierr ) + call mpi_comm_dup( MPI_COMM_WORLD, comm1, ierr ) +C + extrastate = 1001 + call mpi_comm_create_keyval( MPI_COMM_NULL_COPY_FN, + & MPI_COMM_NULL_DELETE_FN, keyval, + & extrastate, ierr ) + flag = .true. + call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' get attr returned true when no attr set' + endif + +C Test the null copy function + valin = 5001 + call mpi_comm_set_attr( comm1, keyval, valin, ierr ) + call mpi_comm_dup( comm1, comm2, ierr ) +C Because we set NULL_COPY_FN, the attribute should not +C appear on the dup'ed communicator + flag = .false. + call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr ) + if (valout .ne. 5001) then + errs = errs + 1 + print *, 'Unexpected output value in comm ', valout + endif + flag = .true. + call mpi_comm_get_attr( comm2, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' Attribute incorrectly present on dup communicator' + endif +C Test the delete function + call mpi_comm_free( comm2, ierr ) +C +C Test the attr delete function + call mpi_comm_dup( comm1, comm2, ierr ) + valin = 6001 + extrastate = 1001 + call mpi_comm_set_attr( comm2, keyval, valin, ierr ) + call mpi_comm_delete_attr( comm2, keyval, ierr ) + flag = .true. + call mpi_comm_get_attr( comm2, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' Delete_attr did not delete attribute' + endif + call mpi_comm_free( comm2, ierr ) +C + ierr = -1 + call mpi_comm_free_keyval( keyval, ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + call mtestprinterror( ierr ) + endif + call mpi_comm_free( comm1, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/attr/commattrf.f b/teshsuite/smpi/mpich3-test/f77/attr/commattrf.f new file mode 100644 index 0000000000..491ec88098 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/commattrf.f @@ -0,0 +1,154 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + include 'attraints.h' + integer comm1, comm2 + integer curcount, keyval + logical flag + external mycopyfn, mydelfn + integer callcount, delcount + common /myattr/ callcount, delcount +C +C The only difference between the MPI-2 and MPI-1 attribute caching +C routines in Fortran is that the take an address-sized integer +C instead of a simple integer. These still are not pointers, +C so the values are still just integers. +C + errs = 0 + callcount = 0 + delcount = 0 + call mtest_init( ierr ) + call mpi_comm_dup( MPI_COMM_WORLD, comm1, ierr ) +C + extrastate = 1001 + call mpi_comm_create_keyval( mycopyfn, mydelfn, keyval, + & extrastate, ierr ) + flag = .true. + call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' get attr returned true when no attr set' + endif + + valin = 2003 + call mpi_comm_set_attr( comm1, keyval, valin, ierr ) + flag = .false. + valout = -1 + call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr ) + if (valout .ne. 2003) then + errs = errs + 1 + print *, 'Unexpected value (should be 2003)', valout, + & ' from attr' + endif + + valin = 2001 + call mpi_comm_set_attr( comm1, keyval, valin, ierr ) + flag = .false. + valout = -1 + call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr ) + if (valout .ne. 2001) then + errs = errs + 1 + print *, 'Unexpected value (should be 2001)', valout, + & ' from attr' + endif + +C +C Test the copy function + valin = 5001 + call mpi_comm_set_attr( comm1, keyval, valin, ierr ) + call mpi_comm_dup( comm1, comm2, ierr ) + flag = .false. + call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr ) + if (valout .ne. 5001) then + errs = errs + 1 + print *, 'Unexpected output value in comm ', valout + endif + flag = .false. + call mpi_comm_get_attr( comm2, keyval, valout, flag, ierr ) + if (valout .ne. 5003) then + errs = errs + 1 + print *, 'Unexpected output value in comm2 ', valout + endif +C Test the delete function + curcount = delcount + call mpi_comm_free( comm2, ierr ) + if (delcount .ne. curcount + 1) then + errs = errs + 1 + print *, ' did not get expected value of delcount ', + & delcount, curcount + 1 + endif +C +C Test the attr delete function + call mpi_comm_dup( comm1, comm2, ierr ) + valin = 6001 + extrastate = 1001 + call mpi_comm_set_attr( comm2, keyval, valin, ierr ) + delcount = 0 + call mpi_comm_delete_attr( comm2, keyval, ierr ) + if (delcount .ne. 1) then + errs = errs + 1 + print *, ' Delete_attr did not call delete function' + endif + flag = .true. + call mpi_comm_get_attr( comm2, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' Delete_attr did not delete attribute' + endif + call mpi_comm_free( comm2, ierr ) +C + ierr = -1 + call mpi_comm_free_keyval( keyval, ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + call mtestprinterror( ierr ) + endif + call mpi_comm_free( comm1, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end +C + subroutine mycopyfn( oldcomm, keyval, extrastate, valin, valout, + & flag, ierr ) + implicit none + include 'mpif.h' + integer oldcomm, keyval, ierr + include 'attraints.h' + logical flag + integer callcount, delcount + common /myattr/ callcount, delcount +C increment the attribute by 2 + valout = valin + 2 + callcount = callcount + 1 + if (extrastate .eq. 1001) then + flag = .true. + ierr = MPI_SUCCESS + else + print *, ' Unexpected value of extrastate = ', extrastate + flag = .false. + ierr = MPI_ERR_OTHER + endif + end +C + subroutine mydelfn( comm, keyval, val, extrastate, ierr ) + implicit none + include 'mpif.h' + integer comm, keyval, ierr + include 'attraints.h' + integer callcount, delcount + common /myattr/ callcount, delcount + delcount = delcount + 1 + if (extrastate .eq. 1001) then + ierr = MPI_SUCCESS + else + print *, ' Unexpected value of extrastate = ', extrastate + ierr = MPI_ERR_OTHER + endif + end diff --git a/teshsuite/smpi/mpich3-test/f77/attr/testlist b/teshsuite/smpi/mpich3-test/f77/attr/testlist new file mode 100644 index 0000000000..27d9d59c21 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/testlist @@ -0,0 +1,9 @@ +attrmpi1f 1 +baseattrf 1 +baseattr2f 1 +commattrf 1 +commattr2f 1 +commattr3f 1 +typeattrf 1 +typeattr2f 1 +typeattr3f 1 diff --git a/teshsuite/smpi/mpich3-test/f77/attr/typeattr2f.f b/teshsuite/smpi/mpich3-test/f77/attr/typeattr2f.f new file mode 100644 index 0000000000..5fbbdbbf52 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/typeattr2f.f @@ -0,0 +1,102 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C This is a modified version of typeattrf.f that uses two of the +C default functions +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + include 'attraints.h' + integer type1, type2 + integer keyval + logical flag +C +C The only difference between the MPI-2 and MPI-1 attribute caching +C routines in Fortran is that the take an address-sized integer +C instead of a simple integer. These still are not pointers, +C so the values are still just integers. +C + errs = 0 + call mtest_init( ierr ) + type1 = MPI_INTEGER +C + extrastate = 1001 + call mpi_type_create_keyval( MPI_TYPE_DUP_FN, + & MPI_TYPE_NULL_DELETE_FN, keyval, + & extrastate, ierr ) + flag = .true. + call mpi_type_get_attr( type1, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' get attr returned true when no attr set' + endif + + valin = 2003 + call mpi_type_set_attr( type1, keyval, valin, ierr ) + flag = .false. + valout = -1 + call mpi_type_get_attr( type1, keyval, valout, flag, ierr ) + if (valout .ne. 2003) then + errs = errs + 1 + print *, 'Unexpected value (should be 2003)', valout, + & ' from attr' + endif + + valin = 2001 + call mpi_type_set_attr( type1, keyval, valin, ierr ) + flag = .false. + valout = -1 + call mpi_type_get_attr( type1, keyval, valout, flag, ierr ) + if (valout .ne. 2001) then + errs = errs + 1 + print *, 'Unexpected value (should be 2001)', valout, + & ' from attr' + endif + +C +C Test the copy function + valin = 5001 + call mpi_type_set_attr( type1, keyval, valin, ierr ) + call mpi_type_dup( type1, type2, ierr ) + flag = .false. + call mpi_type_get_attr( type1, keyval, valout, flag, ierr ) + if (valout .ne. 5001) then + errs = errs + 1 + print *, 'Unexpected output value in type ', valout + endif + flag = .false. + call mpi_type_get_attr( type2, keyval, valout, flag, ierr ) + if (valout .ne. 5001) then + errs = errs + 1 + print *, 'Unexpected output value in type2 ', valout + endif +C Test the delete function + call mpi_type_free( type2, ierr ) +C +C Test the attr delete function + call mpi_type_dup( type1, type2, ierr ) + valin = 6001 + extrastate = 1001 + call mpi_type_set_attr( type2, keyval, valin, ierr ) + call mpi_type_delete_attr( type2, keyval, ierr ) + flag = .true. + call mpi_type_get_attr( type2, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' Delete_attr did not delete attribute' + endif + call mpi_type_free( type2, ierr ) +C + ierr = -1 + call mpi_type_free_keyval( keyval, ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + call mtestprinterror( ierr ) + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/attr/typeattr3f.f b/teshsuite/smpi/mpich3-test/f77/attr/typeattr3f.f new file mode 100644 index 0000000000..5d30e70f61 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/typeattr3f.f @@ -0,0 +1,83 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2004 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C This tests the null copy function (returns flag false; thus the +C attribute should not be propagated to a dup'ed communicator +C This is much like the test in typeattr2f +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + include 'attraints.h' + integer type1, type2 + integer keyval + logical flag +C +C The only difference between the MPI-2 and MPI-1 attribute caching +C routines in Fortran is that the take an address-sized integer +C instead of a simple integer. These still are not pointers, +C so the values are still just integers. +C + errs = 0 + call mtest_init( ierr ) + type1 = MPI_INTEGER +C + extrastate = 1001 + call mpi_type_create_keyval( MPI_TYPE_NULL_COPY_FN, + & MPI_TYPE_NULL_DELETE_FN, keyval, + & extrastate, ierr ) + flag = .true. + call mpi_type_get_attr( type1, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' get attr returned true when no attr set' + endif + +C Test the null copy function + valin = 5001 + call mpi_type_set_attr( type1, keyval, valin, ierr ) + call mpi_type_dup( type1, type2, ierr ) +C Because we set NULL_COPY_FN, the attribute should not +C appear on the dup'ed communicator + flag = .false. + call mpi_type_get_attr( type1, keyval, valout, flag, ierr ) + if (valout .ne. 5001) then + errs = errs + 1 + print *, 'Unexpected output value in type ', valout + endif + flag = .true. + call mpi_type_get_attr( type2, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' Attribute incorrectly present on dup datatype' + endif +C Test the delete function + call mpi_type_free( type2, ierr ) +C +C Test the attr delete function + call mpi_type_dup( type1, type2, ierr ) + valin = 6001 + extrastate = 1001 + call mpi_type_set_attr( type2, keyval, valin, ierr ) + call mpi_type_delete_attr( type2, keyval, ierr ) + flag = .true. + call mpi_type_get_attr( type2, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' Delete_attr did not delete attribute' + endif + call mpi_type_free( type2, ierr ) +C + ierr = -1 + call mpi_type_free_keyval( keyval, ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + call mtestprinterror( ierr ) + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/attr/typeattrf.f b/teshsuite/smpi/mpich3-test/f77/attr/typeattrf.f new file mode 100644 index 0000000000..78aaa35929 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/typeattrf.f @@ -0,0 +1,155 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + include 'attraints.h' + integer comm + integer type1, type2 + integer curcount, keyval + logical flag + external mycopyfn, mydelfn + integer callcount, delcount + common /myattr/ callcount, delcount +C +C The only difference between the MPI-2 and MPI-1 attribute caching +C routines in Fortran is that the take an address-sized integer +C instead of a simple integer. These still are not pointers, +C so the values are still just integers. +C + errs = 0 + callcount = 0 + delcount = 0 + call mtest_init( ierr ) +C +C Attach an attribute to a predefined object + type1 = MPI_INTEGER + extrastate = 1001 + call mpi_type_create_keyval( mycopyfn, mydelfn, keyval, + & extrastate, ierr ) + flag = .true. + call mpi_type_get_attr( type1, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' get attr returned true when no attr set' + endif + + valin = 2003 + call mpi_type_set_attr( type1, keyval, valin, ierr ) + flag = .false. + valout = -1 + call mpi_type_get_attr( type1, keyval, valout, flag, ierr ) + if (valout .ne. 2003) then + errs = errs + 1 + print *, 'Unexpected value (should be 2003)', valout, + & ' from attr' + endif + + valin = 2001 + call mpi_type_set_attr( type1, keyval, valin, ierr ) + flag = .false. + valout = -1 + call mpi_type_get_attr( type1, keyval, valout, flag, ierr ) + if (valout .ne. 2001) then + errs = errs + 1 + print *, 'Unexpected value (should be 2001)', valout, + & ' from attr' + endif + +C +C Test the copy function + valin = 5001 + call mpi_type_set_attr( type1, keyval, valin, ierr ) + call mpi_type_dup( type1, type2, ierr ) + flag = .false. + call mpi_type_get_attr( type1, keyval, valout, flag, ierr ) + if (valout .ne. 5001) then + errs = errs + 1 + print *, 'Unexpected output value in type ', valout + endif + flag = .false. + call mpi_type_get_attr( type2, keyval, valout, flag, ierr ) + if (valout .ne. 5003) then + errs = errs + 1 + print *, 'Unexpected output value in type2 ', valout + endif +C Test the delete function + curcount = delcount + call mpi_type_free( type2, ierr ) + if (delcount .ne. curcount + 1) then + errs = errs + 1 + print *, ' did not get expected value of delcount ', + & delcount, curcount + 1 + endif +C +C Test the attr delete function + call mpi_type_dup( type1, type2, ierr ) + valin = 6001 + extrastate = 1001 + call mpi_type_set_attr( type2, keyval, valin, ierr ) + delcount = 0 + call mpi_type_delete_attr( type2, keyval, ierr ) + if (delcount .ne. 1) then + errs = errs + 1 + print *, ' Delete_attr did not call delete function' + endif + flag = .true. + call mpi_type_get_attr( type2, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' Delete_attr did not delete attribute' + endif + call mpi_type_free( type2, ierr ) + + ierr = -1 + call mpi_type_free_keyval( keyval, ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + call mtestprinterror( ierr ) + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end +C + subroutine mycopyfn( oldtype, keyval, extrastate, valin, valout, + & flag, ierr ) + implicit none + include 'mpif.h' + integer oldtype, keyval, ierr + include 'attraints.h' + logical flag + integer callcount, delcount + common /myattr/ callcount, delcount +C increment the attribute by 2 + valout = valin + 2 + callcount = callcount + 1 + if (extrastate .eq. 1001) then + flag = .true. + ierr = MPI_SUCCESS + else + print *, ' Unexpected value of extrastate = ', extrastate + flag = .false. + ierr = MPI_ERR_OTHER + endif + end +C + subroutine mydelfn( type, keyval, val, extrastate, ierr ) + implicit none + include 'mpif.h' + integer type, keyval, ierr + include 'attraints.h' + integer callcount, delcount + common /myattr/ callcount, delcount + delcount = delcount + 1 + if (extrastate .eq. 1001) then + ierr = MPI_SUCCESS + else + print *, ' Unexpected value of extrastate = ', extrastate + ierr = MPI_ERR_OTHER + endif + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f77/coll/CMakeLists.txt new file mode 100644 index 0000000000..4b1c593519 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/CMakeLists.txt @@ -0,0 +1,103 @@ +cmake_minimum_required(VERSION 2.6) + +if(enable_smpi) + if(WIN32) + set(CMAKE_C_FLAGS "-include ${CMAKE_HOME_DIRECTORY}/include/smpi/smpi_main.h") + else() + set(CMAKE_C_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpicc") + set(CMAKE_Fortran_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpiff") + endif() + + set(EXECUTABLE_OUTPUT_PATH "${CMAKE_CURRENT_BINARY_DIR}") + set(MPICH_FLAGS "-DHAVE_STDLIB_H=1 -DHAVE_UNISTD_H=1 -DHAVE_STRING_H=1 -DUSE_STDARG=1 -DHAVE_LONG_DOUBLE=1 -DHAVE_PROTOTYPES=1 -DHAVE_SIGNAL_H=1 -DHAVE_SIGACTION=1 -DHAVE_SLEEP=1 -DHAVE_SYSCONF=1 -Wno-error=unused-variable -Wno-implicit -g") + include_directories("${CMAKE_HOME_DIRECTORY}/include/smpi") + include_directories("${CMAKE_CURRENT_BINARY_DIR}/../include/") + + + add_executable(allredint8f allredint8f.f ../util/mtestf.f) + add_executable(allredopttf allredopttf.f ../util/mtestf.f) + add_executable(alltoallvf alltoallvf.f ../util/mtestf.f) + add_executable(alltoallwf alltoallwf.f ../util/mtestf.f) + add_executable(exscanf exscanf.f ../util/mtestf.f) + add_executable(inplacef inplacef.f ../util/mtestf.f) + # add_executable(nonblockingf nonblockingf.f ../util/mtestf.f) + # add_executable(nonblocking_inpf nonblocking_inpf.f ../util/mtestf.f) + add_executable(red_scat_blockf red_scat_blockf.f ../util/mtestf.f) + add_executable(redscatf redscatf.f ../util/mtestf.f) + add_executable(reducelocalf reducelocalf.f ../util/mtestf.f) + add_executable(split_typef split_typef.f ../util/mtestf.f) + add_executable(uallreducef uallreducef.f ../util/mtestf.f) + add_executable(vw_inplacef vw_inplacef.f ../util/mtestf.f) + + + + target_link_libraries(allredint8f simgrid) + target_link_libraries(allredopttf simgrid) + target_link_libraries(alltoallvf simgrid) + target_link_libraries(alltoallwf simgrid) + target_link_libraries(exscanf simgrid) + target_link_libraries(inplacef simgrid) + # target_link_libraries(nonblockingf simgrid) + # target_link_libraries(nonblocking_inpf simgrid) + target_link_libraries(red_scat_blockf simgrid) + target_link_libraries(redscatf simgrid) + target_link_libraries(reducelocalf simgrid) + target_link_libraries(split_typef simgrid) + target_link_libraries(uallreducef simgrid) + target_link_libraries(vw_inplacef simgrid) + + + + set_target_properties(allredint8f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(allredopttf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(alltoallvf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(alltoallwf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(exscanf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(inplacef PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") +# set_target_properties(nonblockingf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") +# set_target_properties(nonblocking_inpf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(red_scat_blockf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(redscatf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(reducelocalf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(split_typef PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(uallreducef PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(vw_inplacef PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + +endif() + +set(tesh_files + ${tesh_files} + PARENT_SCOPE + ) +set(xml_files + ${xml_files} + PARENT_SCOPE + ) +set(examples_src + ${examples_src} + ${CMAKE_CURRENT_SOURCE_DIR}/allredint8f.f + ${CMAKE_CURRENT_SOURCE_DIR}/allredopttf.f + ${CMAKE_CURRENT_SOURCE_DIR}/alltoallvf.f + ${CMAKE_CURRENT_SOURCE_DIR}/alltoallwf.f + ${CMAKE_CURRENT_SOURCE_DIR}/exscanf.f + ${CMAKE_CURRENT_SOURCE_DIR}/inplacef.f + ${CMAKE_CURRENT_SOURCE_DIR}/nonblockingf.f + ${CMAKE_CURRENT_SOURCE_DIR}/nonblocking_inpf.f + ${CMAKE_CURRENT_SOURCE_DIR}/red_scat_blockf.f + ${CMAKE_CURRENT_SOURCE_DIR}/redscatf.f + ${CMAKE_CURRENT_SOURCE_DIR}/reducelocalf.f + ${CMAKE_CURRENT_SOURCE_DIR}/split_typef.f + ${CMAKE_CURRENT_SOURCE_DIR}/uallreducef.f + ${CMAKE_CURRENT_SOURCE_DIR}/vw_inplacef.f + PARENT_SCOPE + ) +set(bin_files + ${bin_files} + PARENT_SCOPE + ) +set(txt_files + ${txt_files} + ${CMAKE_CURRENT_SOURCE_DIR}/runtests + ${CMAKE_CURRENT_SOURCE_DIR}/testlist + PARENT_SCOPE + ) diff --git a/teshsuite/smpi/mpich3-test/f77/coll/allredint8f.f b/teshsuite/smpi/mpich3-test/f77/coll/allredint8f.f new file mode 100644 index 0000000000..10ece8700e --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/allredint8f.f @@ -0,0 +1,23 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2006 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer*8 inbuf, outbuf + integer errs, ierr + + errs = 0 + + call mtest_init( ierr ) +C +C A simple test of allreduce for the optional integer*8 type + + call mpi_allreduce(inbuf, outbuf, 1, MPI_INTEGER8, MPI_SUM, + & MPI_COMM_WORLD, ierr) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/allredopttf.f b/teshsuite/smpi/mpich3-test/f77/coll/allredopttf.f new file mode 100644 index 0000000000..1b71c8d2a7 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/allredopttf.f @@ -0,0 +1,46 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2007 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer*8 inbuf, outbuf + double complex zinbuf, zoutbuf + integer wsize + integer errs, ierr + + errs = 0 + + call mtest_init( ierr ) + call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr ) +C +C A simple test of allreduce for the optional integer*8 type + + inbuf = 1 + outbuf = 0 + call mpi_allreduce(inbuf, outbuf, 1, MPI_INTEGER8, MPI_SUM, + & MPI_COMM_WORLD, ierr) + if (outbuf .ne. wsize ) then + errs = errs + 1 + print *, "result wrong for sum with integer*8 = got ", outbuf, + & " but should have ", wsize + endif + zinbuf = (1,1) + zoutbuf = (0,0) + call mpi_allreduce(zinbuf, zoutbuf, 1, MPI_DOUBLE_COMPLEX, + & MPI_SUM, MPI_COMM_WORLD, ierr) + if (dreal(zoutbuf) .ne. wsize ) then + errs = errs + 1 + print *, "result wrong for sum with double complex = got ", + & outbuf, " but should have ", wsize + endif + if (dimag(zoutbuf) .ne. wsize ) then + errs = errs + 1 + print *, "result wrong for sum with double complex = got ", + & outbuf, " but should have ", wsize + endif + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/alltoallvf.f b/teshsuite/smpi/mpich3-test/f77/coll/alltoallvf.f new file mode 100644 index 0000000000..0a2831a1f6 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/alltoallvf.f @@ -0,0 +1,146 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2011 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer ierr, errs + integer i, ans, size, rank, color, comm, newcomm + integer maxSize, displ + parameter (maxSize=128) + integer scounts(maxSize), sdispls(maxSize), stypes(maxSize) + integer rcounts(maxSize), rdispls(maxSize), rtypes(maxSize) + integer sbuf(maxSize), rbuf(maxSize) + + errs = 0 + + call mtest_init( ierr ) + +C Get a comm + call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr ) + call mpi_comm_size( comm, size, ierr ) + if (size .gt. maxSize) then + call mpi_comm_rank( comm, rank, ierr ) + color = 1 + if (rank .lt. maxSize) color = 0 + call mpi_comm_split( comm, color, rank, newcomm, ierr ) + call mpi_comm_free( comm, ierr ) + comm = newcomm + call mpi_comm_size( comm, size, ierr ) + endif + call mpi_comm_rank( comm, rank, ierr ) +C + if (size .le. maxSize) then +C Initialize the data. Just use this as an all to all +C Use the same test as alltoallwf.c , except displacements are in units of +C integers instead of bytes + do i=1, size + scounts(i) = 1 + sdispls(i) = (i-1) + stypes(i) = MPI_INTEGER + sbuf(i) = rank * size + i + rcounts(i) = 1 + rdispls(i) = (i-1) + rtypes(i) = MPI_INTEGER + rbuf(i) = -1 + enddo + call mpi_alltoallv( sbuf, scounts, sdispls, stypes, + & rbuf, rcounts, rdispls, rtypes, comm, ierr ) +C +C check rbuf(i) = data from the ith location of the ith send buf, or +C rbuf(i) = (i-1) * size + i + do i=1, size + ans = (i-1) * size + rank + 1 + if (rbuf(i) .ne. ans) then + errs = errs + 1 + print *, rank, ' rbuf(', i, ') = ', rbuf(i), + & ' expected ', ans + endif + enddo +C +C A halo-exchange example - mostly zero counts +C + do i=1, size + scounts(i) = 0 + sdispls(i) = 0 + stypes(i) = MPI_INTEGER + sbuf(i) = -1 + rcounts(i) = 0 + rdispls(i) = 0 + rtypes(i) = MPI_INTEGER + rbuf(i) = -1 + enddo + +C +C Note that the arrays are 1-origin + displ = 0 + if (rank .gt. 0) then + scounts(1+rank-1) = 1 + rcounts(1+rank-1) = 1 + sdispls(1+rank-1) = displ + rdispls(1+rank-1) = rank - 1 + sbuf(1+displ) = rank + displ = displ + 1 + endif + scounts(1+rank) = 1 + rcounts(1+rank) = 1 + sdispls(1+rank) = displ + rdispls(1+rank) = rank + sbuf(1+displ) = rank + displ = displ + 1 + if (rank .lt. size-1) then + scounts(1+rank+1) = 1 + rcounts(1+rank+1) = 1 + sdispls(1+rank+1) = displ + rdispls(1+rank+1) = rank+1 + sbuf(1+displ) = rank + displ = displ + 1 + endif + + call mpi_alltoallv( sbuf, scounts, sdispls, stypes, + & rbuf, rcounts, rdispls, rtypes, comm, ierr ) +C +C Check the neighbor values are correctly moved +C + if (rank .gt. 0) then + if (rbuf(1+rank-1) .ne. rank-1) then + errs = errs + 1 + print *, rank, ' rbuf(',1+rank-1, ') = ', rbuf(1+rank-1), + & 'expected ', rank-1 + endif + endif + if (rbuf(1+rank) .ne. rank) then + errs = errs + 1 + print *, rank, ' rbuf(', 1+rank, ') = ', rbuf(1+rank), + & 'expected ', rank + endif + if (rank .lt. size-1) then + if (rbuf(1+rank+1) .ne. rank+1) then + errs = errs + 1 + print *, rank, ' rbuf(', 1+rank+1, ') = ',rbuf(1+rank+1), + & 'expected ', rank+1 + endif + endif + do i=0,rank-2 + if (rbuf(1+i) .ne. -1) then + errs = errs + 1 + print *, rank, ' rbuf(', 1+i, ') = ', rbuf(1+i), + & 'expected -1' + endif + enddo + do i=rank+2,size-1 + if (rbuf(1+i) .ne. -1) then + errs = errs + 1 + print *, rank, ' rbuf(', i, ') = ', rbuf(1+i), + & 'expected -1' + endif + enddo + endif + call mpi_comm_free( comm, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end + diff --git a/teshsuite/smpi/mpich3-test/f77/coll/alltoallwf.f b/teshsuite/smpi/mpich3-test/f77/coll/alltoallwf.f new file mode 100644 index 0000000000..7ab0d60f57 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/alltoallwf.f @@ -0,0 +1,67 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer ierr, errs + integer i, intsize, ans, size, rank, color, comm, newcomm + integer maxSize + parameter (maxSize=32) + integer scounts(maxSize), sdispls(maxSize), stypes(maxSize) + integer rcounts(maxSize), rdispls(maxSize), rtypes(maxSize) + integer sbuf(maxSize), rbuf(maxSize) + errs = 0 + + call mtest_init( ierr ) + + call mpi_type_size( MPI_INTEGER, intsize, ierr ) + +C Get a comm + call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr ) + call mpi_comm_size( comm, size, ierr ) + if (size .gt. maxSize) then + call mpi_comm_rank( comm, rank, ierr ) + color = 1 + if (rank .lt. maxSize) color = 0 + call mpi_comm_split( comm, color, rank, newcomm, ierr ) + call mpi_comm_free( comm, ierr ) + comm = newcomm + call mpi_comm_size( comm, size, ierr ) + endif + call mpi_comm_rank( comm, rank, ierr ) + + if (size .le. maxSize) then +C Initialize the data. Just use this as an all to all + do i=1, size + scounts(i) = 1 + sdispls(i) = (i-1)*intsize + stypes(i) = MPI_INTEGER + sbuf(i) = rank * size + i + rcounts(i) = 1 + rdispls(i) = (i-1)*intsize + rtypes(i) = MPI_INTEGER + rbuf(i) = -1 + enddo + call mpi_alltoallw( sbuf, scounts, sdispls, stypes, + & rbuf, rcounts, rdispls, rtypes, comm, ierr ) +C +C check rbuf(i) = data from the ith location of the ith send buf, or +C rbuf(i) = (i-1) * size + i + do i=1, size + ans = (i-1) * size + rank + 1 + if (rbuf(i) .ne. ans) then + errs = errs + 1 + print *, rank, ' rbuf(', i, ') = ', rbuf(i), + & ' expected ', ans + endif + enddo + endif + call mpi_comm_free( comm, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end + diff --git a/teshsuite/smpi/mpich3-test/f77/coll/exscanf.f b/teshsuite/smpi/mpich3-test/f77/coll/exscanf.f new file mode 100644 index 0000000000..5e6f64e63e --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/exscanf.f @@ -0,0 +1,107 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + subroutine uop( cin, cout, count, datatype ) + implicit none + include 'mpif.h' + integer cin(*), cout(*) + integer count, datatype + integer i + +! if (datatype .ne. MPI_INTEGER) then +! write(6,*) 'Invalid datatype passed to user_op()' +! return +! endif + + do i=1, count + cout(i) = cin(i) + cout(i) + enddo + end +C + program main + implicit none + include 'mpif.h' + integer inbuf(2), outbuf(2) + integer ans, rank, size, comm + integer errs, ierr + integer sumop + external uop + + errs = 0 + + call mtest_init( ierr ) +C +C A simple test of exscan + comm = MPI_COMM_WORLD + + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + + inbuf(1) = rank + inbuf(2) = -rank + call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, MPI_SUM, comm, + & ierr ) +C this process has the sum of i from 0 to rank-1, which is +C (rank)(rank-1)/2 and -i + ans = (rank * (rank - 1))/2 + if (rank .gt. 0) then + if (outbuf(1) .ne. ans) then + errs = errs + 1 + print *, rank, ' Expected ', ans, ' got ', outbuf(1) + endif + if (outbuf(2) .ne. -ans) then + errs = errs + 1 + print *, rank, ' Expected ', -ans, ' got ', outbuf(1) + endif + endif +C +C Try a user-defined operation +C + call mpi_op_create( uop, .true., sumop, ierr ) + inbuf(1) = rank + inbuf(2) = -rank + call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, sumop, comm, + & ierr ) +C this process has the sum of i from 0 to rank-1, which is +C (rank)(rank-1)/2 and -i + ans = (rank * (rank - 1))/2 + if (rank .gt. 0) then + if (outbuf(1) .ne. ans) then + errs = errs + 1 + print *, rank, ' sumop: Expected ', ans, ' got ', outbuf(1) + endif + if (outbuf(2) .ne. -ans) then + errs = errs + 1 + print *, rank, ' sumop: Expected ', -ans, ' got ', outbuf(1) + endif + endif + call mpi_op_free( sumop, ierr ) + +C +C Try a user-defined operation (and don't claim it is commutative) +C + call mpi_op_create( uop, .false., sumop, ierr ) + inbuf(1) = rank + inbuf(2) = -rank + call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, sumop, comm, + & ierr ) +C this process has the sum of i from 0 to rank-1, which is +C (rank)(rank-1)/2 and -i + ans = (rank * (rank - 1))/2 + if (rank .gt. 0) then + if (outbuf(1) .ne. ans) then + errs = errs + 1 + print *, rank, ' sumop2: Expected ', ans, ' got ', outbuf(1) + endif + if (outbuf(2) .ne. -ans) then + errs = errs + 1 + print *, rank, ' sumop2: Expected ', -ans, ' got ',outbuf(1) + endif + endif + call mpi_op_free( sumop, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/inplacef.f b/teshsuite/smpi/mpich3-test/f77/coll/inplacef.f new file mode 100644 index 0000000000..230cccb37a --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/inplacef.f @@ -0,0 +1,91 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2005 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C This is a simple test that Fortran support the MPI_IN_PLACE value +C + program main + implicit none + include 'mpif.h' + integer ierr, errs + integer comm, root + integer rank, size + integer i + integer MAX_SIZE + parameter (MAX_SIZE=1024) + integer rbuf(MAX_SIZE), rdispls(MAX_SIZE), rcount(MAX_SIZE), + $ sbuf(MAX_SIZE) + + errs = 0 + call mtest_init( ierr ) + + comm = MPI_COMM_WORLD + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + + root = 0 +C Gather with inplace + do i=1,size + rbuf(i) = - i + enddo + rbuf(1+root) = root + if (rank .eq. root) then + call mpi_gather( MPI_IN_PLACE, 1, MPI_INTEGER, rbuf, 1, + $ MPI_INTEGER, root, comm, ierr ) + do i=1,size + if (rbuf(i) .ne. i-1) then + errs = errs + 1 + print *, '[',rank,'] rbuf(', i, ') = ', rbuf(i), + $ ' in gather' + endif + enddo + else + call mpi_gather( rank, 1, MPI_INTEGER, rbuf, 1, MPI_INTEGER, + $ root, comm, ierr ) + endif + +C Gatherv with inplace + do i=1,size + rbuf(i) = - i + rcount(i) = 1 + rdispls(i) = i-1 + enddo + rbuf(1+root) = root + if (rank .eq. root) then + call mpi_gatherv( MPI_IN_PLACE, 1, MPI_INTEGER, rbuf, rcount, + $ rdispls, MPI_INTEGER, root, comm, ierr ) + do i=1,size + if (rbuf(i) .ne. i-1) then + errs = errs + 1 + print *, '[', rank, '] rbuf(', i, ') = ', rbuf(i), + $ ' in gatherv' + endif + enddo + else + call mpi_gatherv( rank, 1, MPI_INTEGER, rbuf, rcount, rdispls, + $ MPI_INTEGER, root, comm, ierr ) + endif + +C Scatter with inplace + do i=1,size + sbuf(i) = i + enddo + rbuf(1) = -1 + if (rank .eq. root) then + call mpi_scatter( sbuf, 1, MPI_INTEGER, MPI_IN_PLACE, 1, + $ MPI_INTEGER, root, comm, ierr ) + else + call mpi_scatter( sbuf, 1, MPI_INTEGER, rbuf, 1, + $ MPI_INTEGER, root, comm, ierr ) + if (rbuf(1) .ne. rank+1) then + errs = errs + 1 + print *, '[', rank, '] rbuf = ', rbuf(1), + $ ' in scatter' + endif + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/nonblocking_inpf.f b/teshsuite/smpi/mpich3-test/f77/coll/nonblocking_inpf.f new file mode 100644 index 0000000000..d2c3bbd015 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/nonblocking_inpf.f @@ -0,0 +1,124 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2012 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C A simple test for Fortran support of the MPI_IN_PLACE value in Alltoall[vw]. +C + program main + implicit none + include 'mpif.h' + integer SIZEOFINT + integer MAX_SIZE + parameter (MAX_SIZE=1024) + integer rbuf(MAX_SIZE) + integer rdispls(MAX_SIZE), rcounts(MAX_SIZE), rtypes(MAX_SIZE) + integer comm, rank, size, req + integer sumval, ierr, errs + integer iexpected, igot + integer i, j + + errs = 0 + call mtest_init( ierr ) + + comm = MPI_COMM_WORLD + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + call mpi_type_size( MPI_INTEGER, SIZEOFINT, ierr ) + + do i=1,MAX_SIZE + rbuf(i) = -1 + enddo + do i=1,size + rbuf(i) = (i-1) * size + rank + enddo + call mpi_ialltoall( MPI_IN_PLACE, -1, MPI_DATATYPE_NULL, + . rbuf, 1, MPI_INTEGER, comm, req, ierr ) + call mpi_wait( req, MPI_STATUS_IGNORE, ierr ) + do i=1,size + if (rbuf(i) .ne. (rank*size + i - 1)) then + errs = errs + 1 + print *, '[', rank, ']: IALLTOALL rbuf(', i, ') = ', + . rbuf(i), ', should be', rank * size + i - 1 + endif + enddo + + do i=1,MAX_SIZE + rbuf(i) = -1 + enddo + do i=1,size + rcounts(i) = i-1 + rank + rdispls(i) = (i-1) * (2*size) + do j=0,rcounts(i)-1 + rbuf(rdispls(i)+j+1) = 100 * rank + 10 * (i-1) + j + enddo + enddo + call mpi_ialltoallv( MPI_IN_PLACE, 0, 0, MPI_DATATYPE_NULL, + . rbuf, rcounts, rdispls, MPI_INTEGER, + . comm, req, ierr ) + call mpi_wait( req, MPI_STATUS_IGNORE, ierr ) + do i=1,size + do j=0,rcounts(i)-1 + iexpected = 100 * (i-1) + 10 * rank + j + igot = rbuf(rdispls(i)+j+1) + if ( igot .ne. iexpected ) then + errs = errs + 1 + print *, '[', rank, ']: IALLTOALLV got ', igot, + . ',but expected ', iexpected, + . ' for block=', i-1, ' element=', j + endif + enddo + enddo + + do i=1,MAX_SIZE + rbuf(i) = -1 + enddo + do i=1,size + rcounts(i) = i-1 + rank + rdispls(i) = (i-1) * (2*size) * SIZEOFINT + rtypes(i) = MPI_INTEGER + do j=0,rcounts(i)-1 + rbuf(rdispls(i)/SIZEOFINT+j+1) = 100 * rank + . + 10 * (i-1) + j + enddo + enddo + call mpi_ialltoallw( MPI_IN_PLACE, 0, 0, MPI_DATATYPE_NULL, + . rbuf, rcounts, rdispls, rtypes, + . comm, req, ierr ) + call mpi_wait( req, MPI_STATUS_IGNORE, ierr ) + do i=1,size + do j=0,rcounts(i)-1 + iexpected = 100 * (i-1) + 10 * rank + j + igot = rbuf(rdispls(i)/SIZEOFINT+j+1) + if ( igot .ne. iexpected ) then + errs = errs + 1 + print *, '[', rank, ']: IALLTOALLW got ', igot, + . ',but expected ', iexpected, + . ' for block=', i-1, ' element=', j + endif + enddo + enddo + + do i=1,MAX_SIZE + rbuf(i) = -1 + enddo + do i = 1, size + rbuf(i) = rank + (i-1) + enddo + call mpi_ireduce_scatter_block( MPI_IN_PLACE, rbuf, 1, + . MPI_INTEGER, MPI_SUM, comm, + . req, ierr ) + call mpi_wait( req, MPI_STATUS_IGNORE, ierr ) + + sumval = size * rank + ((size-1) * size)/2 + if ( rbuf(1) .ne. sumval ) then + errs = errs + 1 + print *, 'Ireduce_scatter_block does not get expected value.' + print *, '[', rank, ']:', 'Got ', rbuf(1), ' but expected ', + . sumval, '.' + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/nonblockingf.f b/teshsuite/smpi/mpich3-test/f77/coll/nonblockingf.f new file mode 100644 index 0000000000..b912acd8f1 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/nonblockingf.f @@ -0,0 +1,98 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2012 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer NUM_INTS + parameter (NUM_INTS=2) + integer maxSize + parameter (maxSize=128) + integer scounts(maxSize), sdispls(maxSize) + integer rcounts(maxSize), rdispls(maxSize) + integer types(maxSize) + integer sbuf(maxSize), rbuf(maxSize) + integer comm, size, rank, req + integer ierr, errs + integer ii, ans + + errs = 0 + + call mtest_init(ierr) + + comm = MPI_COMM_WORLD + call MPI_Comm_size(comm, size, ierr) + call MPI_Comm_rank(comm, rank, ierr) +C + do ii = 1, size + sbuf(2*ii-1) = ii + sbuf(2*ii) = ii + sbuf(2*ii-1) = ii + sbuf(2*ii) = ii + scounts(ii) = NUM_INTS + rcounts(ii) = NUM_INTS + sdispls(ii) = (ii-1) * NUM_INTS + rdispls(ii) = (ii-1) * NUM_INTS + types(ii) = MPI_INTEGER + enddo + + call MPI_Ibarrier(comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Ibcast(sbuf, NUM_INTS, MPI_INTEGER, 0, comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Igather(sbuf, NUM_INTS, MPI_INTEGER, + . rbuf, NUM_INTS, MPI_INTEGER, + . 0, comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Igatherv(sbuf, NUM_INTS, MPI_INTEGER, + . rbuf, rcounts, rdispls, MPI_INTEGER, + . 0, comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Ialltoall(sbuf, NUM_INTS, MPI_INTEGER, + . rbuf, NUM_INTS, MPI_INTEGER, + . comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Ialltoallv(sbuf, scounts, sdispls, MPI_INTEGER, + . rbuf, rcounts, rdispls, MPI_INTEGER, + . comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Ialltoallw(sbuf, scounts, sdispls, types, + . rbuf, rcounts, rdispls, types, + . comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Ireduce(sbuf, rbuf, NUM_INTS, MPI_INTEGER, + . MPI_SUM, 0, comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Iallreduce(sbuf, rbuf, NUM_INTS, MPI_INTEGER, + . MPI_SUM, comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Ireduce_scatter(sbuf, rbuf, rcounts, MPI_INTEGER, + . MPI_SUM, comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Ireduce_scatter_block(sbuf, rbuf, NUM_INTS, MPI_INTEGER, + . MPI_SUM, comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Iscan(sbuf, rbuf, NUM_INTS, MPI_INTEGER, + . MPI_SUM, comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Iexscan(sbuf, rbuf, NUM_INTS, MPI_INTEGER, + . MPI_SUM, comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call mtest_finalize( errs ) + call MPI_Finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/red_scat_blockf.f b/teshsuite/smpi/mpich3-test/f77/coll/red_scat_blockf.f new file mode 100644 index 0000000000..831f2fc7a4 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/red_scat_blockf.f @@ -0,0 +1,56 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2012 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C A simple test for Fortran support of Reduce_scatter_block +C with or withoutMPI_IN_PLACE. +C + program main + implicit none + include 'mpif.h' + integer MAX_SIZE + parameter (MAX_SIZE=1024) + integer sbuf(MAX_SIZE), rbuf(MAX_SIZE) + integer comm, rank, size + integer sumval, ierr, errs, i + + errs = 0 + call mtest_init( ierr ) + + comm = MPI_COMM_WORLD + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + + do i = 1, size + sbuf(i) = rank + (i-1) + enddo + + call MPI_Reduce_scatter_block(sbuf, rbuf, 1, MPI_INTEGER, + . MPI_SUM, comm, ierr) + + sumval = size * rank + ((size-1) * size)/2 + if ( rbuf(1) .ne. sumval ) then + errs = errs + 1 + print *, 'Reduce_scatter_block does not get expected value.' + print *, '[', rank, ']', 'Got ', rbuf(1), ' but expected ', + . sumval, '.' + endif + +C Try MPI_IN_PLACE + do i = 1, size + rbuf(i) = rank + (i-1) + enddo + call MPI_Reduce_scatter_block(MPI_IN_PLACE, rbuf, 1, MPI_INTEGER, + . MPI_SUM, comm, ierr) + if ( rbuf(1) .ne. sumval ) then + errs = errs + 1 + print *, 'Reduce_scatter_block does not get expected value.' + print *, '[', rank, ']', 'Got ', rbuf(1), ' but expected ', + . sumval, '.' + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/redscatf.f b/teshsuite/smpi/mpich3-test/f77/coll/redscatf.f new file mode 100644 index 0000000000..b19b1e7903 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/redscatf.f @@ -0,0 +1,85 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2011 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + subroutine uop( cin, cout, count, datatype ) + implicit none + include 'mpif.h' + integer cin(*), cout(*) + integer count, datatype + integer i + +! if (datatype .ne. MPI_INTEGER) then +! write(6,*) 'Invalid datatype ',datatype,' passed to user_op()' +! return +! endif + + do i=1, count + cout(i) = cin(i) + cout(i) + enddo + end +C +C Test of reduce scatter. +C +C Each processor contributes its rank + the index to the reduction, +C then receives the ith sum +C +C Can be called with any number of processors. +C + + program main + implicit none + include 'mpif.h' + integer errs, ierr, toterr + integer maxsize + parameter (maxsize=1024) + integer sendbuf(maxsize), recvbuf, recvcounts(maxsize) + integer size, rank, i, sumval + integer comm, sumop + external uop + + errs = 0 + + call mtest_init( ierr ) + + comm = MPI_COMM_WORLD + + call mpi_comm_size( comm, size, ierr ) + call mpi_comm_rank( comm, rank, ierr ) + + if (size .gt. maxsize) then + endif + do i=1, size + sendbuf(i) = rank + i - 1 + recvcounts(i) = 1 + enddo + + call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts, + & MPI_INTEGER, MPI_SUM, comm, ierr ) + + sumval = size * rank + ((size - 1) * size)/2 +C recvbuf should be size * (rank + i) + if (recvbuf .ne. sumval) then + errs = errs + 1 + print *, "Did not get expected value for reduce scatter" + print *, rank, " Got ", recvbuf, " expected ", sumval + endif + + call mpi_op_create( uop, .true., sumop, ierr ) + call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts, + & MPI_INTEGER, sumop, comm, ierr ) + + sumval = size * rank + ((size - 1) * size)/2 +C recvbuf should be size * (rank + i) + if (recvbuf .ne. sumval) then + errs = errs + 1 + print *, "sumop: Did not get expected value for reduce scatter" + print *, rank, " Got ", recvbuf, " expected ", sumval + endif + call mpi_op_free( sumop, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/reducelocalf.f b/teshsuite/smpi/mpich3-test/f77/coll/reducelocalf.f new file mode 100644 index 0000000000..6037308f0d --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/reducelocalf.f @@ -0,0 +1,97 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2009 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C +C Test Fortran MPI_Reduce_local with MPI_OP_SUM and with user-defined operation. +C + subroutine user_op( invec, outvec, count, datatype ) + implicit none + include 'mpif.h' + integer invec(*), outvec(*) + integer count, datatype + integer ii + + if (datatype .ne. MPI_INTEGER) then + write(6,*) 'Invalid datatype passed to user_op()' + return + endif + + do ii=1, count + outvec(ii) = invec(ii) * 2 + outvec(ii) + enddo + + end + + program main + implicit none + include 'mpif.h' + integer max_buf_size + parameter (max_buf_size=65000) + integer vin(max_buf_size), vout(max_buf_size) + external user_op + integer ierr, errs + integer count, myop + integer ii + + errs = 0 + + call mtest_init(ierr) + + count = 0 + do while (count .le. max_buf_size ) + do ii = 1,count + vin(ii) = ii + vout(ii) = ii + enddo + call mpi_reduce_local( vin, vout, count, + & MPI_INTEGER, MPI_SUM, ierr ) +C Check if the result is correct + do ii = 1,count + if ( vin(ii) .ne. ii ) then + errs = errs + 1 + endif + if ( vout(ii) .ne. 2*ii ) then + errs = errs + 1 + endif + enddo + if ( count .gt. 0 ) then + count = count + count + else + count = 1 + endif + enddo + + call mpi_op_create( user_op, .false., myop, ierr ) + + count = 0 + do while (count .le. max_buf_size) + do ii = 1, count + vin(ii) = ii + vout(ii) = ii + enddo + call mpi_reduce_local( vin, vout, count, + & MPI_INTEGER, myop, ierr ) +C Check if the result is correct + do ii = 1, count + if ( vin(ii) .ne. ii ) then + errs = errs + 1 + endif + if ( vout(ii) .ne. 3*ii ) then + errs = errs + 1 + endif + enddo + if ( count .gt. 0 ) then + count = count + count + else + count = 1 + endif + enddo + + call mpi_op_free( myop, ierr ) + + call mtest_finalize(errs) + call mpi_finalize(ierr) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/split_typef.f b/teshsuite/smpi/mpich3-test/f77/coll/split_typef.f new file mode 100644 index 0000000000..3f3aa3e21e --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/split_typef.f @@ -0,0 +1,46 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2011 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer ierr, errs + integer i, ans, size, rank, color, comm, newcomm + integer maxSize, displ + parameter (maxSize=128) + integer scounts(maxSize), sdispls(maxSize), stypes(maxSize) + integer rcounts(maxSize), rdispls(maxSize), rtypes(maxSize) + integer sbuf(maxSize), rbuf(maxSize) + + errs = 0 + + call mtest_init( ierr ) + + call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr ) + + call mpi_comm_split_type( comm, MPI_COMM_TYPE_SHARED, rank, + & MPI_INFO_NULL, newcomm, ierr ) + call mpi_comm_rank( newcomm, rank, ierr ) + call mpi_comm_size( newcomm, size, ierr ) + + do i=1, size + scounts(i) = 1 + sdispls(i) = (i-1) + stypes(i) = MPI_INTEGER + sbuf(i) = rank * size + i + rcounts(i) = 1 + rdispls(i) = (i-1) + rtypes(i) = MPI_INTEGER + rbuf(i) = -1 + enddo + call mpi_alltoallv( sbuf, scounts, sdispls, stypes, + & rbuf, rcounts, rdispls, rtypes, newcomm, ierr ) + + call mpi_comm_free( newcomm, ierr ) + call mpi_comm_free( comm, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/testlist b/teshsuite/smpi/mpich3-test/f77/coll/testlist new file mode 100644 index 0000000000..dd711632c0 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/testlist @@ -0,0 +1,12 @@ +uallreducef 4 +exscanf 5 +#alltoallwf 7 +alltoallvf 7 +inplacef 4 +reducelocalf 2 mpiversion=2.2 +redscatf 4 +split_typef 4 mpiversion=3.0 +nonblockingf 4 mpiversion=3.0 +vw_inplacef 4 mpiversion=2.2 +red_scat_blockf 4 mpiversion=2.2 +nonblocking_inpf 4 mpiversion=3.0 diff --git a/teshsuite/smpi/mpich3-test/f77/coll/uallreducef.f b/teshsuite/smpi/mpich3-test/f77/coll/uallreducef.f new file mode 100644 index 0000000000..566d294b92 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/uallreducef.f @@ -0,0 +1,63 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C +C Test user-defined operations. This tests a simple commutative operation +C + subroutine uop( cin, cout, count, datatype ) + implicit none + include 'mpif.h' + integer cin(*), cout(*) + integer count, datatype + integer i + +C if (datatype .ne. MPI_INTEGER) then +C print *, 'Invalid datatype (',datatype,') passed to user_op()' +C return +C endif + + do i=1, count + cout(i) = cin(i) + cout(i) + enddo + end + + program main + implicit none + include 'mpif.h' + external uop + integer ierr, errs + integer count, sumop, vin(65000), vout(65000), i, size + integer comm + + errs = 0 + + call mtest_init(ierr) + call mpi_op_create( uop, .true., sumop, ierr ) + + comm = MPI_COMM_WORLD + call mpi_comm_size( comm, size, ierr ) + count = 1 + do while (count .lt. 65000) + do i=1, count + vin(i) = i + vout(i) = -1 + enddo + call mpi_allreduce( vin, vout, count, MPI_INTEGER, sumop, + * comm, ierr ) +C Check that all results are correct + do i=1, count + if (vout(i) .ne. i * size) then + errs = errs + 1 + if (errs .lt. 10) print *, "vout(",i,") = ", vout(i) + endif + enddo + count = count + count + enddo + + call mpi_op_free( sumop, ierr ) + + call mtest_finalize(errs) + call mpi_finalize(ierr) + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/vw_inplacef.f b/teshsuite/smpi/mpich3-test/f77/coll/vw_inplacef.f new file mode 100644 index 0000000000..4ad1d4ac36 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/vw_inplacef.f @@ -0,0 +1,109 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2012 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C A simple test for Fortran support of the MPI_IN_PLACE value in Alltoall[vw]. +C + program main + implicit none + include 'mpif.h' + integer SIZEOFINT + integer MAX_SIZE + parameter (MAX_SIZE=1024) + integer rbuf(MAX_SIZE) + integer rdispls(MAX_SIZE), rcounts(MAX_SIZE), rtypes(MAX_SIZE) + integer ierr, errs + integer comm, root + integer rank, size + integer iexpected, igot + integer i, j + + errs = 0 + call mtest_init( ierr ) + + comm = MPI_COMM_WORLD + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + call mpi_type_size( MPI_INTEGER, SIZEOFINT, ierr ) + + if (size .gt. MAX_SIZE) then + print *, ' At most ', MAX_SIZE, ' processes allowed' + call mpi_abort( MPI_COMM_WORLD, 1, ierr ) + endif +C + do i=1,MAX_SIZE + rbuf(i) = -1 + enddo + do i=1,size + rbuf(i) = (i-1) * size + rank + enddo + call mpi_alltoall( MPI_IN_PLACE, -1, MPI_DATATYPE_NULL, + $ rbuf, 1, MPI_INTEGER, comm, ierr ) + do i=1,size + if (rbuf(i) .ne. (rank*size + i - 1)) then + errs = errs + 1 + print *, '[', rank, '] rbuf(', i, ') = ', rbuf(i), + $ ', should be', rank * size + i - 1 + endif + enddo + + do i=1,MAX_SIZE + rbuf(i) = -1 + enddo + do i=1,size + rcounts(i) = (i-1) + rank + rdispls(i) = (i-1) * (2*size) + do j=0,rcounts(i)-1 + rbuf(rdispls(i)+j+1) = 100 * rank + 10 * (i-1) + j + enddo + enddo + call mpi_alltoallv( MPI_IN_PLACE, 0, 0, MPI_DATATYPE_NULL, + $ rbuf, rcounts, rdispls, MPI_INTEGER, + $ comm, ierr ) + do i=1,size + do j=0,rcounts(i)-1 + iexpected = 100 * (i-1) + 10 * rank + j + igot = rbuf(rdispls(i)+j+1) + if ( igot .ne. iexpected ) then + errs = errs + 1 + print *, '[', rank, '] ALLTOALLV got ', igot, + $ ',but expected ', iexpected, + $ ' for block=', i-1, ' element=', j + endif + enddo + enddo + + do i=1,MAX_SIZE + rbuf(i) = -1 + enddo +C Alltoallw's displs[] are in bytes not in type extents. + do i=1,size + rcounts(i) = (i-1) + rank + rdispls(i) = (i-1) * (2*size) * SIZEOFINT + rtypes(i) = MPI_INTEGER + do j=0,rcounts(i)-1 + rbuf(rdispls(i)/SIZEOFINT+j+1) = 100 * rank + $ + 10 * (i-1) + j + enddo + enddo + call mpi_alltoallw( MPI_IN_PLACE, 0, 0, MPI_DATATYPE_NULL, + $ rbuf, rcounts, rdispls, rtypes, + $ comm, ierr ) + do i=1,size + do j=0,rcounts(i)-1 + iexpected = 100 * (i-1) + 10 * rank + j + igot = rbuf(rdispls(i)/SIZEOFINT+j+1) + if ( igot .ne. iexpected ) then + errs = errs + 1 + print *, '[', rank, '] ALLTOALLW got ', igot, + $ ',but expected ', iexpected, + $ ' for block=', i-1, ' element=', j + endif + enddo + enddo + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/comm/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f77/comm/CMakeLists.txt new file mode 100644 index 0000000000..8dc5f07b1f --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/comm/CMakeLists.txt @@ -0,0 +1,55 @@ +cmake_minimum_required(VERSION 2.6) + +if(enable_smpi) + if(WIN32) + set(CMAKE_C_FLAGS "-include ${CMAKE_HOME_DIRECTORY}/include/smpi/smpi_main.h") + else() + set(CMAKE_C_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpicc") + set(CMAKE_Fortran_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpiff") + endif() + + set(EXECUTABLE_OUTPUT_PATH "${CMAKE_CURRENT_BINARY_DIR}") + set(MPICH_FLAGS "-DHAVE_STDLIB_H=1 -DHAVE_UNISTD_H=1 -DHAVE_STRING_H=1 -DUSE_STDARG=1 -DHAVE_LONG_DOUBLE=1 -DHAVE_PROTOTYPES=1 -DHAVE_SIGNAL_H=1 -DHAVE_SIGACTION=1 -DHAVE_SLEEP=1 -DHAVE_SYSCONF=1 -Wno-error=unused-variable -Wno-implicit") + include_directories("${CMAKE_HOME_DIRECTORY}/include/smpi") + include_directories("${CMAKE_CURRENT_BINARY_DIR}/../include/") + + + # add_executable(commerrf commerrf.f ../util/mtestf.f) + add_executable(commnamef commnamef.f ../util/mtestf.f) + + + + # target_link_libraries(commerrf simgrid) + target_link_libraries(commnamef simgrid) + + + +# set_target_properties(commerrf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(commnamef PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + +endif() + +set(tesh_files + ${tesh_files} + PARENT_SCOPE + ) +set(xml_files + ${xml_files} + PARENT_SCOPE + ) +set(examples_src + ${examples_src} + ${CMAKE_CURRENT_SOURCE_DIR}/commerrf.f + ${CMAKE_CURRENT_SOURCE_DIR}/commnamef.f + PARENT_SCOPE + ) +set(bin_files + ${bin_files} + PARENT_SCOPE + ) +set(txt_files + ${txt_files} + ${CMAKE_CURRENT_SOURCE_DIR}/runtests + ${CMAKE_CURRENT_SOURCE_DIR}/testlist + PARENT_SCOPE + ) diff --git a/teshsuite/smpi/mpich3-test/f77/comm/commerrf.f b/teshsuite/smpi/mpich3-test/f77/comm/commerrf.f new file mode 100644 index 0000000000..e58337f29f --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/comm/commerrf.f @@ -0,0 +1,131 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr, code(2), newerrclass, eclass + character*(MPI_MAX_ERROR_STRING) errstring + integer comm, rlen + external myerrhanfunc +CF90 INTERFACE +CF90 SUBROUTINE myerrhanfunc(vv0,vv1) +CF90 INTEGER vv0,vv1 +CF90 END SUBROUTINE +CF90 END INTERFACE + integer myerrhan, qerr + integer callcount, codesSeen(3) + common /myerrhan/ callcount, codesSeen + + errs = 0 + callcount = 0 + call mtest_init( ierr ) +C +C Setup some new codes and classes + call mpi_add_error_class( newerrclass, ierr ) + call mpi_add_error_code( newerrclass, code(1), ierr ) + call mpi_add_error_code( newerrclass, code(2), ierr ) + call mpi_add_error_string( newerrclass, "New Class", ierr ) + call mpi_add_error_string( code(1), "First new code", ierr ) + call mpi_add_error_string( code(2), "Second new code", ierr ) +C +C + call mpi_comm_create_errhandler( myerrhanfunc, myerrhan, ierr ) +C +C Create a new communicator so that we can leave the default errors-abort +C on MPI_COMM_WORLD + call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr ) +C + call mpi_comm_set_errhandler( comm, myerrhan, ierr ) + + call mpi_comm_get_errhandler( comm, qerr, ierr ) + if (qerr .ne. myerrhan) then + errs = errs + 1 + print *, ' Did not get expected error handler' + endif + call mpi_errhandler_free( qerr, ierr ) +C We can free our error handler now + call mpi_errhandler_free( myerrhan, ierr ) + + call mpi_comm_call_errhandler( comm, newerrclass, ierr ) + call mpi_comm_call_errhandler( comm, code(1), ierr ) + call mpi_comm_call_errhandler( comm, code(2), ierr ) + + if (callcount .ne. 3) then + errs = errs + 1 + print *, ' Expected 3 calls to error handler, found ', + & callcount + else + if (codesSeen(1) .ne. newerrclass) then + errs = errs + 1 + print *, 'Expected class ', newerrclass, ' got ', + & codesSeen(1) + endif + if (codesSeen(2) .ne. code(1)) then + errs = errs + 1 + print *, 'Expected code ', code(1), ' got ', + & codesSeen(2) + endif + if (codesSeen(3) .ne. code(2)) then + errs = errs + 1 + print *, 'Expected code ', code(2), ' got ', + & codesSeen(3) + endif + endif + + call mpi_comm_free( comm, ierr ) +C +C Check error strings while here... + call mpi_error_string( newerrclass, errstring, rlen, ierr ) + if (errstring(1:rlen) .ne. "New Class") then + errs = errs + 1 + print *, ' Wrong string for error class: ', errstring(1:rlen) + endif + call mpi_error_class( code(1), eclass, ierr ) + if (eclass .ne. newerrclass) then + errs = errs + 1 + print *, ' Class for new code is not correct' + endif + call mpi_error_string( code(1), errstring, rlen, ierr ) + if (errstring(1:rlen) .ne. "First new code") then + errs = errs + 1 + print *, ' Wrong string for error code: ', errstring(1:rlen) + endif + call mpi_error_class( code(2), eclass, ierr ) + if (eclass .ne. newerrclass) then + errs = errs + 1 + print *, ' Class for new code is not correct' + endif + call mpi_error_string( code(2), errstring, rlen, ierr ) + if (errstring(1:rlen) .ne. "Second new code") then + errs = errs + 1 + print *, ' Wrong string for error code: ', errstring(1:rlen) + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end +C + subroutine myerrhanfunc( comm, errcode ) + implicit none + include 'mpif.h' + integer comm, errcode + integer rlen, ierr + integer callcount, codesSeen(3) + character*(MPI_MAX_ERROR_STRING) errstring + common /myerrhan/ callcount, codesSeen + + callcount = callcount + 1 +C Remember the code we've seen + if (callcount .le. 3) then + codesSeen(callcount) = errcode + endif + call mpi_error_string( errcode, errstring, rlen, ierr ) + if (ierr .ne. MPI_SUCCESS) then + print *, ' Panic! could not get error string' + call mpi_abort( MPI_COMM_WORLD, 1, ierr ) + endif + end diff --git a/teshsuite/smpi/mpich3-test/f77/comm/commnamef.f b/teshsuite/smpi/mpich3-test/f77/comm/commnamef.f new file mode 100644 index 0000000000..4ff5caf6de --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/comm/commnamef.f @@ -0,0 +1,82 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + integer comm(4), i, rlen, ln + integer ncomm + character*(MPI_MAX_OBJECT_NAME) inname(4), cname + logical MTestGetIntracomm + + errs = 0 + call mtest_init( ierr ) + +C Test the predefined communicators + do ln=1,MPI_MAX_OBJECT_NAME + cname(ln:ln) = 'X' + enddo + call mpi_comm_get_name( MPI_COMM_WORLD, cname, rlen, ierr ) + do ln=MPI_MAX_OBJECT_NAME,1,-1 + if (cname(ln:ln) .ne. ' ') then + if (ln .ne. rlen) then + errs = errs + 1 + print *, 'result len ', rlen,' not equal to actual len ', + & ln + endif + goto 110 + endif + enddo + if (cname(1:rlen) .ne. 'MPI_COMM_WORLD') then + errs = errs + 1 + print *, 'Did not get MPI_COMM_WORLD for world' + endif + 110 continue +C + do ln=1,MPI_MAX_OBJECT_NAME + cname(ln:ln) = 'X' + enddo + call mpi_comm_get_name( MPI_COMM_SELF, cname, rlen, ierr ) + do ln=MPI_MAX_OBJECT_NAME,1,-1 + if (cname(ln:ln) .ne. ' ') then + if (ln .ne. rlen) then + errs = errs + 1 + print *, 'result len ', rlen,' not equal to actual len ', + & ln + endif + goto 120 + endif + enddo + if (cname(1:rlen) .ne. 'MPI_COMM_SELF') then + errs = errs + 1 + print *, 'Did not get MPI_COMM_SELF for world' + endif + 120 continue +C + do i = 1, 4 + if (MTestGetIntracomm( comm(i), 1, .true. )) then + ncomm = i + write( inname(i), '(a,i1)') 'myname',i + call mpi_comm_set_name( comm(i), inname(i), ierr ) + else + goto 130 + endif + enddo + 130 continue +C +C Now test them all + do i=1, ncomm + call mpi_comm_get_name( comm(i), cname, rlen, ierr ) + if (inname(i) .ne. cname) then + errs = errs + 1 + print *, ' Expected ', inname(i), ' got ', cname + endif + call MTestFreeComm( comm(i) ) + enddo +C + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/comm/testlist b/teshsuite/smpi/mpich3-test/f77/comm/testlist new file mode 100644 index 0000000000..6523065976 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/comm/testlist @@ -0,0 +1,2 @@ +#commnamef 2 +#commerrf 2 diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f77/datatype/CMakeLists.txt new file mode 100644 index 0000000000..380584f0dc --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/CMakeLists.txt @@ -0,0 +1,95 @@ +cmake_minimum_required(VERSION 2.6) + +if(enable_smpi) + if(WIN32) + set(CMAKE_C_FLAGS "-include ${CMAKE_HOME_DIRECTORY}/include/smpi/smpi_main.h") + else() + set(CMAKE_C_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpicc") + set(CMAKE_Fortran_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpiff") + endif() + + set(EXECUTABLE_OUTPUT_PATH "${CMAKE_CURRENT_BINARY_DIR}") + set(MPICH_FLAGS "-DHAVE_STDLIB_H=1 -DHAVE_UNISTD_H=1 -DHAVE_STRING_H=1 -DUSE_STDARG=1 -DHAVE_LONG_DOUBLE=1 -DHAVE_PROTOTYPES=1 -DHAVE_SIGNAL_H=1 -DHAVE_SIGACTION=1 -DHAVE_SLEEP=1 -DHAVE_SYSCONF=1 -Wno-error=unused-variable -Wno-implicit") + include_directories("${CMAKE_HOME_DIRECTORY}/include/smpi") + include_directories("${CMAKE_CURRENT_BINARY_DIR}/../include/") + + + add_executable(allctypesf allctypesf.f ../util/mtestf.f) + add_executable(gaddressf gaddressf.f ../util/mtestf.f) + add_executable(hindex1f hindex1f.f ../util/mtestf.f) + add_executable(hindexed_blockf hindexed_blockf.f ../util/mtestf.f) + add_executable(packef packef.f ../util/mtestf.f) + add_executable(typeaints typeaints.h ../util/mtestf.f) + add_executable(typecntsf typecntsf.f ../util/mtestf.f) + add_executable(typem2f typem2f.f ../util/mtestf.f) + add_executable(typename3f typename3f.f ../util/mtestf.f) + add_executable(typenamef typenamef.f ../util/mtestf.f) + add_executable(typesnamef typesnamef.f ../util/mtestf.f) + add_executable(typesubf typesubf.f ../util/mtestf.f) + + + + target_link_libraries(allctypesf simgrid) + target_link_libraries(gaddressf simgrid) + target_link_libraries(hindex1f simgrid) + target_link_libraries(hindexed_blockf simgrid) + target_link_libraries(packef simgrid) + target_link_libraries(typeaints simgrid) + target_link_libraries(typecntsf simgrid) + target_link_libraries(typem2f simgrid) + target_link_libraries(typename3f simgrid) + target_link_libraries(typenamef simgrid) + target_link_libraries(typesnamef simgrid) + target_link_libraries(typesubf simgrid) + + + + set_target_properties(allctypesf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(gaddressf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(hindex1f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(hindexed_blockf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(packef PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typeaints PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typecntsf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typem2f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typename3f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typenamef PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typesnamef PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typesubf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + +endif() + +set(tesh_files + ${tesh_files} + PARENT_SCOPE + ) +set(xml_files + ${xml_files} + PARENT_SCOPE + ) +set(examples_src + ${examples_src} + ${CMAKE_CURRENT_SOURCE_DIR}/allctypesf.f + ${CMAKE_CURRENT_SOURCE_DIR}/gaddressf.f + ${CMAKE_CURRENT_SOURCE_DIR}/hindex1f.f + ${CMAKE_CURRENT_SOURCE_DIR}/hindexed_blockf.f + ${CMAKE_CURRENT_SOURCE_DIR}/packef.f + ${CMAKE_CURRENT_SOURCE_DIR}/typeaints.h + ${CMAKE_CURRENT_SOURCE_DIR}/typecntsf.f + ${CMAKE_CURRENT_SOURCE_DIR}/typem2f.f + ${CMAKE_CURRENT_SOURCE_DIR}/typename3f.f + ${CMAKE_CURRENT_SOURCE_DIR}/typenamef.f + ${CMAKE_CURRENT_SOURCE_DIR}/typesnamef.f + ${CMAKE_CURRENT_SOURCE_DIR}/typesubf.f + PARENT_SCOPE + ) +set(bin_files + ${bin_files} + PARENT_SCOPE + ) +set(txt_files + ${txt_files} + ${CMAKE_CURRENT_SOURCE_DIR}/runtests + ${CMAKE_CURRENT_SOURCE_DIR}/testlist + PARENT_SCOPE + ) diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/allctypesf.f b/teshsuite/smpi/mpich3-test/f77/datatype/allctypesf.f new file mode 100644 index 0000000000..f4c5e3f2d5 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/allctypesf.f @@ -0,0 +1,138 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2004 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + include 'mpif.h' + integer atype, ierr +C + call mtest_init(ierr) + call mpi_comm_set_errhandler( MPI_COMM_WORLD, MPI_ERRORS_RETURN, + * ierr ) +C +C Check that all Ctypes are available in Fortran (MPI 2.1, p 483, line 46) +C + call checkdtype( MPI_CHAR, "MPI_CHAR", ierr ) + call checkdtype( MPI_SIGNED_CHAR, "MPI_SIGNED_CHAR", ierr ) + call checkdtype( MPI_UNSIGNED_CHAR, "MPI_UNSIGNED_CHAR", ierr ) + call checkdtype( MPI_BYTE, "MPI_BYTE", ierr ) + call checkdtype( MPI_WCHAR, "MPI_WCHAR", ierr ) + call checkdtype( MPI_SHORT, "MPI_SHORT", ierr ) + call checkdtype( MPI_UNSIGNED_SHORT, "MPI_UNSIGNED_SHORT", ierr ) + call checkdtype( MPI_INT, "MPI_INT", ierr ) + call checkdtype( MPI_UNSIGNED, "MPI_UNSIGNED", ierr ) + call checkdtype( MPI_LONG, "MPI_LONG", ierr ) + call checkdtype( MPI_UNSIGNED_LONG, "MPI_UNSIGNED_LONG", ierr ) + call checkdtype( MPI_FLOAT, "MPI_FLOAT", ierr ) + call checkdtype( MPI_DOUBLE, "MPI_DOUBLE", ierr ) + if (MPI_LONG_DOUBLE .ne. MPI_DATATYPE_NULL) then + call checkdtype( MPI_LONG_DOUBLE, "MPI_LONG_DOUBLE", ierr ) + endif + if (MPI_LONG_LONG_INT .ne. MPI_DATATYPE_NULL) then + call checkdtype2( MPI_LONG_LONG_INT, "MPI_LONG_LONG_INT", + * "MPI_LONG_LONG", ierr ) + endif + if (MPI_UNSIGNED_LONG_LONG .ne. MPI_DATATYPE_NULL) then + call checkdtype( MPI_UNSIGNED_LONG_LONG, + * "MPI_UNSIGNED_LONG_LONG", ierr ) + endif + if (MPI_LONG_LONG .ne. MPI_DATATYPE_NULL) then + call checkdtype2( MPI_LONG_LONG, "MPI_LONG_LONG", + * "MPI_LONG_LONG_INT", ierr ) + endif + call checkdtype( MPI_PACKED, "MPI_PACKED", ierr ) + call checkdtype( MPI_LB, "MPI_LB", ierr ) + call checkdtype( MPI_UB, "MPI_UB", ierr ) + call checkdtype( MPI_FLOAT_INT, "MPI_FLOAT_INT", ierr ) + call checkdtype( MPI_DOUBLE_INT, "MPI_DOUBLE_INT", ierr ) + call checkdtype( MPI_LONG_INT, "MPI_LONG_INT", ierr ) + call checkdtype( MPI_SHORT_INT, "MPI_SHORT_INT", ierr ) + call checkdtype( MPI_2INT, "MPI_2INT", ierr ) + if (MPI_LONG_DOUBLE_INT .ne. MPI_DATATYPE_NULL) then + call checkdtype( MPI_LONG_DOUBLE_INT, "MPI_LONG_DOUBLE_INT", + * ierr) + endif +C +C Check that all Ctypes are available in Fortran (MPI 2.2) +C Note that because of implicit declarations in Fortran, this +C code should compile even with pre MPI 2.2 implementations. +C + if (MPI_VERSION .gt. 2 .or. (MPI_VERSION .eq. 2 .and. + * MPI_SUBVERSION .ge. 2)) then + call checkdtype( MPI_INT8_T, "MPI_INT8_T", ierr ) + call checkdtype( MPI_INT16_T, "MPI_INT16_T", ierr ) + call checkdtype( MPI_INT32_T, "MPI_INT32_T", ierr ) + call checkdtype( MPI_INT64_T, "MPI_INT64_T", ierr ) + call checkdtype( MPI_UINT8_T, "MPI_UINT8_T", ierr ) + call checkdtype( MPI_UINT16_T, "MPI_UINT16_T", ierr ) + call checkdtype( MPI_UINT32_T, "MPI_UINT32_T", ierr ) + call checkdtype( MPI_UINT64_T, "MPI_UINT64_T", ierr ) +C other C99 types + call checkdtype( MPI_C_BOOL, "MPI_C_BOOL", ierr ) + call checkdtype( MPI_C_FLOAT_COMPLEX, "MPI_C_FLOAT_COMPLEX", + * ierr) + call checkdtype2( MPI_C_COMPLEX, "MPI_C_COMPLEX", + * "MPI_C_FLOAT_COMPLEX", ierr ) + call checkdtype( MPI_C_DOUBLE_COMPLEX, "MPI_C_DOUBLE_COMPLEX", + * ierr ) + if (MPI_C_LONG_DOUBLE_COMPLEX .ne. MPI_DATATYPE_NULL) then + call checkdtype( MPI_C_LONG_DOUBLE_COMPLEX, + * "MPI_C_LONG_DOUBLE_COMPLEX", ierr ) + endif +C address/offset types + call checkdtype( MPI_AINT, "MPI_AINT", ierr ) + call checkdtype( MPI_OFFSET, "MPI_OFFSET", ierr ) + endif +C + call mtest_finalize( ierr ) + call MPI_Finalize( ierr ) + end +C +C Check name of datatype + subroutine CheckDtype( intype, name, ierr ) + include 'mpif.h' + integer intype, ierr + character *(*) name + integer ir, rlen + character *(MPI_MAX_OBJECT_NAME) outname +C + outname = "" + call MPI_TYPE_GET_NAME( intype, outname, rlen, ir ) + if (ir .ne. MPI_SUCCESS) then + print *, " Datatype ", name, " not available in Fortran" + ierr = ierr + 1 + else + if (outname .ne. name) then + print *, " For datatype ", name, " found name ", + * outname(1:rlen) + ierr = ierr + 1 + endif + endif + + return + end +C +C Check name of datatype (allows alias) + subroutine CheckDtype2( intype, name, name2, ierr ) + include 'mpif.h' + integer intype, ierr + character *(*) name, name2 + integer ir, rlen + character *(MPI_MAX_OBJECT_NAME) outname +C + outname = "" + call MPI_TYPE_GET_NAME( intype, outname, rlen, ir ) + if (ir .ne. MPI_SUCCESS) then + print *, " Datatype ", name, " not available in Fortran" + ierr = ierr + 1 + else + if (outname .ne. name .and. outname .ne. name2) then + print *, " For datatype ", name, " found name ", + * outname(1:rlen) + ierr = ierr + 1 + endif + endif + + return + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/gaddressf.f b/teshsuite/smpi/mpich3-test/f77/datatype/gaddressf.f new file mode 100644 index 0000000000..4dba0f2a04 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/gaddressf.f @@ -0,0 +1,38 @@ +C -*- Mode: Fortran; -*- +C +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer max_asizev + parameter (max_asizev=2) + include 'typeaints.h' + integer iarray(200), gap, intsize + integer ierr, errs + + errs = 0 + + call MPI_Init(ierr) + + call MPI_Get_address( iarray(1), aintv(1), ierr ) + call MPI_Get_address( iarray(200), aintv(2), ierr ) + gap = aintv(2) - aintv(1) + + call MPI_Type_size( MPI_INTEGER, intsize, ierr ) + + if (gap .ne. 199 * intsize) then + errs = errs + 1 + print *, ' Using get_address, computed a gap of ', gap + print *, ' Expected a gap of ', 199 * intsize + endif + if (errs .gt. 0) then + print *, ' Found ', errs, ' errors' + else + print *, ' No Errors' + endif + + call MPI_Finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/hindex1f.f b/teshsuite/smpi/mpich3-test/f77/datatype/hindex1f.f new file mode 100644 index 0000000000..1a689ed629 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/hindex1f.f @@ -0,0 +1,61 @@ +C -*- Mode: Fortran; -*- +C +C +C (C) 2011 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr, intsize + integer i, displs(10), counts(10), dtype + integer bufsize + parameter (bufsize=100) + integer inbuf(bufsize), outbuf(bufsize), packbuf(bufsize) + integer position, len, psize +C +C Test for hindexed; +C + errs = 0 + call mtest_init( ierr ) + + call mpi_type_size( MPI_INTEGER, intsize, ierr ) + + do i=1, 10 + displs(i) = (10-i)*intsize + counts(i) = 1 + enddo + call mpi_type_hindexed( 10, counts, displs, MPI_INTEGER, dtype, + & ierr ) + call mpi_type_commit( dtype, ierr ) +C + call mpi_pack_size( 1, dtype, MPI_COMM_WORLD, psize, ierr ) + if (psize .gt. bufsize*intsize) then + errs = errs + 1 + else + do i=1,10 + inbuf(i) = i + outbuf(i) = -i + enddo + position = 0 + call mpi_pack( inbuf, 1, dtype, packbuf, psize, position, + $ MPI_COMM_WORLD, ierr ) +C + len = position + position = 0 + call mpi_unpack( packbuf, len, position, outbuf, 10, + $ MPI_INTEGER, MPI_COMM_WORLD, ierr ) +C + do i=1, 10 + if (outbuf(i) .ne. 11-i) then + errs = errs + 1 + print *, 'outbuf(',i,')=',outbuf(i),', expected ', 10-i + endif + enddo + endif +C + call mpi_type_free( dtype, ierr ) +C + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/hindexed_blockf.f b/teshsuite/smpi/mpich3-test/f77/datatype/hindexed_blockf.f new file mode 100644 index 0000000000..8dc00a8e85 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/hindexed_blockf.f @@ -0,0 +1,178 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr, i, intsize + integer type1, type2, type3, type4, type5 + integer max_asizev + parameter (max_asizev = 10) + include 'typeaints.h' + integer blocklens(max_asizev), dtypes(max_asizev) + integer displs(max_asizev) + integer recvbuf(6*max_asizev) + integer sendbuf(max_asizev), status(MPI_STATUS_SIZE) + integer rank, size + + errs = 0 + + call mtest_init( ierr ) + + call mpi_comm_size( MPI_COMM_WORLD, size, ierr ) + call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr ) +C + call mpi_type_size( MPI_INTEGER, intsize, ierr ) +C + aintv(1) = 0 + aintv(2) = 3 * intsize + call mpi_type_create_resized( MPI_INTEGER, aintv(1), aintv(2), + & type1, ierr ) + call mpi_type_commit( type1, ierr ) + aintv(1) = -1 + aintv(2) = -1 + call mpi_type_get_extent( type1, aintv(1), aintv(2), ierr ) + if (aintv(1) .ne. 0) then + errs = errs + 1 + print *, 'Did not get expected lb' + endif + if (aintv(2) .ne. 3*intsize) then + errs = errs + 1 + print *, 'Did not get expected extent' + endif + aintv(1) = -1 + aintv(2) = -1 + call mpi_type_get_true_extent( type1, aintv(1), aintv(2), ierr ) + if (aintv(1) .ne. 0) then + errs = errs + 1 + print *, 'Did not get expected true lb' + endif + if (aintv(2) .ne. intsize) then + errs = errs + 1 + print *, 'Did not get expected true extent (', aintv(2), ') ', + & ' expected ', intsize + endif +C + do i=1,10 + blocklens(i) = 1 + aintv(i) = (i-1) * 3 * intsize + enddo + call mpi_type_create_hindexed( 10, blocklens, aintv, + & MPI_INTEGER, type2, ierr ) + call mpi_type_commit( type2, ierr ) +C + aint = 3 * intsize + call mpi_type_create_hvector( 10, 1, aint, MPI_INTEGER, type3, + & ierr ) + call mpi_type_commit( type3, ierr ) +C + do i=1,10 + blocklens(i) = 1 + dtypes(i) = MPI_INTEGER + aintv(i) = (i-1) * 3 * intsize + enddo + call mpi_type_create_struct( 10, blocklens, aintv, dtypes, + & type4, ierr ) + call mpi_type_commit( type4, ierr ) + + call mpi_type_get_extent(MPI_INTEGER, aintv(1), aint, ierr) + do i=1,10 + aintv(i) = (i-1) * 3 * aint + enddo + call mpi_type_create_hindexed_block( 10, 1, aintv, + & MPI_INTEGER, type5, ierr ) + call mpi_type_commit( type5, ierr ) +C +C Using each time, send and receive using these types + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + do i=1, max_asizev + sendbuf(i) = i + enddo + call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, + & recvbuf, max_asizev, type1, rank, 0, + & MPI_COMM_WORLD, status, ierr ) + do i=1, max_asizev + if (recvbuf(1+(i-1)*3) .ne. i ) then + errs = errs + 1 + print *, 'type1:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + do i=1, max_asizev + sendbuf(i) = i + enddo + call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, + & recvbuf, 1, type2, rank, 0, + & MPI_COMM_WORLD, status, ierr ) + do i=1, max_asizev + if (recvbuf(1+(i-1)*3) .ne. i ) then + errs = errs + 1 + print *, 'type2:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + do i=1, max_asizev + sendbuf(i) = i + enddo + call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, + & recvbuf, 1, type3, rank, 0, + & MPI_COMM_WORLD, status, ierr ) + do i=1, max_asizev + if (recvbuf(1+(i-1)*3) .ne. i ) then + errs = errs + 1 + print *, 'type3:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + do i=1, max_asizev + sendbuf(i) = i + enddo + call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, + & recvbuf, 1, type4, rank, 0, + & MPI_COMM_WORLD, status, ierr ) + do i=1, max_asizev + if (recvbuf(1+(i-1)*3) .ne. i ) then + errs = errs + 1 + print *, 'type4:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + do i=1, max_asizev + sendbuf(i) = i + enddo + call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, + & recvbuf, 1, type5, rank, 0, + & MPI_COMM_WORLD, status, ierr ) + do i=1, max_asizev + if (recvbuf(1+(i-1)*3) .ne. i ) then + errs = errs + 1 + print *, 'type5:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + call mpi_type_free( type1, ierr ) + call mpi_type_free( type2, ierr ) + call mpi_type_free( type3, ierr ) + call mpi_type_free( type4, ierr ) + call mpi_type_free( type5, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/packef.f b/teshsuite/smpi/mpich3-test/f77/datatype/packef.f new file mode 100644 index 0000000000..f91e91f7a9 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/packef.f @@ -0,0 +1,187 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer ierr, errs + integer inbuf(10), ioutbuf(10), inbuf2(10), ioutbuf2(10) + integer i, insize, rsize, csize, insize2 + character*(16) cbuf, coutbuf + double precision rbuf(10), routbuf(10) + integer packbuf(1000), pbufsize, intsize + integer max_asizev + parameter (max_asizev = 3) + include 'typeaints.h' + + errs = 0 + call mtest_init( ierr ) + + call mpi_type_size( MPI_INTEGER, intsize, ierr ) + pbufsize = 1000 * intsize + + call mpi_pack_external_size( 'external32', 10, MPI_INTEGER, + & aint, ierr ) + if (aint .ne. 10 * 4) then + errs = errs + 1 + print *, 'Expected 40 for size of 10 external32 integers', + & ', got ', aint + endif + call mpi_pack_external_size( 'external32', 10, MPI_LOGICAL, + & aint, ierr ) + if (aint .ne. 10 * 4) then + errs = errs + 1 + print *, 'Expected 40 for size of 10 external32 logicals', + & ', got ', aint + endif + call mpi_pack_external_size( 'external32', 10, MPI_CHARACTER, + & aint, ierr ) + if (aint .ne. 10 * 1) then + errs = errs + 1 + print *, 'Expected 10 for size of 10 external32 characters', + & ', got ', aint + endif + + call mpi_pack_external_size( 'external32', 3, MPI_INTEGER2, + & aint, ierr ) + if (aint .ne. 3 * 2) then + errs = errs + 1 + print *, 'Expected 6 for size of 3 external32 INTEGER*2', + & ', got ', aint + endif + call mpi_pack_external_size( 'external32', 3, MPI_INTEGER4, + & aint, ierr ) + if (aint .ne. 3 * 4) then + errs = errs + 1 + print *, 'Expected 12 for size of 3 external32 INTEGER*4', + & ', got ', aint + endif + call mpi_pack_external_size( 'external32', 3, MPI_REAL4, + & aint, ierr ) + if (aint .ne. 3 * 4) then + errs = errs + 1 + print *, 'Expected 12 for size of 3 external32 REAL*4', + & ', got ', aint + endif + call mpi_pack_external_size( 'external32', 3, MPI_REAL8, + & aint, ierr ) + if (aint .ne. 3 * 8) then + errs = errs + 1 + print *, 'Expected 24 for size of 3 external32 REAL*8', + & ', got ', aint + endif + if (MPI_INTEGER1 .ne. MPI_DATATYPE_NULL) then + call mpi_pack_external_size( 'external32', 3, MPI_INTEGER1, + & aint, ierr ) + if (aint .ne. 3 * 1) then + errs = errs + 1 + print *, 'Expected 3 for size of 3 external32 INTEGER*1', + & ', got ', aint + endif + endif + if (MPI_INTEGER8 .ne. MPI_DATATYPE_NULL) then + call mpi_pack_external_size( 'external32', 3, MPI_INTEGER8, + & aint, ierr ) + if (aint .ne. 3 * 8) then + errs = errs + 1 + print *, 'Expected 24 for size of 3 external32 INTEGER*8', + & ', got ', aint + endif + endif + +C +C Initialize values +C + insize = 10 + do i=1, insize + inbuf(i) = i + enddo + rsize = 3 + do i=1, rsize + rbuf(i) = 1000.0 * i + enddo + cbuf = 'This is a string' + csize = 16 + insize2 = 7 + do i=1, insize2 + inbuf2(i) = 5000-i + enddo +C + aintv(1) = pbufsize + aintv(2) = 0 + aintv(3) = 0 +C One MPI implementation failed to increment the position; instead, +C it set the value with the amount of data packed in this call +C We use aintv(3) to detect and report this specific error + call mpi_pack_external( 'external32', inbuf, insize, MPI_INTEGER, + & packbuf, aintv(1), aintv(2), ierr ) + if (aintv(2) .le. aintv(3)) then + print *, ' Position decreased after pack of integer!' + endif + aintv(3) = aintv(2) + call mpi_pack_external( 'external32', rbuf, rsize, + & MPI_DOUBLE_PRECISION, packbuf, aintv(1), + & aintv(2), ierr ) + if (aintv(2) .le. aintv(3)) then + print *, ' Position decreased after pack of real!' + endif + aintv(3) = aintv(2) + call mpi_pack_external( 'external32', cbuf, csize, + & MPI_CHARACTER, packbuf, aintv(1), + & aintv(2), ierr ) + if (aintv(2) .le. aintv(3)) then + print *, ' Position decreased after pack of character!' + endif + aintv(3) = aintv(2) + call mpi_pack_external( 'external32', inbuf2, insize2, + & MPI_INTEGER, + & packbuf, aintv(1), aintv(2), ierr ) + if (aintv(2) .le. aintv(3)) then + print *, ' Position decreased after pack of integer (2nd)!' + endif + aintv(3) = aintv(2) +C +C We could try sending this with MPI_BYTE... + aintv(2) = 0 + call mpi_unpack_external( 'external32', packbuf, aintv(1), + & aintv(2), ioutbuf, insize, MPI_INTEGER, ierr ) + call mpi_unpack_external( 'external32', packbuf, aintv(1), + & aintv(2), routbuf, rsize, MPI_DOUBLE_PRECISION, ierr ) + call mpi_unpack_external( 'external32', packbuf, aintv(1), + & aintv(2), coutbuf, csize, MPI_CHARACTER, ierr ) + call mpi_unpack_external( 'external32', packbuf, aintv(1), + & aintv(2), ioutbuf2, insize2, MPI_INTEGER, ierr ) +C +C Now, test the values +C + do i=1, insize + if (ioutbuf(i) .ne. i) then + errs = errs + 1 + print *, 'ioutbuf(',i,') = ', ioutbuf(i), ' expected ', i + endif + enddo + do i=1, rsize + if (routbuf(i) .ne. 1000.0 * i) then + errs = errs + 1 + print *, 'routbuf(',i,') = ', routbuf(i), ' expected ', & + & 1000.0 * i + endif + enddo + if (coutbuf(1:csize) .ne. 'This is a string') then + errs = errs + 1 + print *, 'coutbuf = ', coutbuf(1:csize), ' expected ', & + & 'This is a string' + endif + do i=1, insize2 + if (ioutbuf2(i) .ne. 5000-i) then + errs = errs + 1 + print *, 'ioutbuf2(',i,') = ', ioutbuf2(i), ' expected ', & + & 5000-i + endif + enddo +C + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/testlist b/teshsuite/smpi/mpich3-test/f77/datatype/testlist new file mode 100644 index 0000000000..5da0524bf3 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/testlist @@ -0,0 +1,11 @@ +#typenamef 1 +#typename3f 1 mpiversion=3.0 +#typesnamef 1 +#typecntsf 1 +#typem2f 1 +#typesubf 1 +#packef 1 +gaddressf 1 +#allctypesf 1 +#hindex1f 1 +#hindexed_blockf 1 mpiversion=3.0 diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/typeaints.h b/teshsuite/smpi/mpich3-test/f77/datatype/typeaints.h new file mode 100644 index 0000000000..ded63b03fc --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/typeaints.h @@ -0,0 +1,6 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + integer aint, aintv(max_asizev) diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/typecntsf.f b/teshsuite/smpi/mpich3-test/f77/datatype/typecntsf.f new file mode 100644 index 0000000000..2bd194c9e4 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/typecntsf.f @@ -0,0 +1,91 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + integer ntype1, ntype2 +C +C This is a very simple test that just tests that the contents/envelope +C routines can be called. This should be upgraded to test the new +C MPI-2 datatype routines (which use address-sized integers) +C + + errs = 0 + call mtest_init( ierr ) + + call explore( MPI_INTEGER, MPI_COMBINER_NAMED, errs ) + call explore( MPI_BYTE, MPI_COMBINER_NAMED, errs ) + call mpi_type_vector( 10, 1, 30, MPI_DOUBLE_PRECISION, ntype1, + & ierr ) + call explore( ntype1, MPI_COMBINER_VECTOR, errs ) + call mpi_type_dup( ntype1, ntype2, ierr ) + call explore( ntype2, MPI_COMBINER_DUP, errs ) + call mpi_type_free( ntype2, ierr ) + call mpi_type_free( ntype1, ierr ) + +C + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end +C + subroutine explore( dtype, mycomb, errs ) + implicit none + include 'mpif.h' + integer dtype, mycomb, errs + integer ierr + integer nints, nadds, ntype, combiner + integer max_nints, max_dtypes, max_asizev + parameter (max_nints = 10, max_dtypes = 10, max_asizev=10) + integer intv(max_nints), dtypesv(max_dtypes) + include 'typeaints.h' +C + call mpi_type_get_envelope( dtype, nints, nadds, ntype, + & combiner, ierr ) +C + if (combiner .ne. MPI_COMBINER_NAMED) then + call mpi_type_get_contents( dtype, + & max_nints, max_asizev, max_dtypes, + & intv, aintv, dtypesv, ierr ) +C +C dtypesv of constructed types must be free'd now +C + if (combiner .eq. MPI_COMBINER_DUP) then + call mpi_type_free( dtypesv(1), ierr ) + endif + endif + if (combiner .ne. mycomb) then + errs = errs + 1 + print *, ' Expected combiner ', mycomb, ' but got ', + & combiner + endif +C +C List all combiner types to check that they are defined in mpif.h + if (combiner .eq. MPI_COMBINER_NAMED) then + else if (combiner .eq. MPI_COMBINER_DUP) then + else if (combiner .eq. MPI_COMBINER_CONTIGUOUS) then + else if (combiner .eq. MPI_COMBINER_VECTOR) then + else if (combiner .eq. MPI_COMBINER_HVECTOR_INTEGER) then + else if (combiner .eq. MPI_COMBINER_HVECTOR) then + else if (combiner .eq. MPI_COMBINER_INDEXED) then + else if (combiner .eq. MPI_COMBINER_HINDEXED_INTEGER) then + else if (combiner .eq. MPI_COMBINER_HINDEXED) then + else if (combiner .eq. MPI_COMBINER_INDEXED_BLOCK) then + else if (combiner .eq. MPI_COMBINER_STRUCT_INTEGER) then + else if (combiner .eq. MPI_COMBINER_STRUCT) then + else if (combiner .eq. MPI_COMBINER_SUBARRAY) then + else if (combiner .eq. MPI_COMBINER_DARRAY) then + else if (combiner .eq. MPI_COMBINER_F90_REAL) then + else if (combiner .eq. MPI_COMBINER_F90_COMPLEX) then + else if (combiner .eq. MPI_COMBINER_F90_INTEGER) then + else if (combiner .eq. MPI_COMBINER_RESIZED) then + else + errs = errs + 1 + print *, ' Unknown combiner ', combiner + endif + + return + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/typem2f.f b/teshsuite/smpi/mpich3-test/f77/datatype/typem2f.f new file mode 100644 index 0000000000..32e9af4330 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/typem2f.f @@ -0,0 +1,177 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr, i, intsize + integer type1, type2, type3, type4, type5 + integer max_asizev + parameter (max_asizev = 10) + include 'typeaints.h' + integer blocklens(max_asizev), dtypes(max_asizev) + integer displs(max_asizev) + integer recvbuf(6*max_asizev) + integer sendbuf(max_asizev), status(MPI_STATUS_SIZE) + integer rank, size + + errs = 0 + + call mtest_init( ierr ) + + call mpi_comm_size( MPI_COMM_WORLD, size, ierr ) + call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr ) +C + call mpi_type_size( MPI_INTEGER, intsize, ierr ) +C + aintv(1) = 0 + aintv(2) = 3 * intsize + call mpi_type_create_resized( MPI_INTEGER, aintv(1), aintv(2), + & type1, ierr ) + call mpi_type_commit( type1, ierr ) + aintv(1) = -1 + aintv(2) = -1 + call mpi_type_get_extent( type1, aintv(1), aintv(2), ierr ) + if (aintv(1) .ne. 0) then + errs = errs + 1 + print *, 'Did not get expected lb' + endif + if (aintv(2) .ne. 3*intsize) then + errs = errs + 1 + print *, 'Did not get expected extent' + endif + aintv(1) = -1 + aintv(2) = -1 + call mpi_type_get_true_extent( type1, aintv(1), aintv(2), ierr ) + if (aintv(1) .ne. 0) then + errs = errs + 1 + print *, 'Did not get expected true lb' + endif + if (aintv(2) .ne. intsize) then + errs = errs + 1 + print *, 'Did not get expected true extent (', aintv(2), ') ', + & ' expected ', intsize + endif +C + do i=1,10 + blocklens(i) = 1 + aintv(i) = (i-1) * 3 * intsize + enddo + call mpi_type_create_hindexed( 10, blocklens, aintv, + & MPI_INTEGER, type2, ierr ) + call mpi_type_commit( type2, ierr ) +C + aint = 3 * intsize + call mpi_type_create_hvector( 10, 1, aint, MPI_INTEGER, type3, + & ierr ) + call mpi_type_commit( type3, ierr ) +C + do i=1,10 + blocklens(i) = 1 + dtypes(i) = MPI_INTEGER + aintv(i) = (i-1) * 3 * intsize + enddo + call mpi_type_create_struct( 10, blocklens, aintv, dtypes, + & type4, ierr ) + call mpi_type_commit( type4, ierr ) + + do i=1,10 + displs(i) = (i-1) * 3 + enddo + call mpi_type_create_indexed_block( 10, 1, displs, + & MPI_INTEGER, type5, ierr ) + call mpi_type_commit( type5, ierr ) +C +C Using each time, send and receive using these types + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + do i=1, max_asizev + sendbuf(i) = i + enddo + call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, + & recvbuf, max_asizev, type1, rank, 0, + & MPI_COMM_WORLD, status, ierr ) + do i=1, max_asizev + if (recvbuf(1+(i-1)*3) .ne. i ) then + errs = errs + 1 + print *, 'type1:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + do i=1, max_asizev + sendbuf(i) = i + enddo + call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, + & recvbuf, 1, type2, rank, 0, + & MPI_COMM_WORLD, status, ierr ) + do i=1, max_asizev + if (recvbuf(1+(i-1)*3) .ne. i ) then + errs = errs + 1 + print *, 'type2:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + do i=1, max_asizev + sendbuf(i) = i + enddo + call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, + & recvbuf, 1, type3, rank, 0, + & MPI_COMM_WORLD, status, ierr ) + do i=1, max_asizev + if (recvbuf(1+(i-1)*3) .ne. i ) then + errs = errs + 1 + print *, 'type3:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + do i=1, max_asizev + sendbuf(i) = i + enddo + call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, + & recvbuf, 1, type4, rank, 0, + & MPI_COMM_WORLD, status, ierr ) + do i=1, max_asizev + if (recvbuf(1+(i-1)*3) .ne. i ) then + errs = errs + 1 + print *, 'type4:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + do i=1, max_asizev + sendbuf(i) = i + enddo + call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, + & recvbuf, 1, type5, rank, 0, + & MPI_COMM_WORLD, status, ierr ) + do i=1, max_asizev + if (recvbuf(1+(i-1)*3) .ne. i ) then + errs = errs + 1 + print *, 'type5:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + call mpi_type_free( type1, ierr ) + call mpi_type_free( type2, ierr ) + call mpi_type_free( type3, ierr ) + call mpi_type_free( type4, ierr ) + call mpi_type_free( type5, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/typename3f.f b/teshsuite/smpi/mpich3-test/f77/datatype/typename3f.f new file mode 100644 index 0000000000..17414d0e41 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/typename3f.f @@ -0,0 +1,41 @@ +C -*- Mode: Fortran; -*- +C +C +C (C) 2012 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + character*(MPI_MAX_OBJECT_NAME) name + integer namelen + integer ierr, errs + + errs = 0 + + call mtest_init( ierr ) +C +C Check each Fortran datatype, including the size-specific ones +C See the C version (typename.c) for the relevant MPI sections + + call MPI_Type_get_name( MPI_AINT, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_AINT") then + errs = errs + 1 + print *, "Expected MPI_AINT but got "//name(1:namelen) + endif + + call MPI_Type_get_name( MPI_OFFSET, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_OFFSET") then + errs = errs + 1 + print *, "Expected MPI_OFFSET but got "//name(1:namelen) + endif + + call MPI_Type_get_name( MPI_COUNT, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_COUNT") then + errs = errs + 1 + print *, "Expected MPI_COUNT but got "//name(1:namelen) + endif + + call mtest_finalize( errs ) + call MPI_Finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/typenamef.f b/teshsuite/smpi/mpich3-test/f77/datatype/typenamef.f new file mode 100644 index 0000000000..611fbcfda1 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/typenamef.f @@ -0,0 +1,205 @@ +C -*- Mode: Fortran; -*- +C +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + character*(MPI_MAX_OBJECT_NAME) name + integer namelen + integer ierr, errs + + errs = 0 + + call mtest_init( ierr ) +C +C Check each Fortran datatype, including the size-specific ones +C See the C version (typename.c) for the relevant MPI sections + + call MPI_Type_get_name( MPI_COMPLEX, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_COMPLEX") then + errs = errs + 1 + print *, "Expected MPI_COMPLEX but got "//name(1:namelen) + endif + + call MPI_Type_get_name( MPI_DOUBLE_COMPLEX, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_DOUBLE_COMPLEX") then + errs = errs + 1 + print *, "Expected MPI_DOUBLE_COMPLEX but got "// + & name(1:namelen) + endif + + call MPI_Type_get_name( MPI_LOGICAL, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_LOGICAL") then + errs = errs + 1 + print *, "Expected MPI_LOGICAL but got "//name(1:namelen) + endif + + call MPI_Type_get_name( MPI_REAL, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_REAL") then + errs = errs + 1 + print *, "Expected MPI_REAL but got "//name(1:namelen) + endif + + call MPI_Type_get_name( MPI_DOUBLE_PRECISION, name, namelen, ierr) + if (name(1:namelen) .ne. "MPI_DOUBLE_PRECISION") then + errs = errs + 1 + print *, "Expected MPI_DOUBLE_PRECISION but got "// + & name(1:namelen) + endif + + call MPI_Type_get_name( MPI_INTEGER, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_INTEGER") then + errs = errs + 1 + print *, "Expected MPI_INTEGER but got "//name(1:namelen) + endif + + call MPI_Type_get_name( MPI_2INTEGER, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_2INTEGER") then + errs = errs + 1 + print *, "Expected MPI_2INTEGER but got "//name(1:namelen) + endif + +C 2COMPLEX was present only in MPI 1.0 +C call MPI_Type_get_name( MPI_2COMPLEX, name, namelen, ierr ) +C if (name(1:namelen) .ne. "MPI_2COMPLEX") then +C errs = errs + 1 +C print *, "Expected MPI_2COMPLEX but got "//name(1:namelen) +C endif +C + call MPI_Type_get_name(MPI_2DOUBLE_PRECISION, name, namelen, ierr) + if (name(1:namelen) .ne. "MPI_2DOUBLE_PRECISION") then + errs = errs + 1 + print *, "Expected MPI_2DOUBLE_PRECISION but got "// + & name(1:namelen) + endif + + call MPI_Type_get_name( MPI_2REAL, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_2REAL") then + errs = errs + 1 + print *, "Expected MPI_2REAL but got "//name(1:namelen) + endif + +C 2DOUBLE_COMPLEX isn't in MPI 2.1 +C call MPI_Type_get_name( MPI_2DOUBLE_COMPLEX, name, namelen, ierr ) +C if (name(1:namelen) .ne. "MPI_2DOUBLE_COMPLEX") then +C errs = errs + 1 +C print *, "Expected MPI_2DOUBLE_COMPLEX but got "// +C & name(1:namelen) +C endif + + call MPI_Type_get_name( MPI_CHARACTER, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_CHARACTER") then + errs = errs + 1 + print *, "Expected MPI_CHARACTER but got "//name(1:namelen) + endif + + call MPI_Type_get_name( MPI_BYTE, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_BYTE") then + errs = errs + 1 + print *, "Expected MPI_BYTE but got "//name(1:namelen) + endif + + if (MPI_REAL4 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_REAL4, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_REAL4") then + errs = errs + 1 + print *, "Expected MPI_REAL4 but got "//name(1:namelen) + endif + endif + + if (MPI_REAL8 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_REAL8, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_REAL8") then + errs = errs + 1 + print *, "Expected MPI_REAL8 but got "//name(1:namelen) + endif + endif + + if (MPI_REAL16 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_REAL16, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_REAL16") then + errs = errs + 1 + print *, "Expected MPI_REAL16 but got "//name(1:namelen) + endif + endif + + if (MPI_COMPLEX8 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_COMPLEX8, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_COMPLEX8") then + errs = errs + 1 + print *, "Expected MPI_COMPLEX8 but got "// + & name(1:namelen) + endif + endif + + if (MPI_COMPLEX16 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_COMPLEX16, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_COMPLEX16") then + errs = errs + 1 + print *, "Expected MPI_COMPLEX16 but got "// + & name(1:namelen) + endif + endif + + if (MPI_COMPLEX32 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_COMPLEX32, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_COMPLEX32") then + errs = errs + 1 + print *, "Expected MPI_COMPLEX32 but got "// + & name(1:namelen) + endif + endif + + if (MPI_INTEGER1 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_INTEGER1, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_INTEGER1") then + errs = errs + 1 + print *, "Expected MPI_INTEGER1 but got "// + & name(1:namelen) + endif + endif + + if (MPI_INTEGER2 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_INTEGER2, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_INTEGER2") then + errs = errs + 1 + print *, "Expected MPI_INTEGER2 but got "// + & name(1:namelen) + endif + endif + + if (MPI_INTEGER4 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_INTEGER4, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_INTEGER4") then + errs = errs + 1 + print *, "Expected MPI_INTEGER4 but got "// + & name(1:namelen) + endif + endif + + if (MPI_INTEGER8 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_INTEGER8, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_INTEGER8") then + errs = errs + 1 + print *, "Expected MPI_INTEGER8 but got "// + & name(1:namelen) + endif + endif + +C MPI_INTEGER16 is in MPI 2.1, but it is missing from most tables +C Some MPI implementations may not provide it +C if (MPI_INTEGER16 .ne. MPI_DATATYPE_NULL) then +C call MPI_Type_get_name( MPI_INTEGER16, name, namelen, ierr ) +C if (name(1:namelen) .ne. "MPI_INTEGER16") then +C errs = errs + 1 +C print *, "Expected MPI_INTEGER16 but got "// +C & name(1:namelen) +C endif +C endif + + call mtest_finalize( errs ) + call MPI_Finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/typesnamef.f b/teshsuite/smpi/mpich3-test/f77/datatype/typesnamef.f new file mode 100644 index 0000000000..b958c4998e --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/typesnamef.f @@ -0,0 +1,67 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + character*(MPI_MAX_OBJECT_NAME) cname + integer rlen, ln + integer ntype1, ntype2, errs, ierr + + errs = 0 + + call MTest_Init( ierr ) + + call mpi_type_vector( 10, 1, 100, MPI_INTEGER, ntype1, ierr ) + rlen = -1 + cname = 'XXXXXX' + call mpi_type_get_name( ntype1, cname, rlen, ierr ) + if (rlen .ne. 0) then + errs = errs + 1 + print *, ' Expected length 0, got ', rlen + endif + rlen = 0 + do ln=MPI_MAX_OBJECT_NAME,1,-1 + if (cname(ln:ln) .ne. ' ') then + rlen = ln + goto 100 + endif + enddo + 100 continue + if (rlen .ne. 0) then + errs = errs + 1 + print *, 'Datatype name is not all blank' + endif +C +C now add a name, then dup + call mpi_type_set_name( ntype1, 'a vector type', ierr ) + call mpi_type_dup( ntype1, ntype2, ierr ) + rlen = -1 + cname = 'XXXXXX' + call mpi_type_get_name( ntype2, cname, rlen, ierr ) + if (rlen .ne. 0) then + errs = errs + 1 + print *, ' (type2) Expected length 0, got ', rlen + endif + rlen = 0 + do ln=MPI_MAX_OBJECT_NAME,1,-1 + if (cname(ln:ln) .ne. ' ') then + rlen = ln + goto 110 + endif + enddo + 110 continue + if (rlen .ne. 0) then + errs = errs + 1 + print *, ' (type2) Datatype name is not all blank' + endif + + call mpi_type_free( ntype1, ierr ) + call mpi_type_free( ntype2, ierr ) + + call MTest_Finalize( errs ) + call MPI_Finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/typesubf.f b/teshsuite/smpi/mpich3-test/f77/datatype/typesubf.f new file mode 100644 index 0000000000..f175149231 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/typesubf.f @@ -0,0 +1,73 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + integer maxn, maxm + parameter (maxn=10,maxm=15) + integer fullsizes(2), subsizes(2), starts(2) + integer fullarr(maxn,maxm),subarr(maxn-3,maxm-4) + integer i,j, ssize + integer newtype, size, rank, ans + + errs = 0 + call mtest_init( ierr ) + call mpi_comm_size( MPI_COMM_WORLD, size, ierr ) + call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr ) +C +C Create a Fortran-style subarray + fullsizes(1) = maxn + fullsizes(2) = maxm + subsizes(1) = maxn - 3 + subsizes(2) = maxm - 4 +C starts are from zero, even in Fortran + starts(1) = 1 + starts(2) = 2 +C In Fortran 90 notation, the original array is +C integer a(maxn,maxm) +C and the subarray is +C a(1+1:(maxn-3) +(1+1)-1,2+1:(maxm-4)+(2+1)-1) +C i.e., a (start:(len + start - 1),...) + call mpi_type_create_subarray( 2, fullsizes, subsizes, starts, + & MPI_ORDER_FORTRAN, MPI_INTEGER, newtype, ierr ) + call mpi_type_commit( newtype, ierr ) +C +C Prefill the array + do j=1, maxm + do i=1, maxn + fullarr(i,j) = (i-1) + (j-1) * maxn + enddo + enddo + do j=1, subsizes(2) + do i=1, subsizes(1) + subarr(i,j) = -1 + enddo + enddo + ssize = subsizes(1)*subsizes(2) + call mpi_sendrecv( fullarr, 1, newtype, rank, 0, + & subarr, ssize, MPI_INTEGER, rank, 0, + & MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr ) +C +C Check the data + do j=1, subsizes(2) + do i=1, subsizes(1) + ans = (i+starts(1)-1) + (j+starts(2)-1) * maxn + if (subarr(i,j) .ne. ans) then + errs = errs + 1 + if (errs .le. 10) then + print *, rank, 'subarr(',i,',',j,') = ', subarr(i,j) + endif + endif + enddo + enddo + + call mpi_type_free( newtype, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/ext/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f77/ext/CMakeLists.txt new file mode 100644 index 0000000000..c14e134968 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/ext/CMakeLists.txt @@ -0,0 +1,65 @@ +cmake_minimum_required(VERSION 2.6) + +if(enable_smpi) + if(WIN32) + set(CMAKE_C_FLAGS "-include ${CMAKE_HOME_DIRECTORY}/include/smpi/smpi_main.h") + else() + set(CMAKE_C_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpicc") + set(CMAKE_Fortran_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpiff") + endif() + + set(EXECUTABLE_OUTPUT_PATH "${CMAKE_CURRENT_BINARY_DIR}") + set(MPICH_FLAGS "-DHAVE_STDLIB_H=1 -DHAVE_UNISTD_H=1 -DHAVE_STRING_H=1 -DUSE_STDARG=1 -DHAVE_LONG_DOUBLE=1 -DHAVE_PROTOTYPES=1 -DHAVE_SIGNAL_H=1 -DHAVE_SIGACTION=1 -DHAVE_SLEEP=1 -DHAVE_SYSCONF=1 -Wno-error=unused-variable -Wno-implicit") + include_directories("${CMAKE_HOME_DIRECTORY}/include/smpi") + include_directories("${CMAKE_CURRENT_BINARY_DIR}/../include/") + + + add_executable(add1size add1size.h ../util/mtestf.f) +# add_executable(allocmemf allocmemf.f ../util/mtestf.f) +# add_executable(c2f2cf c2f2cf.f c2f2c.c ../util/mtestf.f) +# add_executable(ctypesinf ctypesinf.f ctypesfromc.c ../util/mtestf.f) + + + + target_link_libraries(add1size simgrid) +# target_link_libraries(allocmemf simgrid) +# target_link_libraries(c2f2cf simgrid) +# target_link_libraries(ctypesinf simgrid) + + + + set_target_properties(add1size PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") +# set_target_properties(allocmemf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") +# set_target_properties(c2f2cf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") +# set_target_properties(ctypesinf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + +endif() + +set(tesh_files + ${tesh_files} + PARENT_SCOPE + ) +set(xml_files + ${xml_files} + PARENT_SCOPE + ) +set(examples_src + ${examples_src} + ${CMAKE_CURRENT_SOURCE_DIR}/add1size.h + ${CMAKE_CURRENT_SOURCE_DIR}/allocmemf.f + ${CMAKE_CURRENT_SOURCE_DIR}/c2f2cf.f + ${CMAKE_CURRENT_SOURCE_DIR}/c2f2c.c + ${CMAKE_CURRENT_SOURCE_DIR}/ctypesinf.f + ${CMAKE_CURRENT_SOURCE_DIR}/ctypesfromc.c + PARENT_SCOPE + ) +set(bin_files + ${bin_files} + PARENT_SCOPE + ) +set(txt_files + ${txt_files} + ${CMAKE_CURRENT_SOURCE_DIR}/runtests + ${CMAKE_CURRENT_SOURCE_DIR}/testlist + PARENT_SCOPE + ) diff --git a/teshsuite/smpi/mpich3-test/f77/ext/add1size.h b/teshsuite/smpi/mpich3-test/f77/ext/add1size.h new file mode 100644 index 0000000000..940a4c315a --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/ext/add1size.h @@ -0,0 +1,6 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + integer asize diff --git a/teshsuite/smpi/mpich3-test/f77/ext/allocmemf.f b/teshsuite/smpi/mpich3-test/f77/ext/allocmemf.f new file mode 100644 index 0000000000..cc8792d672 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/ext/allocmemf.f @@ -0,0 +1,41 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2004 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' +C +C This program makes use of a common (but not universal; g77 doesn't +C have it) extension: the "Cray" pointer. This allows MPI_Alloc_mem +C to allocate memory and return it to Fortran, where it can be used. +C As this is not standard Fortran, this test is not run by default. +C To run it, build (with a suitable compiler) and run with +C mpiexec -n 1 ./allocmemf +C + real a + pointer (p,a(100,100)) + include 'add1size.h' + integer ierr, sizeofreal, errs + integer i,j +C + errs = 0 + call mtest_init(ierr) + call mpi_type_size( MPI_REAL, sizeofreal, ierr ) +C Make sure we pass in an integer of the correct type + asize = sizeofreal * 100 * 100 + call mpi_alloc_mem( asize,MPI_INFO_NULL,p,ierr ) + + do i=1,100 + do j=1,100 + a(i,j) = -1 + enddo + enddo + a(3,5) = 10.0 + + call mpi_free_mem( a, ierr ) + call mtest_finalize(errs) + call mpi_finalize(ierr) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/ext/c2f2c.c b/teshsuite/smpi/mpich3-test/f77/ext/c2f2c.c new file mode 100644 index 0000000000..4e048b272f --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/ext/c2f2c.c @@ -0,0 +1,263 @@ +/* -*- Mode: C; c-basic-offset:4 ; indent-tabs-mode:nil ; -*- */ +/* + * + * (C) 2001 by Argonne National Laboratory. + * See COPYRIGHT in top-level directory. + */ +/* + * This file contains the C routines used in testing the c2f and f2c + * handle conversion functions, except for MPI_File and MPI_Win (to + * allow working with MPI implementations that do not include those + * features). + * + * The tests follow this pattern: + * + * Fortran main program + * calls c routine with each handle type, with a prepared + * and valid handle (often requires constructing an object) + * + * C routine uses xxx_f2c routine to get C handle, checks some + * properties (i.e., size and rank of communicator, contents of datatype) + * + * Then the Fortran main program calls a C routine that provides + * a handle, and the Fortran program performs similar checks. + * + * We also assume that a C int is a Fortran integer. If this is not the + * case, these tests must be modified. + */ + +/* style: allow:fprintf:10 sig:0 */ +#include +#include "mpi.h" +#include "../../include/mpitestconf.h" +#include + +/* + Name mapping. All routines are created with names that are lower case + with a single trailing underscore. This matches many compilers. + We use #define to change the name for Fortran compilers that do + not use the lowercase/underscore pattern +*/ + +#ifdef F77_NAME_UPPER +#define c2fcomm_ C2FCOMM +#define c2fgroup_ C2FGROUP +#define c2ftype_ C2FTYPE +#define c2finfo_ C2FINFO +#define c2frequest_ C2FREQUEST +#define c2fop_ C2FOP +#define c2ferrhandler_ C2FERRHANDLER + +#define f2ccomm_ F2CCOMM +#define f2cgroup_ F2CGROUP +#define f2ctype_ F2CTYPE +#define f2cinfo_ F2CINFO +#define f2crequest_ F2CREQUEST +#define f2cop_ F2COP +#define f2cerrhandler_ F2CERRHANDLER + +#elif defined(F77_NAME_LOWER) || defined(F77_NAME_MIXED) +/* Mixed is ok because we use lowercase in all uses */ +#define c2fcomm_ c2fcomm +#define c2fgroup_ c2fgroup +#define c2ftype_ c2ftype +#define c2finfo_ c2finfo +#define c2frequest_ c2frequest +#define c2fop_ c2fop +#define c2ferrhandler_ c2ferrhandler + +#define f2ccomm_ f2ccomm +#define f2cgroup_ f2cgroup +#define f2ctype_ f2ctype +#define f2cinfo_ f2cinfo +#define f2crequest_ f2crequest +#define f2cop_ f2cop +#define f2cerrhandler_ f2cerrhandler + +#elif defined(F77_NAME_LOWER_2USCORE) || defined(F77_NAME_LOWER_USCORE) || \ + defined(F77_NAME_MIXED_USCORE) +/* Else leave name alone (routines have no underscore, so both + of these map to a lowercase, single underscore) */ +#else +#error 'Unrecognized Fortran name mapping' +#endif + +/* Prototypes to keep compilers happy */ +MPI_Fint c2fcomm_( MPI_Fint * ); +MPI_Fint c2fgroup_( MPI_Fint * ); +MPI_Fint c2finfo_( MPI_Fint * ); +MPI_Fint c2frequest_( MPI_Fint * ); +MPI_Fint c2ftype_( MPI_Fint * ); +MPI_Fint c2fop_( MPI_Fint * ); +MPI_Fint c2ferrhandler_( MPI_Fint * ); + +void f2ccomm_( MPI_Fint * ); +void f2cgroup_( MPI_Fint * ); +void f2cinfo_( MPI_Fint * ); +void f2crequest_( MPI_Fint * ); +void f2ctype_( MPI_Fint * ); +void f2cop_( MPI_Fint * ); +void f2cerrhandler_( MPI_Fint * ); + + +MPI_Fint c2fcomm_ (MPI_Fint *comm) +{ + MPI_Comm cComm = MPI_Comm_f2c(*comm); + int cSize, wSize, cRank, wRank; + + MPI_Comm_size( MPI_COMM_WORLD, &wSize ); + MPI_Comm_rank( MPI_COMM_WORLD, &wRank ); + MPI_Comm_size( cComm, &cSize ); + MPI_Comm_rank( cComm, &cRank ); + + if (wSize != cSize || wRank != cRank) { + fprintf( stderr, "Comm: Did not get expected size,rank (got %d,%d)", + cSize, cRank ); + return 1; + } + return 0; +} + +MPI_Fint c2fgroup_ (MPI_Fint *group) +{ + MPI_Group cGroup = MPI_Group_f2c(*group); + int cSize, wSize, cRank, wRank; + + /* We pass in the group of comm world */ + MPI_Comm_size( MPI_COMM_WORLD, &wSize ); + MPI_Comm_rank( MPI_COMM_WORLD, &wRank ); + MPI_Group_size( cGroup, &cSize ); + MPI_Group_rank( cGroup, &cRank ); + + if (wSize != cSize || wRank != cRank) { + fprintf( stderr, "Group: Did not get expected size,rank (got %d,%d)", + cSize, cRank ); + return 1; + } + return 0; +} + +MPI_Fint c2ftype_ ( MPI_Fint *type ) +{ + MPI_Datatype dtype = MPI_Type_f2c( *type ); + + if (dtype != MPI_INTEGER) { + fprintf( stderr, "Type: Did not get expected type\n" ); + return 1; + } + return 0; +} + +MPI_Fint c2finfo_ ( MPI_Fint *info ) +{ + MPI_Info cInfo = MPI_Info_f2c( *info ); + int flag; + char value[100]; + MPI_Fint errs = 0; + + MPI_Info_get( cInfo, (char*)"host", sizeof(value), value, &flag ); + if (!flag || strcmp(value,"myname") != 0) { + fprintf( stderr, "Info: Wrong value or no value for host\n" ); + errs++; + } + MPI_Info_get( cInfo, (char*)"wdir", sizeof(value), value, &flag ); + if (!flag || strcmp( value, "/rdir/foo" ) != 0) { + fprintf( stderr, "Info: Wrong value of no value for wdir\n" ); + errs++; + } + + return errs; +} + +MPI_Fint c2frequest_ ( MPI_Fint *request ) +{ + MPI_Request req = MPI_Request_f2c( *request ); + MPI_Status status; + int flag; + MPI_Test( &req, &flag, &status ); + MPI_Test_cancelled( &status, &flag ); + if (!flag) { + fprintf( stderr, "Request: Wrong value for flag\n" ); + return 1; + } + else { + *request = MPI_Request_c2f( req ); + } + return 0; +} + +MPI_Fint c2fop_ ( MPI_Fint *op ) +{ + MPI_Op cOp = MPI_Op_f2c( *op ); + + if (cOp != MPI_SUM) { + fprintf( stderr, "Op: did not get sum\n" ); + return 1; + } + return 0; +} + +MPI_Fint c2ferrhandler_ ( MPI_Fint *errh ) +{ + MPI_Errhandler errhand = MPI_Errhandler_f2c( *errh ); + + if (errhand != MPI_ERRORS_RETURN) { + fprintf( stderr, "Errhandler: did not get errors return\n" ); + return 1; + } + + return 0; +} + +/* + * The following routines provide handles to the calling Fortran program + */ +void f2ccomm_( MPI_Fint * comm ) +{ + *comm = MPI_Comm_c2f( MPI_COMM_WORLD ); +} + +void f2cgroup_( MPI_Fint * group ) +{ + MPI_Group wgroup; + MPI_Comm_group( MPI_COMM_WORLD, &wgroup ); + *group = MPI_Group_c2f( wgroup ); +} + +void f2ctype_( MPI_Fint * type ) +{ + *type = MPI_Type_c2f( MPI_INTEGER ); +} + +void f2cinfo_( MPI_Fint * info ) +{ + MPI_Info cinfo; + + MPI_Info_create( &cinfo ); + MPI_Info_set( cinfo, (char*)"host", (char*)"myname" ); + MPI_Info_set( cinfo, (char*)"wdir", (char*)"/rdir/foo" ); + + *info = MPI_Info_c2f( cinfo ); +} + +void f2crequest_( MPI_Fint * req ) +{ + MPI_Request cReq; + + MPI_Irecv( NULL, 0, MPI_INT, MPI_ANY_SOURCE, MPI_ANY_TAG, + MPI_COMM_WORLD, &cReq ); + MPI_Cancel( &cReq ); + *req = MPI_Request_c2f( cReq ); + +} + +void f2cop_( MPI_Fint * op ) +{ + *op = MPI_Op_c2f( MPI_SUM ); +} + +void f2cerrhandler_( MPI_Fint *errh ) +{ + *errh = MPI_Errhandler_c2f( MPI_ERRORS_RETURN ); +} + diff --git a/teshsuite/smpi/mpich3-test/f77/ext/c2f2cf.f b/teshsuite/smpi/mpich3-test/f77/ext/c2f2cf.f new file mode 100644 index 0000000000..175592572d --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/ext/c2f2cf.f @@ -0,0 +1,121 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, toterrs, ierr + integer wrank, wsize + integer wgroup, info, req + integer fsize, frank + integer comm, group, type, op, errh, result + integer c2fcomm, c2fgroup, c2ftype, c2finfo, c2frequest, + $ c2ferrhandler, c2fop + character value*100 + logical flag + errs = 0 + + call mpi_init( ierr ) + +C +C Test passing a Fortran MPI object to C + call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr ) + errs = errs + c2fcomm( MPI_COMM_WORLD ) + call mpi_comm_group( MPI_COMM_WORLD, wgroup, ierr ) + errs = errs + c2fgroup( wgroup ) + call mpi_group_free( wgroup, ierr ) + + call mpi_info_create( info, ierr ) + call mpi_info_set( info, "host", "myname", ierr ) + call mpi_info_set( info, "wdir", "/rdir/foo", ierr ) + errs = errs + c2finfo( info ) + call mpi_info_free( info, ierr ) + + errs = errs + c2ftype( MPI_INTEGER ) + + call mpi_irecv( 0, 0, MPI_INTEGER, MPI_ANY_SOURCE, MPI_ANY_TAG, + $ MPI_COMM_WORLD, req, ierr ) + call mpi_cancel( req, ierr ) + errs = errs + c2frequest( req ) + call mpi_wait( req, MPI_STATUS_IGNORE, ierr ) + + errs = errs + c2ferrhandler( MPI_ERRORS_RETURN ) + + errs = errs + c2fop( MPI_SUM ) + +C +C Test using a C routine to provide the Fortran handle + call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr ) + call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr ) + + call f2ccomm( comm ) + call mpi_comm_size( comm, fsize, ierr ) + call mpi_comm_rank( comm, frank, ierr ) + if (fsize.ne.wsize .or. frank.ne.wrank) then + errs = errs + 1 + print *, "Comm(fortran) has wrong size or rank" + endif + + call f2cgroup( group ) + call mpi_group_size( group, fsize, ierr ) + call mpi_group_rank( group, frank, ierr ) + if (fsize.ne.wsize .or. frank.ne.wrank) then + errs = errs + 1 + print *, "Group(fortran) has wrong size or rank" + endif + call mpi_group_free( group, ierr ) + + call f2ctype( type ) + if (type .ne. MPI_INTEGER) then + errs = errs + 1 + print *, "Datatype(fortran) is not MPI_INT" + endif + + call f2cinfo( info ) + call mpi_info_get( info, "host", 100, value, flag, ierr ) + if (.not. flag) then + errs = errs + 1 + print *, "Info test for host returned false" + else if (value .ne. "myname") then + errs = errs + 1 + print *, "Info test for host returned ", value + endif + call mpi_info_get( info, "wdir", 100, value, flag, ierr ) + if (.not. flag) then + errs = errs + 1 + print *, "Info test for wdir returned false" + else if (value .ne. "/rdir/foo") then + errs = errs + 1 + print *, "Info test for wdir returned ", value + endif + call mpi_info_free( info, ierr ) + + call f2cop( op ) + if (op .ne. MPI_SUM) then + errs = errs + 1 + print *, "Fortran MPI_SUM not MPI_SUM in C" + endif + + call f2cerrhandler( errh ) + if (errh .ne. MPI_ERRORS_RETURN) then + errs = errs + 1 + print *,"Fortran MPI_ERRORS_RETURN not MPI_ERRORS_RETURN in C" + endif +C +C Summarize the errors +C + call mpi_allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, + $ MPI_COMM_WORLD, ierr ) + if (wrank .eq. 0) then + if (toterrs .eq. 0) then + print *, ' No Errors' + else + print *, ' Found ', toterrs, ' errors' + endif + endif + + call mpi_finalize( ierr ) + end + diff --git a/teshsuite/smpi/mpich3-test/f77/ext/c2fmult.c b/teshsuite/smpi/mpich3-test/f77/ext/c2fmult.c new file mode 100644 index 0000000000..07c21d6e36 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/ext/c2fmult.c @@ -0,0 +1,60 @@ +/* -*- Mode: C; c-basic-offset:4 ; indent-tabs-mode:nil ; -*- */ +/* + * (C) 2001 by Argonne National Laboratory. + * See COPYRIGHT in top-level directory. + */ + +/* + Check that MPI_xxxx_c2f, applied to the same object several times, + yields the same handle. We do this because when MPI handles in + C are a different length than those in Fortran, care needs to + be exercised to ensure that the mapping from one to another is unique. + (Test added to test a potential problem in ROMIO for handling MPI_File + on 64-bit systems) +*/ +#include "mpi.h" +#include +#include "mpitest.h" + +int main( int argc, char *argv[] ) +{ + MPI_Fint handleA, handleB; + int rc; + int errs = 0; + int buf[1]; + MPI_Request cRequest; + MPI_Status st; + int tFlag; + + MTest_Init( &argc, &argv ); + + /* Request */ + rc = MPI_Irecv( buf, 1, MPI_INT, 0, 0, MPI_COMM_WORLD, &cRequest ); + if (rc) { + errs++; + printf( "Unable to create request\n" ); + } + else { + handleA = MPI_Request_c2f( cRequest ); + handleB = MPI_Request_c2f( cRequest ); + if (handleA != handleB) { + errs++; + printf( "MPI_Request_c2f does not give the same handle twice on the same MPI_Request\n" ); + } + } + MPI_Cancel( &cRequest ); + MPI_Test( &cRequest, &tFlag, &st ); + MPI_Test_cancelled( &st, &tFlag ); + if (!tFlag) { + errs++; + printf( "Unable to cancel MPI_Irecv request\n" ); + } + /* Using MPI_Request_free should be ok, but some MPI implementations + object to it imediately after the cancel and that isn't essential to + this test */ + + MTest_Finalize( errs ); + MPI_Finalize(); + + return 0; +} diff --git a/teshsuite/smpi/mpich3-test/f77/ext/ctypesfromc.c b/teshsuite/smpi/mpich3-test/f77/ext/ctypesfromc.c new file mode 100644 index 0000000000..51015da908 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/ext/ctypesfromc.c @@ -0,0 +1,118 @@ +/* -*- Mode: C; c-basic-offset:4 ; indent-tabs-mode:nil ; -*- */ +/* + * + * (C) 2008 by Argonne National Laboratory. + * See COPYRIGHT in top-level directory. + */ +/* + * This file contains the C routines used in testing that all C datatypes + * are available in Fortran and have the correct values. + * + * The tests follow this pattern: + * + * Fortran main program + * calls the c routine f2ctype with each of the C types and the name of + * the type. That c routine using MPI_Type_f2c to convert the + * Fortran handle to a C handle, and then compares it to the corresponding + * C type, which is found by looking up the C handle by name + * + * C routine uses xxx_f2c routine to get C handle, checks some + * properties (i.e., size and rank of communicator, contents of datatype) + * + * Then the Fortran main program calls a C routine that provides + * a handle, and the Fortran program performs similar checks. + * + * We also assume that a C int is a Fortran integer. If this is not the + * case, these tests must be modified. + */ + +/* style: allow:fprintf:10 sig:0 */ +#include +#include "mpi.h" +#include "../../include/mpitestconf.h" +#include + +/* Create an array with all of the MPI names in it */ +/* This is extracted from the test in test/mpi/types/typename.c ; only the + C types are included. */ + +typedef struct mpi_names_t { MPI_Datatype dtype; const char *name; } mpi_names_t; + +/* The MPI standard specifies that the names must be the MPI names, + not the related language names (e.g., MPI_CHAR, not char) */ + +static mpi_names_t mpi_names[] = { + { MPI_CHAR, "MPI_CHAR" }, + { MPI_SIGNED_CHAR, "MPI_SIGNED_CHAR" }, + { MPI_UNSIGNED_CHAR, "MPI_UNSIGNED_CHAR" }, + { MPI_WCHAR, "MPI_WCHAR" }, + { MPI_SHORT, "MPI_SHORT" }, + { MPI_UNSIGNED_SHORT, "MPI_UNSIGNED_SHORT" }, + { MPI_INT, "MPI_INT" }, + { MPI_UNSIGNED, "MPI_UNSIGNED" }, + { MPI_LONG, "MPI_LONG" }, + { MPI_UNSIGNED_LONG, "MPI_UNSIGNED_LONG" }, + { MPI_FLOAT, "MPI_FLOAT" }, + { MPI_DOUBLE, "MPI_DOUBLE" }, + { MPI_FLOAT_INT, "MPI_FLOAT_INT" }, + { MPI_DOUBLE_INT, "MPI_DOUBLE_INT" }, + { MPI_LONG_INT, "MPI_LONG_INT" }, + { MPI_SHORT_INT, "MPI_SHORT_INT" }, + { MPI_2INT, "MPI_2INT" }, + { MPI_LONG_DOUBLE, "MPI_LONG_DOUBLE" }, + { MPI_LONG_LONG_INT, "MPI_LONG_LONG_INT" }, + { MPI_LONG_LONG, "MPI_LONG_LONG" }, + { MPI_UNSIGNED_LONG_LONG, "MPI_UNSIGNED_LONG_LONG" }, + { MPI_LONG_DOUBLE_INT, "MPI_LONG_DOUBLE_INT" }, + { 0, (char *)0 }, /* Sentinal used to indicate the last element */ +}; + +/* + Name mapping. All routines are created with names that are lower case + with a single trailing underscore. This matches many compilers. + We use #define to change the name for Fortran compilers that do + not use the lowercase/underscore pattern +*/ + +#ifdef F77_NAME_UPPER +#define f2ctype_ F2CTYPE + +#elif defined(F77_NAME_LOWER) || defined(F77_NAME_MIXED) +/* Mixed is ok because we use lowercase in all uses */ +#define f2ctype_ f2ctype + +#elif defined(F77_NAME_LOWER_2USCORE) || defined(F77_NAME_LOWER_USCORE) || \ + defined(F77_NAME_MIXED_USCORE) +/* Else leave name alone (routines have no underscore, so both + of these map to a lowercase, single underscore) */ +#else +#error 'Unrecognized Fortran name mapping' +#endif + +/* Prototypes to keep compilers happy */ +int f2ctype_( MPI_Fint *, MPI_Fint * ); + +/* */ +int f2ctype_( MPI_Fint *fhandle, MPI_Fint *typeidx ) +{ + int errs = 0; + MPI_Datatype ctype; + + /* printf( "Testing %s\n", mpi_names[*typeidx].name ); */ + ctype = MPI_Type_f2c( *fhandle ); + if (ctype != mpi_names[*typeidx].dtype) { + char mytypename[MPI_MAX_OBJECT_NAME]; + int mytypenamelen; + /* An implementation is not *required* to deliver the + corresponding C version of the MPI Datatype bit-for-bit. But + if *must* act like it - e.g., the datatype name must be the same */ + MPI_Type_get_name( ctype, mytypename, &mytypenamelen ); + if (strcmp( mytypename, mpi_names[*typeidx].name ) != 0) { + errs++; + printf( "C and Fortran types for %s (c name is %s) do not match f=%d, ctof=%d.\n", + mpi_names[*typeidx].name, mytypename, *fhandle, MPI_Type_c2f( ctype ) ); + } + } + + return errs; +} diff --git a/teshsuite/smpi/mpich3-test/f77/ext/ctypesinf.f b/teshsuite/smpi/mpich3-test/f77/ext/ctypesinf.f new file mode 100644 index 0000000000..4693bc87c1 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/ext/ctypesinf.f @@ -0,0 +1,49 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2010 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + include 'mpif.h' + integer ierr + integer errs, wrank + integer f2ctype +C + call mtest_init( ierr ) + call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr ) +C + errs = 0 +C + errs = errs + f2ctype( MPI_CHAR, 0 ) + errs = errs + f2ctype( MPI_SIGNED_CHAR, 1 ) + errs = errs + f2ctype( MPI_UNSIGNED_CHAR, 2 ) + errs = errs + f2ctype( MPI_WCHAR, 3 ) + errs = errs + f2ctype( MPI_SHORT, 4 ) + errs = errs + f2ctype( MPI_UNSIGNED_SHORT, 5 ) + errs = errs + f2ctype( MPI_INT, 6 ) + errs = errs + f2ctype( MPI_UNSIGNED, 7 ) + errs = errs + f2ctype( MPI_LONG, 8 ) + errs = errs + f2ctype( MPI_UNSIGNED_LONG, 9 ) + errs = errs + f2ctype( MPI_FLOAT, 10 ) + errs = errs + f2ctype( MPI_DOUBLE, 11 ) + errs = errs + f2ctype( MPI_FLOAT_INT, 12 ) + errs = errs + f2ctype( MPI_DOUBLE_INT, 13 ) + errs = errs + f2ctype( MPI_LONG_INT, 14 ) + errs = errs + f2ctype( MPI_SHORT_INT, 15 ) + errs = errs + f2ctype( MPI_2INT, 16 ) + if (MPI_LONG_DOUBLE .ne. MPI_TYPE_NULL) then + errs = errs + f2ctype( MPI_LONG_DOUBLE, 17 ) + errs = errs + f2ctype( MPI_LONG_DOUBLE_INT, 21 ) + endif + if (MPI_LONG_LONG .ne. MPI_TYPE_NULL) then + errs = errs + f2ctype( MPI_LONG_LONG_INT, 18 ) + errs = errs + f2ctype( MPI_LONG_LONG, 19 ) + errs = errs + f2ctype( MPI_UNSIGNED_LONG_LONG, 20 ) + endif +C +C Summarize the errors +C + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/ext/testlist b/teshsuite/smpi/mpich3-test/f77/ext/testlist new file mode 100644 index 0000000000..745768e0cb --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/ext/testlist @@ -0,0 +1,4 @@ +#c2f2cf 1 +#c2fmult 1 +#ctypesinf 1 + diff --git a/teshsuite/smpi/mpich3-test/f77/init/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f77/init/CMakeLists.txt new file mode 100644 index 0000000000..2a756bc8ae --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/init/CMakeLists.txt @@ -0,0 +1,51 @@ +cmake_minimum_required(VERSION 2.6) + +if(enable_smpi) + if(WIN32) + set(CMAKE_C_FLAGS "-include ${CMAKE_HOME_DIRECTORY}/include/smpi/smpi_main.h") + else() + set(CMAKE_C_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpicc") + set(CMAKE_Fortran_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpiff") + endif() + + set(EXECUTABLE_OUTPUT_PATH "${CMAKE_CURRENT_BINARY_DIR}") + set(MPICH_FLAGS "-DHAVE_STDLIB_H=1 -DHAVE_UNISTD_H=1 -DHAVE_STRING_H=1 -DUSE_STDARG=1 -DHAVE_LONG_DOUBLE=1 -DHAVE_PROTOTYPES=1 -DHAVE_SIGNAL_H=1 -DHAVE_SIGACTION=1 -DHAVE_SLEEP=1 -DHAVE_SYSCONF=1 -Wno-error=unused-variable -Wno-implicit") + include_directories("${CMAKE_HOME_DIRECTORY}/include/smpi") + include_directories("${CMAKE_CURRENT_BINARY_DIR}/../include/") + + + add_executable(baseenvf baseenvf.f ../util/mtestf.f) + + + + target_link_libraries(baseenvf simgrid) + + + + set_target_properties(baseenvf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + +endif() + +set(tesh_files + ${tesh_files} + PARENT_SCOPE + ) +set(xml_files + ${xml_files} + PARENT_SCOPE + ) +set(examples_src + ${examples_src} + ${CMAKE_CURRENT_SOURCE_DIR}/baseenvf.f + PARENT_SCOPE + ) +set(bin_files + ${bin_files} + PARENT_SCOPE + ) +set(txt_files + ${txt_files} + ${CMAKE_CURRENT_SOURCE_DIR}/runtests + ${CMAKE_CURRENT_SOURCE_DIR}/testlist + PARENT_SCOPE + ) diff --git a/teshsuite/smpi/mpich3-test/f77/init/baseenvf.f b/teshsuite/smpi/mpich3-test/f77/init/baseenvf.f new file mode 100644 index 0000000000..b8b1f6ca0f --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/init/baseenvf.f @@ -0,0 +1,90 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer ierr, provided, errs, rank, size + integer iv, isubv, qprovided + logical flag + + errs = 0 + flag = .true. + call mpi_finalized( flag, ierr ) + if (flag) then + errs = errs + 1 + print *, 'Returned true for finalized before init' + endif + flag = .true. + call mpi_initialized( flag, ierr ) + if (flag) then + errs = errs + 1 + print *, 'Return true for initialized before init' + endif + + provided = -1 + call mpi_init_thread( MPI_THREAD_MULTIPLE, provided, ierr ) + + if (provided .ne. MPI_THREAD_MULTIPLE .and. + & provided .ne. MPI_THREAD_SERIALIZED .and. + & provided .ne. MPI_THREAD_FUNNELED .and. + & provided .ne. MPI_THREAD_SINGLE) then + errs = errs + 1 + print *, ' Unrecognized value for provided = ', provided + endif + + iv = -1 + isubv = -1 + call mpi_get_version( iv, isubv, ierr ) + if (iv .ne. MPI_VERSION .or. isubv .ne. MPI_SUBVERSION) then + errs = errs + 1 + print *, 'Version in mpif.h and get_version do not agree' + print *, 'Version in mpif.h is ', MPI_VERSION, '.', + & MPI_SUBVERSION + print *, 'Version in get_version is ', iv, '.', isubv + endif + if (iv .lt. 1 .or. iv .gt. 3) then + errs = errs + 1 + print *, 'Version of MPI is invalid (=', iv, ')' + endif + if (isubv.lt.0 .or. isubv.gt.2) then + errs = errs + 1 + print *, 'Subversion of MPI is invalid (=', isubv, ')' + endif + + call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr ) + call mpi_comm_size( MPI_COMM_WORLD, size, ierr ) + + flag = .false. + call mpi_is_thread_main( flag, ierr ) + if (.not.flag) then + errs = errs + 1 + print *, 'is_thread_main returned false for main thread' + endif + + call mpi_query_thread( qprovided, ierr ) + if (qprovided .ne. provided) then + errs = errs + 1 + print *,'query thread and init thread disagree on'// + & ' thread level' + endif + + call mpi_finalize( ierr ) + flag = .false. + call mpi_finalized( flag, ierr ) + if (.not. flag) then + errs = errs + 1 + print *, 'finalized returned false after finalize' + endif + + if (rank .eq. 0) then + if (errs .eq. 0) then + print *, ' No Errors' + else + print *, ' Found ', errs, ' errors' + endif + endif + + end diff --git a/teshsuite/smpi/mpich3-test/f77/init/checksizes.c b/teshsuite/smpi/mpich3-test/f77/init/checksizes.c new file mode 100644 index 0000000000..e91dc8d7d6 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/init/checksizes.c @@ -0,0 +1,23 @@ +#include "mpi.h" +#include +int main( int argc, char **argv ) +{ + int fsizeof_aint = ; + int fsizeof_offset = ; + int err = 0, rc = 0; + + MPI_Init( &argc, &argv ); + if (sizeof(MPI_Aint) != fsizeof_aint) { + printf( "Sizeof MPI_Aint is %d but Fortran thinks it is %d\n", + (int)sizeof(MPI_Aint), fsizeof_aint ); + err++; + } + if (sizeof(MPI_Offset) != fsizeof_offset) { + printf( "Sizeof MPI_Offset is %d but Fortran thinks it is %d\n", + (int)sizeof(MPI_Offset), fsizeof_offset ); + err++; + } + MPI_Finalize( ); + if (err > 0) rc = 1; + return rc; +} diff --git a/teshsuite/smpi/mpich3-test/f77/init/testlist b/teshsuite/smpi/mpich3-test/f77/init/testlist new file mode 100644 index 0000000000..0b0b623fd2 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/init/testlist @@ -0,0 +1 @@ +baseenvf 1 diff --git a/teshsuite/smpi/mpich3-test/f77/pt2pt/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f77/pt2pt/CMakeLists.txt new file mode 100644 index 0000000000..3af650ced0 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/pt2pt/CMakeLists.txt @@ -0,0 +1,61 @@ +cmake_minimum_required(VERSION 2.6) + +if(enable_smpi) + if(WIN32) + set(CMAKE_C_FLAGS "-include ${CMAKE_HOME_DIRECTORY}/include/smpi/smpi_main.h") + else() + set(CMAKE_C_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpicc") + set(CMAKE_Fortran_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpiff") + endif() + + set(EXECUTABLE_OUTPUT_PATH "${CMAKE_CURRENT_BINARY_DIR}") + set(MPICH_FLAGS "-DHAVE_STDLIB_H=1 -DHAVE_UNISTD_H=1 -DHAVE_STRING_H=1 -DUSE_STDARG=1 -DHAVE_LONG_DOUBLE=1 -DHAVE_PROTOTYPES=1 -DHAVE_SIGNAL_H=1 -DHAVE_SIGACTION=1 -DHAVE_SLEEP=1 -DHAVE_SYSCONF=1 -Wno-error=unused-variable -Wno-implicit -g") + include_directories("${CMAKE_HOME_DIRECTORY}/include/smpi") + include_directories("${CMAKE_CURRENT_BINARY_DIR}/../include/") + + + add_executable(allpairf allpairf.f ../util/mtestf.f) + add_executable(greqf greqf.f dummyf.f ../util/mtestf.f) + #add_executable(mprobef mprobef.f ../util/mtestf.f) + add_executable(statusesf statusesf.f ../util/mtestf.f) + + target_link_libraries(allpairf simgrid) + target_link_libraries(greqf simgrid) + #target_link_libraries(mprobef simgrid) + target_link_libraries(statusesf simgrid) + + set_target_properties(allpairf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(greqf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + #set_target_properties(mprobef PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(statusesf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + +endif() + +set(tesh_files + ${tesh_files} + PARENT_SCOPE + ) +set(xml_files + ${xml_files} + PARENT_SCOPE + ) +set(examples_src + ${examples_src} + ${CMAKE_CURRENT_SOURCE_DIR}/allpairf.f + ${CMAKE_CURRENT_SOURCE_DIR}/attr1aints.h + ${CMAKE_CURRENT_SOURCE_DIR}/dummyf.f + ${CMAKE_CURRENT_SOURCE_DIR}/greqf.f + ${CMAKE_CURRENT_SOURCE_DIR}/mprobef.f + ${CMAKE_CURRENT_SOURCE_DIR}/statusesf.f + PARENT_SCOPE + ) +set(bin_files + ${bin_files} + PARENT_SCOPE + ) +set(txt_files + ${txt_files} + ${CMAKE_CURRENT_SOURCE_DIR}/runtests + ${CMAKE_CURRENT_SOURCE_DIR}/testlist + PARENT_SCOPE + ) diff --git a/teshsuite/smpi/mpich3-test/f77/pt2pt/allpairf.f b/teshsuite/smpi/mpich3-test/f77/pt2pt/allpairf.f new file mode 100644 index 0000000000..750c56816c --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/pt2pt/allpairf.f @@ -0,0 +1,1029 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2012 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C This program is based on the allpair.f test from the MPICH-1 test +C (test/pt2pt/allpair.f), which in turn was inspired by a bug report from +C fsset@corelli.lerc.nasa.gov (Scott Townsend) + + program allpair + implicit none + include 'mpif.h' + integer ierr, errs, comm + logical mtestGetIntraComm + logical verbose + common /flags/ verbose + + errs = 0 + verbose = .false. +C verbose = .true. + call MTest_Init( ierr ) + + do while ( mtestGetIntraComm( comm, 2, .false. ) ) + call test_pair_send( comm, errs ) + call test_pair_ssend( comm, errs ) + !call test_pair_rsend( comm, errs ) + call test_pair_isend( comm, errs ) + !call test_pair_irsend( comm, errs ) + call test_pair_issend( comm, errs ) + !call test_pair_psend( comm, errs ) + !call test_pair_prsend( comm, errs ) + call test_pair_pssend( comm, errs ) + call test_pair_sendrecv( comm, errs ) + call test_pair_sendrecvrepl( comm, errs ) + call mtestFreeComm( comm ) + enddo +C + call MTest_Finalize( errs ) + call MPI_Finalize(ierr) +C + end +C + subroutine test_pair_send( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer status(MPI_STATUS_SIZE) + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' Send and recv' + endif +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 1123 + count = TEST_SIZE / 5 +C + call clear_test_data(recv_buf,TEST_SIZE) +C + if (rank .eq. 0) then +C + call init_test_data(send_buf,TEST_SIZE) +C + call MPI_Send(send_buf, count, MPI_REAL, next, tag, + . comm, ierr) +C + call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, status, ierr) +C + call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, + . 'send and recv', errs ) + else if (prev .eq. 0) then + call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, status, ierr) + + call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, + . 'send and recv', errs ) +C + call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, comm, ierr) + end if +C + end +C + subroutine test_pair_rsend( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count, i + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer status(MPI_STATUS_SIZE), requests(1) + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' Rsend and recv' + endif +C +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 1456 + count = TEST_SIZE / 3 +C + call clear_test_data(recv_buf,TEST_SIZE) +C + if (rank .eq. 0) then +C + call init_test_data(send_buf,TEST_SIZE) +C + call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag, + . comm, status, ierr ) +C + call MPI_Rsend(send_buf, count, MPI_REAL, next, tag, + . comm, ierr) +C + call MPI_Probe(MPI_ANY_SOURCE, tag, comm, status, ierr) +C + if (status(MPI_SOURCE) .ne. next) then + print *, 'Rsend: Incorrect source, expected', next, + . ', got', status(MPI_SOURCE) + errs = errs + 1 + end if +C + if (status(MPI_TAG) .ne. tag) then + print *, 'Rsend: Incorrect tag, expected', tag, + . ', got', status(MPI_TAG) + errs = errs + 1 + end if +C + call MPI_Get_count(status, MPI_REAL, i, ierr) +C + if (i .ne. count) then + print *, 'Rsend: Incorrect count, expected', count, + . ', got', i + errs = errs + 1 + end if +C + call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . status, ierr) +C + call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, + . 'rsend and recv', errs ) +C + else if (prev .eq. 0) then +C + call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . requests(1), ierr) + call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, prev, tag, + . comm, ierr ) + call MPI_Wait( requests(1), status, ierr ) + call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, + . 'rsend and recv', errs ) +C + call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, + . comm, ierr) + end if +C + end +C + subroutine test_pair_ssend( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count, i + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer status(MPI_STATUS_SIZE) + logical flag + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' Ssend and recv' + endif +C +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 1789 + count = TEST_SIZE / 3 +C + call clear_test_data(recv_buf,TEST_SIZE) +C + if (rank .eq. 0) then +C + call init_test_data(send_buf,TEST_SIZE) +C + call MPI_Iprobe(MPI_ANY_SOURCE, tag, + . comm, flag, status, ierr) +C + if (flag) then + print *, 'Ssend: Iprobe succeeded! source', + . status(MPI_SOURCE), + . ', tag', status(MPI_TAG) + errs = errs + 1 + end if +C + call MPI_Ssend(send_buf, count, MPI_REAL, next, tag, + . comm, ierr) +C + do while (.not. flag) + call MPI_Iprobe(MPI_ANY_SOURCE, tag, + . comm, flag, status, ierr) + end do +C + if (status(MPI_SOURCE) .ne. next) then + print *, 'Ssend: Incorrect source, expected', next, + . ', got', status(MPI_SOURCE) + errs = errs + 1 + end if +C + if (status(MPI_TAG) .ne. tag) then + print *, 'Ssend: Incorrect tag, expected', tag, + . ', got', status(MPI_TAG) + errs = errs + 1 + end if +C + call MPI_Get_count(status, MPI_REAL, i, ierr) +C + if (i .ne. count) then + print *, 'Ssend: Incorrect count, expected', count, + . ', got', i + errs = errs + 1 + end if +C + call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . status, ierr) +C + call msg_check( recv_buf, next, tag, count, status, + . TEST_SIZE, 'ssend and recv', errs ) +C + else if (prev .eq. 0) then +C + call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . status, ierr) +C + call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, + . 'ssend and recv', errs ) +C + call MPI_Ssend(recv_buf, count, MPI_REAL, prev, tag, + . comm, ierr) + end if +C + end +C + subroutine test_pair_isend( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer status(MPI_STATUS_SIZE), requests(2) + integer statuses(MPI_STATUS_SIZE,2) + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' isend and irecv' + endif +C +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 2123 + count = TEST_SIZE / 5 +C + call clear_test_data(recv_buf,TEST_SIZE) +C + if (rank .eq. 0) then +C + call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . requests(1), ierr) +C + call init_test_data(send_buf,TEST_SIZE) +C + call MPI_Isend(send_buf, count, MPI_REAL, next, tag, + . comm, requests(2), ierr) +C + call MPI_Waitall(2, requests, statuses, ierr) +C + call rq_check( requests, 2, 'isend and irecv' ) +C + call msg_check( recv_buf, next, tag, count, statuses(1,1), + . TEST_SIZE, 'isend and irecv', errs ) +C + else if (prev .eq. 0) then +C + call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . status, ierr) +C + call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, + . 'isend and irecv', errs ) +C + call MPI_Isend(recv_buf, count, MPI_REAL, prev, tag, + . comm, requests(1), ierr) +C + call MPI_Wait(requests(1), status, ierr) +C +C call rq_check( requests(1), 1, 'isend and irecv' ) +C + end if +C + end +C + subroutine test_pair_irsend( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count, index, i + integer TEST_SIZE + integer dupcom + parameter (TEST_SIZE=2000) + integer status(MPI_STATUS_SIZE), requests(2) + integer statuses(MPI_STATUS_SIZE,2) + logical flag + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' Irsend and irecv' + endif +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + call mpi_comm_dup( comm, dupcom, ierr ) +C + tag = 2456 + count = TEST_SIZE / 3 +C + call clear_test_data(recv_buf,TEST_SIZE) +C + if (rank .eq. 0) then +C + call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . requests(1), ierr) +C + call init_test_data(send_buf,TEST_SIZE) +C + call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, next, 0, + . MPI_BOTTOM, 0, MPI_INTEGER, next, 0, + . dupcom, status, ierr ) +C + call MPI_Irsend(send_buf, count, MPI_REAL, next, tag, + . comm, requests(2), ierr) +C + index = -1 + do while (index .ne. 1) + call MPI_Waitany(2, requests, index, statuses, ierr) + end do +C + call rq_check( requests(1), 1, 'irsend and irecv' ) +C + call msg_check( recv_buf, next, tag, count, statuses, + . TEST_SIZE, 'irsend and irecv', errs ) +C + else if (prev .eq. 0) then +C + call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . requests(1), ierr) +C + call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, prev, 0, + . MPI_BOTTOM, 0, MPI_INTEGER, prev, 0, + . dupcom, status, ierr ) +C + flag = .FALSE. + do while (.not. flag) + call MPI_Test(requests(1), flag, status, ierr) + end do +C + call rq_check( requests, 1, 'irsend and irecv (test)' ) +C + call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, + . 'irsend and irecv', errs ) +C + call MPI_Irsend(recv_buf, count, MPI_REAL, prev, tag, + . comm, requests(1), ierr) +C + call MPI_Waitall(1, requests, statuses, ierr) +C + call rq_check( requests, 1, 'irsend and irecv' ) +C + end if +C + call mpi_comm_free( dupcom, ierr ) +C + end +C + subroutine test_pair_issend( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count, index + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer status(MPI_STATUS_SIZE), requests(2) + integer statuses(MPI_STATUS_SIZE,2) + logical flag + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' issend and irecv (testall)' + endif +C +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 2789 + count = TEST_SIZE / 3 +C + call clear_test_data(recv_buf,TEST_SIZE) +C + if (rank .eq. 0) then +C + call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . requests(1), ierr) +C + call init_test_data(send_buf,TEST_SIZE) +C + call MPI_Issend(send_buf, count, MPI_REAL, next, tag, + . comm, requests(2), ierr) +C + flag = .FALSE. + do while (.not. flag) + call MPI_Testall(2, requests, flag, statuses, ierr) + end do +C + call rq_check( requests, 2, 'issend and irecv (testall)' ) +C + call msg_check( recv_buf, next, tag, count, statuses(1,1), + . TEST_SIZE, 'issend and recv (testall)', errs ) +C + else if (prev .eq. 0) then +C + call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . status, ierr) + + call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, + . 'issend and recv', errs ) + + call MPI_Issend(recv_buf, count, MPI_REAL, prev, tag, + . comm, requests(1), ierr) +C + flag = .FALSE. + do while (.not. flag) + call MPI_Testany(1, requests(1), index, flag, + . statuses(1,1), ierr) + end do +C + call rq_check( requests, 1, 'issend and recv (testany)' ) +C + end if +C + end +C + subroutine test_pair_psend( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count, i + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer status(MPI_STATUS_SIZE) + integer statuses(MPI_STATUS_SIZE,2), requests(2) + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' Persistent send and recv' + endif +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 3123 + count = TEST_SIZE / 5 +C + call clear_test_data(recv_buf,TEST_SIZE) + call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . requests(2), ierr) +C + if (rank .eq. 0) then +C + call init_test_data(send_buf,TEST_SIZE) +C + call MPI_Send_init(send_buf, count, MPI_REAL, next, tag, + . comm, requests(1), ierr) +C + call MPI_Startall(2, requests, ierr) + call MPI_Waitall(2, requests, statuses, ierr) +C + call msg_check( recv_buf, next, tag, count, statuses(1,2), + . TEST_SIZE, 'persistent send/recv', errs ) +C + call MPI_Request_free(requests(1), ierr) +C + else if (prev .eq. 0) then +C + call MPI_Send_init(send_buf, count, MPI_REAL, prev, tag, + . comm, requests(1), ierr) + call MPI_Start(requests(2), ierr) + call MPI_Wait(requests(2), status, ierr) +C + call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, + * 'persistent send/recv', errs ) +C + do i = 1,count + send_buf(i) = recv_buf(i) + end do +C + call MPI_Start(requests(1), ierr) + call MPI_Wait(requests(1), status, ierr) +C + call MPI_Request_free(requests(1), ierr) + end if +C + call dummyRef( send_buf, count, ierr ) + call MPI_Request_free(requests(2), ierr) +C + end +C + subroutine test_pair_prsend( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count, index, i + integer outcount, indices(2) + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer statuses(MPI_STATUS_SIZE,2), requests(2) + integer status(MPI_STATUS_SIZE) + logical flag + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' Persistent Rsend and recv' + endif +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 3456 + count = TEST_SIZE / 3 +C + call clear_test_data(recv_buf,TEST_SIZE) +C + call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . requests(2), ierr) +C + if (rank .eq. 0) then +C + call MPI_Rsend_init(send_buf, count, MPI_REAL, next, tag, + . comm, requests(1), ierr) +C + call init_test_data(send_buf,TEST_SIZE) +C + call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag, + . comm, status, ierr ) +C + call MPI_Startall(2, requests, ierr) +C + index = -1 +C + do while (index .ne. 2) + call MPI_Waitsome(2, requests, outcount, + . indices, statuses, ierr) + do i = 1,outcount + if (indices(i) .eq. 2) then + call msg_check( recv_buf, next, tag, count, + . statuses(1,i), TEST_SIZE, 'waitsome', errs ) + index = 2 + end if + end do + end do +C + call MPI_Request_free(requests(1), ierr) + else if (prev .eq. 0) then +C + call MPI_Rsend_init(send_buf, count, MPI_REAL, prev, tag, + . comm, requests(1), ierr) +C + call MPI_Start(requests(2), ierr) +C + call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, prev, tag, + . comm, ierr ) +C + flag = .FALSE. + do while (.not. flag) + call MPI_Test(requests(2), flag, status, ierr) + end do + call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, + . 'test', errs ) +C + do i = 1,count + send_buf(i) = recv_buf(i) + end do +C + call MPI_Start(requests(1), ierr) + call MPI_Wait(requests(1), status, ierr) +C + call MPI_Request_free(requests(1), ierr) + end if +C + call dummyRef( send_buf, count, ierr ) + call MPI_Request_free(requests(2), ierr) +C + end +C + subroutine test_pair_pssend( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count, index, i + integer outcount, indices(2) + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer statuses(MPI_STATUS_SIZE,2), requests(2) + integer status(MPI_STATUS_SIZE) + logical flag + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' Persistent Ssend and recv' + endif +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 3789 + count = TEST_SIZE / 3 +C + call clear_test_data(recv_buf,TEST_SIZE) +C + call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . requests(1), ierr) +C + if (rank .eq. 0) then +C + call MPI_Ssend_init(send_buf, count, MPI_REAL, next, tag, + . comm, requests(2), ierr) +C + call init_test_data(send_buf,TEST_SIZE) +C + call MPI_Startall(2, requests, ierr) +C + index = -1 + do while (index .ne. 1) + call MPI_Testsome(2, requests, outcount, + . indices, statuses, ierr) + do i = 1,outcount + if (indices(i) .eq. 1) then + call msg_check( recv_buf, next, tag, count, + . statuses(1,i), TEST_SIZE, 'testsome', errs ) + index = 1 + end if + end do + end do +C + call MPI_Request_free(requests(2), ierr) +C + else if (prev .eq. 0) then +C + call MPI_Ssend_init(send_buf, count, MPI_REAL, prev, tag, + . comm, requests(2), ierr) +C + call MPI_Start(requests(1), ierr) +C + flag = .FALSE. + do while (.not. flag) + call MPI_Testany(1, requests(1), index, flag, + . statuses(1,1), ierr) + end do + call msg_check( recv_buf, prev, tag, count, statuses(1,1), + . TEST_SIZE, 'testany', errs ) + + do i = 1,count + send_buf(i) = recv_buf(i) + end do +C + call MPI_Start(requests(2), ierr) + call MPI_Wait(requests(2), status, ierr) +C + call MPI_Request_free(requests(2), ierr) +C + end if +C + call dummyRef( send_buf, count, ierr ) + call MPI_Request_free(requests(1), ierr) +C + end +C + subroutine test_pair_sendrecv( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer status(MPI_STATUS_SIZE) + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' Sendrecv' + endif +C +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 4123 + count = TEST_SIZE / 5 + + call clear_test_data(recv_buf,TEST_SIZE) + + if (rank .eq. 0) then + + call init_test_data(send_buf,TEST_SIZE) + + call MPI_Sendrecv(send_buf, count, MPI_REAL, next, tag, + . recv_buf, count, MPI_REAL, next, tag, + . comm, status, ierr) + + call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, + . 'sendrecv', errs ) + + else if (prev .eq. 0) then + + call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . status, ierr) + + call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, + . 'recv/send', errs ) + + call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, + . comm, ierr) + end if +C + end +C + subroutine test_pair_sendrecvrepl( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count, i + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer status(MPI_STATUS_SIZE) + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' Sendrecv replace' + endif +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 4456 + count = TEST_SIZE / 3 + + if (rank .eq. 0) then +C + call init_test_data(recv_buf, TEST_SIZE) +C + do 11 i = count+1,TEST_SIZE + recv_buf(i) = 0.0 + 11 continue +C + call MPI_Sendrecv_replace(recv_buf, count, MPI_REAL, + . next, tag, next, tag, + . comm, status, ierr) + + call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, + . 'sendrecvreplace', errs ) + + else if (prev .eq. 0) then + + call clear_test_data(recv_buf,TEST_SIZE) + + call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . status, ierr) + + call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, + . 'recv/send for replace', errs ) + + call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, + . comm, ierr) + end if +C + end +C +c------------------------------------------------------------------------------ +c +c Check for correct source, tag, count, and data in test message. +c +c------------------------------------------------------------------------------ + subroutine msg_check( recv_buf, source, tag, count, status, n, + * name, errs ) + implicit none + include 'mpif.h' + integer n, errs + real recv_buf(n) + integer source, tag, count, rank, status(MPI_STATUS_SIZE) + character*(*) name + logical foundError + + integer ierr, recv_src, recv_tag, recv_count + + foundError = .false. + recv_src = status(MPI_SOURCE) + recv_tag = status(MPI_TAG) + call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr ) + call MPI_Get_count(status, MPI_REAL, recv_count, ierr) + + if (recv_src .ne. source) then + print *, '[', rank, '] Unexpected source:', recv_src, + * ' in ', name + errs = errs + 1 + foundError = .true. + end if + + if (recv_tag .ne. tag) then + print *, '[', rank, '] Unexpected tag:', recv_tag, ' in ', name + errs = errs + 1 + foundError = .true. + end if + + if (recv_count .ne. count) then + print *, '[', rank, '] Unexpected count:', recv_count, + * ' in ', name + errs = errs + 1 + foundError = .true. + end if + + call verify_test_data(recv_buf, count, n, name, errs ) + + end +c------------------------------------------------------------------------------ +c +c Check that requests have been set to null +c +c------------------------------------------------------------------------------ + subroutine rq_check( requests, n, msg ) + include 'mpif.h' + integer n, requests(n) + character*(*) msg + integer i +c + do 10 i=1, n + if (requests(i) .ne. MPI_REQUEST_NULL) then + print *, 'Nonnull request in ', msg + endif + 10 continue +c + end +c------------------------------------------------------------------------------ +c +c Initialize test data buffer with integral sequence. +c +c------------------------------------------------------------------------------ + subroutine init_test_data(buf,n) + integer n + real buf(n) + integer i + + do 10 i = 1, n + buf(i) = REAL(i) + 10 continue + end + +c------------------------------------------------------------------------------ +c +c Clear test data buffer +c +c------------------------------------------------------------------------------ + subroutine clear_test_data(buf, n) + integer n + real buf(n) + integer i + + do 10 i = 1, n + buf(i) = 0. + 10 continue + + end + +c------------------------------------------------------------------------------ +c +c Verify test data buffer +c +c------------------------------------------------------------------------------ + subroutine verify_test_data( buf, count, n, name, errs ) + implicit none + include 'mpif.h' + integer n, errs + real buf(n) + character *(*) name + integer count, ierr, i +C + do 10 i = 1, count + if (buf(i) .ne. REAL(i)) then + print 100, buf(i), i, count, name + errs = errs + 1 + endif + 10 continue +C + do 20 i = count + 1, n + if (buf(i) .ne. 0.) then + print 100, buf(i), i, n, name + errs = errs + 1 + endif + 20 continue +C +100 format('Invalid data', f6.1, ' at ', i4, ' of ', i4, ' in ', a) +C + end +C +C This routine is used to prevent the compiler from deallocating the +C array "a", which may happen in some of the tests (see the text in +C the MPI standard about why this may be a problem in valid Fortran +C codes). Without this, for example, tests fail with the Cray ftn +C compiler. +C + subroutine dummyRef( a, n, ie ) + integer n, ie + real a(n) +C This condition will never be true, but the compile won't know that + if (ie .eq. -1) then + print *, a(n) + endif + return + end diff --git a/teshsuite/smpi/mpich3-test/f77/pt2pt/attr1aints.h b/teshsuite/smpi/mpich3-test/f77/pt2pt/attr1aints.h new file mode 100644 index 0000000000..182b04567a --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/pt2pt/attr1aints.h @@ -0,0 +1,6 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + integer extrastate, valin, valout, val diff --git a/teshsuite/smpi/mpich3-test/f77/pt2pt/dummyf.f b/teshsuite/smpi/mpich3-test/f77/pt2pt/dummyf.f new file mode 100644 index 0000000000..7524a194e0 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/pt2pt/dummyf.f @@ -0,0 +1,18 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2010 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C +C This file is used to disable certain compiler optimizations that +C can cause incorrect results with the test in greqf.f. It provides a +C point where extrastate may be modified, limiting the compilers ability +C to move code around. +C The include of mpif.h is not needed in the F77 case but in the +C F90 case it is, because in that case, extrastate is defined as an +C integer (kind=MPI_ADDRESS_KIND), and the script that creates the +C F90 tests from the F77 tests looks for mpif.h + subroutine dummyupdate( extrastate ) + include 'mpif.h' + include 'attr1aints.h' + end diff --git a/teshsuite/smpi/mpich3-test/f77/pt2pt/greqf.f b/teshsuite/smpi/mpich3-test/f77/pt2pt/greqf.f new file mode 100644 index 0000000000..163f0794b0 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/pt2pt/greqf.f @@ -0,0 +1,111 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + subroutine query_fn( extrastate, status, ierr ) + implicit none + include 'mpif.h' + integer status(MPI_STATUS_SIZE), ierr + include 'attr1aints.h' +C +C set a default status + status(MPI_SOURCE) = MPI_UNDEFINED + status(MPI_TAG) = MPI_UNDEFINED + call mpi_status_set_cancelled( status, .false., ierr) + call mpi_status_set_elements( status, MPI_BYTE, 0, ierr ) + ierr = MPI_SUCCESS + end +C + subroutine free_fn( extrastate, ierr ) + implicit none + include 'mpif.h' + integer value, ierr + include 'attr1aints.h' + integer freefncall + common /fnccalls/ freefncall +C +C For testing purposes, the following print can be used to check whether +C the free_fn is called +C print *, 'Free_fn called' +C + extrastate = extrastate - 1 +C The value returned by the free function is the error code +C returned by the wait/test function + ierr = MPI_SUCCESS + end +C + subroutine cancel_fn( extrastate, complete, ierr ) + implicit none + include 'mpif.h' + integer ierr + logical complete + include 'attr1aints.h' + + ierr = MPI_SUCCESS + end +C +C +C This is a very simple test of generalized requests. Normally, the +C MPI_Grequest_complete function would be called from another routine, +C often running in a separate thread. This simple code allows us to +C check that requests can be created, tested, and waited on in the +C case where the request is complete before the wait is called. +C +C Note that MPI did *not* define a routine that can be called within +C test or wait to advance the state of a generalized request. +C Most uses of generalized requests will need to use a separate thread. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + logical flag + integer status(MPI_STATUS_SIZE) + integer request + external query_fn, free_fn, cancel_fn + include 'attr1aints.h' + integer freefncall + common /fnccalls/ freefncall + + errs = 0 + freefncall = 0 + + call MTest_Init( ierr ) + + extrastate = 0 + call mpi_grequest_start( query_fn, free_fn, cancel_fn, + & extrastate, request, ierr ) + call mpi_test( request, flag, status, ierr ) + if (flag) then + errs = errs + 1 + print *, 'Generalized request marked as complete' + endif + + call mpi_grequest_complete( request, ierr ) + + call MPI_Wait( request, status, ierr ) + + extrastate = 1 + call mpi_grequest_start( query_fn, free_fn, cancel_fn, + & extrastate, request, ierr ) + call mpi_grequest_complete( request, ierr ) + call mpi_wait( request, MPI_STATUS_IGNORE, ierr ) +C +C The following routine may prevent an optimizing compiler from +C just remembering that extrastate was set in grequest_start + call dummyupdate(extrastate) + if (extrastate .ne. 0) then + errs = errs + 1 + if (freefncall .eq. 0) then + print *, 'Free routine not called' + else + print *, 'Free routine did not update extra_data' + print *, 'extrastate = ', extrastate + endif + endif +C + call MTest_Finalize( errs ) + call mpi_finalize( ierr ) + end +C diff --git a/teshsuite/smpi/mpich3-test/f77/pt2pt/mprobef.f b/teshsuite/smpi/mpich3-test/f77/pt2pt/mprobef.f new file mode 100644 index 0000000000..e1e554f836 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/pt2pt/mprobef.f @@ -0,0 +1,667 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2012 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer idx, ierr, rank, size, count + integer sendbuf(8), recvbuf(8) + integer s1(MPI_STATUS_SIZE), s2(MPI_STATUS_SIZE) + integer msg, errs + integer rreq + logical found, flag + + ierr = -1 + errs = 0 + call mpi_init( ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + print *, ' Unexpected return from MPI_INIT', ierr + endif + + call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr ) + call mpi_comm_size( MPI_COMM_WORLD, size, ierr ) + if (size .lt. 2) then + errs = errs + 1 + print *, ' This test requires at least 2 processes' +C Abort now - do not continue in this case. + call mpi_abort( MPI_COMM_WORLD, 1, ierr ) + endif + if (size .gt. 2) then + print *, ' This test is running with ', size, ' processes,' + print *, ' only 2 processes are used.' + endif + +C Test 0: simple Send and Mprobe+Mrecv. + if (rank .eq. 0) then + sendbuf(1) = 1735928559 + sendbuf(2) = 1277009102 + call MPI_Send(sendbuf, 2, MPI_INTEGER, + . 1, 5, MPI_COMM_WORLD, ierr) + else + do idx = 1, MPI_STATUS_SIZE + s1(idx) = 0 + s2(idx) = 0 + enddo +C the error fields are initialized for modification check. + s1(MPI_ERROR) = MPI_ERR_DIMS + s2(MPI_ERROR) = MPI_ERR_OTHER + + msg = MPI_MESSAGE_NULL + call MPI_Mprobe(0, 5, MPI_COMM_WORLD, msg, s1, ierr) + if (s1(MPI_SOURCE) .ne. 0) then + errs = errs + 1 + print *, 's1(MPI_SOURCE) != 0 at T0 Mprobe().' + endif + if (s1(MPI_TAG) .ne. 5) then + errs = errs + 1 + print *, 's1(MPI_TAG) != 5 at T0 Mprobe().' + endif + if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then + errs = errs + 1 + print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T0 Mprobe().' + endif + if (msg .eq. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg == MPI_MESSAGE_NULL at T0 Mprobe().' + endif + + count = -1 + call MPI_Get_count(s1, MPI_INTEGER, count, ierr) + if (count .ne. 2) then + errs = errs + 1 + print *, 'probed buffer does not have 2 MPI_INTEGERs.' + endif + + recvbuf(1) = 19088743 + recvbuf(2) = 1309737967 + call MPI_Mrecv(recvbuf, count, MPI_INTEGER, msg, s2, ierr) + if (recvbuf(1) .ne. 1735928559) then + errs = errs + 1 + print *, 'recvbuf(1) is corrupted at T0 Mrecv().' + endif + if (recvbuf(2) .ne. 1277009102) then + errs = errs + 1 + print *, 'recvbuf(2) is corrupted at T0 Mrecv().' + endif + if (s2(MPI_SOURCE) .ne. 0) then + errs = errs + 1 + print *, 's2(MPI_SOURCE) != 0 at T0 Mrecv().' + endif + if (s2(MPI_TAG) .ne. 5) then + errs = errs + 1 + print *, 's2(MPI_TAG) != 5 at T0 Mrecv().' + endif + if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then + errs = errs + 1 + print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T0 Mrecv().' + endif + if (msg .ne. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NULL at T0 Mrecv().' + endif + endif + +C Test 1: simple Send and Mprobe+Imrecv. + if (rank .eq. 0) then + sendbuf(1) = 1735928559 + sendbuf(2) = 1277009102 + call MPI_Send(sendbuf, 2, MPI_INTEGER, + . 1, 5, MPI_COMM_WORLD, ierr) + else + do idx = 1, MPI_STATUS_SIZE + s1(idx) = 0 + s2(idx) = 0 + enddo +C the error fields are initialized for modification check. + s1(MPI_ERROR) = MPI_ERR_DIMS + s2(MPI_ERROR) = MPI_ERR_OTHER + + msg = MPI_MESSAGE_NULL + call MPI_Mprobe(0, 5, MPI_COMM_WORLD, msg, s1, ierr) + if (s1(MPI_SOURCE) .ne. 0) then + errs = errs + 1 + print *, 's1(MPI_SOURCE) != 0 at T1 Mprobe().' + endif + if (s1(MPI_TAG) .ne. 5) then + errs = errs + 1 + print *, 's1(MPI_TAG) != 5 at T1 Mprobe().' + endif + if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then + errs = errs + 1 + print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T1 Mprobe().' + endif + if (msg .eq. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg == MPI_MESSAGE_NULL at T1 Mprobe().' + endif + + count = -1 + call MPI_Get_count(s1, MPI_INTEGER, count, ierr) + if (count .ne. 2) then + errs = errs + 1 + print *, 'probed buffer does not have 2 MPI_INTEGERs.' + endif + + rreq = MPI_REQUEST_NULL + recvbuf(1) = 19088743 + recvbuf(2) = 1309737967 + call MPI_Imrecv(recvbuf, count, MPI_INTEGER, msg, rreq, ierr) + if (rreq .eq. MPI_REQUEST_NULL) then + errs = errs + 1 + print *, 'rreq is unmodified at T1 Imrecv().' + endif + call MPI_Wait(rreq, s2, ierr) + if (recvbuf(1) .ne. 1735928559) then + errs = errs + 1 + print *, 'recvbuf(1) is corrupted at T1 Imrecv().' + endif + if (recvbuf(2) .ne. 1277009102) then + errs = errs + 1 + print *, 'recvbuf(2) is corrupted at T1 Imrecv().' + endif + if (s2(MPI_SOURCE) .ne. 0) then + errs = errs + 1 + print *, 's2(MPI_SOURCE) != 0 at T1 Imrecv().' + endif + if (s2(MPI_TAG) .ne. 5) then + errs = errs + 1 + print *, 's2(MPI_TAG) != 5 at T1 Imrecv().' + endif + if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then + errs = errs + 1 + print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T1 Imrecv().' + endif + if (msg .ne. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NULL at T1 Imrecv().' + endif + endif + +C Test 2: simple Send and Improbe+Mrecv. + if (rank .eq. 0) then + sendbuf(1) = 1735928559 + sendbuf(2) = 1277009102 + call MPI_Send(sendbuf, 2, MPI_INTEGER, + . 1, 5, MPI_COMM_WORLD, ierr) + else + do idx = 1, MPI_STATUS_SIZE + s1(idx) = 0 + s2(idx) = 0 + enddo +C the error fields are initialized for modification check. + s1(MPI_ERROR) = MPI_ERR_DIMS + s2(MPI_ERROR) = MPI_ERR_OTHER + + msg = MPI_MESSAGE_NULL + call MPI_Improbe(0, 5, MPI_COMM_WORLD, found, msg, s1, ierr) + do while (.not. found) + call MPI_Improbe(0, 5, MPI_COMM_WORLD, + . found, msg, s1, ierr) + enddo + if (msg .eq. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg == MPI_MESSAGE_NULL at T2 Improbe().' + endif + if (s1(MPI_SOURCE) .ne. 0) then + errs = errs + 1 + print *, 's1(MPI_SOURCE) != 0 at T2 Improbe().' + endif + if (s1(MPI_TAG) .ne. 5) then + errs = errs + 1 + print *, 's1(MPI_TAG) != 5 at T2 Improbe().' + endif + if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then + errs = errs + 1 + print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T2 Improbe().' + endif + + count = -1 + call MPI_Get_count(s1, MPI_INTEGER, count, ierr) + if (count .ne. 2) then + errs = errs + 1 + print *, 'probed buffer does not have 2 MPI_INTEGERs.' + endif + + recvbuf(1) = 19088743 + recvbuf(2) = 1309737967 + call MPI_Mrecv(recvbuf, count, MPI_INTEGER, msg, s2, ierr) + if (recvbuf(1) .ne. 1735928559) then + errs = errs + 1 + print *, 'recvbuf(1) is corrupted at T2 Mrecv().' + endif + if (recvbuf(2) .ne. 1277009102) then + errs = errs + 1 + print *, 'recvbuf(2) is corrupted at T2 Mrecv().' + endif + if (s2(MPI_SOURCE) .ne. 0) then + errs = errs + 1 + print *, 's2(MPI_SOURCE) != 0 at T2 Mrecv().' + endif + if (s2(MPI_TAG) .ne. 5) then + errs = errs + 1 + print *, 's2(MPI_TAG) != 5 at T2 Mrecv().' + endif + if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then + errs = errs + 1 + print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T2 Mrecv().' + endif + if (msg .ne. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NULL at T2 Mrecv().' + endif + endif + +C Test 3: simple Send and Improbe+Imrecv. + if (rank .eq. 0) then + sendbuf(1) = 1735928559 + sendbuf(2) = 1277009102 + call MPI_Send(sendbuf, 2, MPI_INTEGER, + . 1, 5, MPI_COMM_WORLD, ierr) + else + do idx = 1, MPI_STATUS_SIZE + s1(idx) = 0 + s2(idx) = 0 + enddo +C the error fields are initialized for modification check. + s1(MPI_ERROR) = MPI_ERR_DIMS + s2(MPI_ERROR) = MPI_ERR_OTHER + + msg = MPI_MESSAGE_NULL + call MPI_Improbe(0, 5, MPI_COMM_WORLD, found, msg, s1, ierr) + do while (.not. found) + call MPI_Improbe(0, 5, MPI_COMM_WORLD, + . found, msg, s1, ierr) + enddo + if (msg .eq. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg == MPI_MESSAGE_NULL at T3 Improbe().' + endif + if (s1(MPI_SOURCE) .ne. 0) then + errs = errs + 1 + print *, 's1(MPI_SOURCE) != 0 at T3 Improbe().' + endif + if (s1(MPI_TAG) .ne. 5) then + errs = errs + 1 + print *, 's1(MPI_TAG) != 5 at T3 Improbe().' + endif + if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then + errs = errs + 1 + print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T3 Improbe().' + endif + + count = -1 + call MPI_Get_count(s1, MPI_INTEGER, count, ierr) + if (count .ne. 2) then + errs = errs + 1 + print *, 'probed buffer does not have 2 MPI_INTEGERs.' + endif + + rreq = MPI_REQUEST_NULL + recvbuf(1) = 19088743 + recvbuf(2) = 1309737967 + call MPI_Imrecv(recvbuf, count, MPI_INTEGER, msg, rreq, ierr) + if (rreq .eq. MPI_REQUEST_NULL) then + errs = errs + 1 + print *, 'rreq is unmodified at T3 Imrecv().' + endif + call MPI_Wait(rreq, s2, ierr) + if (recvbuf(1) .ne. 1735928559) then + errs = errs + 1 + print *, 'recvbuf(1) is corrupted at T3 Imrecv().' + endif + if (recvbuf(2) .ne. 1277009102) then + errs = errs + 1 + print *, 'recvbuf(2) is corrupted at T3 Imrecv().' + endif + if (s2(MPI_SOURCE) .ne. 0) then + errs = errs + 1 + print *, 's2(MPI_SOURCE) != 0 at T3 Imrecv().' + endif + if (s2(MPI_TAG) .ne. 5) then + errs = errs + 1 + print *, 's2(MPI_TAG) != 5 at T3 Imrecv().' + endif + if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then + errs = errs + 1 + print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T3 Imrecv().' + endif + if (msg .ne. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NULL at T3 Imrecv().' + endif + endif + +C Test 4: Mprobe+Mrecv with MPI_PROC_NULL + if (.true.) then + do idx = 1, MPI_STATUS_SIZE + s1(idx) = 0 + s2(idx) = 0 + enddo +C the error fields are initialized for modification check. + s1(MPI_ERROR) = MPI_ERR_DIMS + s2(MPI_ERROR) = MPI_ERR_OTHER + + msg = MPI_MESSAGE_NULL + call MPI_Mprobe(MPI_PROC_NULL, 5, MPI_COMM_WORLD, + . msg, s1, ierr) + if (s1(MPI_SOURCE) .ne. MPI_PROC_NULL) then + errs = errs + 1 + print *, 's1(MPI_SOURCE) != MPI_PROC_NULL at T4 Mprobe().' + endif + if (s1(MPI_TAG) .ne. MPI_ANY_TAG) then + errs = errs + 1 + print *, 's1(MPI_TAG) != MPI_ANY_TAG at T4 Mprobe().' + endif + if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then + errs = errs + 1 + print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T4 Mprobe().' + endif + if (msg .ne. MPI_MESSAGE_NO_PROC) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NO_PROC at T4 Mprobe().' + endif + + count = -1 + call MPI_Get_count(s1, MPI_INTEGER, count, ierr) + if (count .ne. 0) then + errs = errs + 1 + print *, 'probed buffer does not have 0 MPI_INTEGER.' + endif + + recvbuf(1) = 19088743 + recvbuf(2) = 1309737967 + call MPI_Mrecv(recvbuf, count, MPI_INTEGER, msg, s2, ierr) +C recvbuf() should remain unmodified + if (recvbuf(1) .ne. 19088743) then + errs = errs + 1 + print *, 'recvbuf(1) is corrupted at T4 Mrecv().' + endif + if (recvbuf(2) .ne. 1309737967) then + errs = errs + 1 + print *, 'recvbuf(2) is corrupted at T4 Mrecv().' + endif + if (s2(MPI_SOURCE) .ne. MPI_PROC_NULL) then + errs = errs + 1 + print *, 's2(MPI_SOURCE) != MPI_PROC_NULL at T4 Mrecv().' + endif + if (s2(MPI_TAG) .ne. MPI_ANY_TAG) then + errs = errs + 1 + print *, 's2(MPI_TAG) != MPI_ANY_TAG at T4 Mrecv().' + endif + if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then + errs = errs + 1 + print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T4 Mrecv().' + endif + if (msg .ne. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NULL at T4 Mrecv().' + endif + + count = -1 + call MPI_Get_count(s2, MPI_INTEGER, count, ierr) + if (count .ne. 0) then + errs = errs + 1 + print *, 'recv buffer does not have 0 MPI_INTEGER.' + endif + endif + +C Test 5: Mprobe+Imrecv with MPI_PROC_NULL + if (.true.) then + do idx = 1, MPI_STATUS_SIZE + s1(idx) = 0 + s2(idx) = 0 + enddo +C the error fields are initialized for modification check. + s1(MPI_ERROR) = MPI_ERR_DIMS + s2(MPI_ERROR) = MPI_ERR_OTHER + + msg = MPI_MESSAGE_NULL + call MPI_Mprobe(MPI_PROC_NULL, 5, MPI_COMM_WORLD, + . msg, s1, ierr) + if (s1(MPI_SOURCE) .ne. MPI_PROC_NULL) then + errs = errs + 1 + print *, 's1(MPI_SOURCE) != MPI_PROC_NULL at T5 Mprobe().' + endif + if (s1(MPI_TAG) .ne. MPI_ANY_TAG) then + errs = errs + 1 + print *, 's1(MPI_TAG) != MPI_ANY_TAG at T5 Mprobe().' + endif + if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then + errs = errs + 1 + print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T5 Mprobe().' + endif + if (msg .ne. MPI_MESSAGE_NO_PROC) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NO_PROC at T5 Mprobe().' + endif + + count = -1 + call MPI_Get_count(s1, MPI_INTEGER, count, ierr) + if (count .ne. 0) then + errs = errs + 1 + print *, 'probed buffer does not have 0 MPI_INTEGER.' + endif + + rreq = MPI_REQUEST_NULL + recvbuf(1) = 19088743 + recvbuf(2) = 1309737967 + call MPI_Imrecv(recvbuf, count, MPI_INTEGER, msg, rreq, ierr) + if (rreq .eq. MPI_REQUEST_NULL) then + errs = errs + 1 + print *, 'rreq == MPI_REQUEST_NULL at T5 Imrecv().' + endif + flag = .false. + call MPI_Test(rreq, flag, s2, ierr) + if (.not. flag) then + errs = errs + 1 + print *, 'flag is false at T5 Imrecv().' + endif +C recvbuf() should remain unmodified + if (recvbuf(1) .ne. 19088743) then + errs = errs + 1 + print *, 'recvbuf(1) is corrupted at T5 Imrecv().' + endif + if (recvbuf(2) .ne. 1309737967) then + errs = errs + 1 + print *, 'recvbuf(2) is corrupted at T5 Imrecv().' + endif + if (s2(MPI_SOURCE) .ne. MPI_PROC_NULL) then + errs = errs + 1 + print *, 's2(MPI_SOURCE) != MPI_PROC_NULL at T5 Imrecv().' + endif + if (s2(MPI_TAG) .ne. MPI_ANY_TAG) then + errs = errs + 1 + print *, 's2(MPI_TAG) != MPI_ANY_TAG at T5 Imrecv().' + endif + if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then + errs = errs + 1 + print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T5 Imrecv().' + endif + if (msg .ne. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NULL at T5 Imrecv().' + endif + + count = -1 + call MPI_Get_count(s2, MPI_INTEGER, count, ierr) + if (count .ne. 0) then + errs = errs + 1 + print *, 'recv buffer does not have 0 MPI_INTEGER.' + endif + endif + +C Test 6: Improbe+Mrecv with MPI_PROC_NULL + if (.true.) then + do idx = 1, MPI_STATUS_SIZE + s1(idx) = 0 + s2(idx) = 0 + enddo +C the error fields are initialized for modification check. + s1(MPI_ERROR) = MPI_ERR_DIMS + s2(MPI_ERROR) = MPI_ERR_OTHER + + found = .false. + msg = MPI_MESSAGE_NULL + call MPI_Improbe(MPI_PROC_NULL, 5, MPI_COMM_WORLD, + . found, msg, s1, ierr) + if (.not. found) then + errs = errs + 1 + print *, 'found is false at T6 Improbe().' + endif + if (s1(MPI_SOURCE) .ne. MPI_PROC_NULL) then + errs = errs + 1 + print *, 's1(MPI_SOURCE) != MPI_PROC_NULL at T6 Improbe()' + endif + if (s1(MPI_TAG) .ne. MPI_ANY_TAG) then + errs = errs + 1 + print *, 's1(MPI_TAG) != MPI_ANY_TAG at T6 Improbe().' + endif + if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then + errs = errs + 1 + print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T6 Improbe().' + endif + if (msg .ne. MPI_MESSAGE_NO_PROC) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NO_PROC at T6 Improbe().' + endif + + count = -1 + call MPI_Get_count(s1, MPI_INTEGER, count, ierr) + if (count .ne. 0) then + errs = errs + 1 + print *, 'probed buffer does not have 0 MPI_INTEGER.' + endif + + recvbuf(1) = 19088743 + recvbuf(2) = 1309737967 + call MPI_Mrecv(recvbuf, count, MPI_INTEGER, msg, s2, ierr) +C recvbuf() should remain unmodified + if (recvbuf(1) .ne. 19088743) then + errs = errs + 1 + print *, 'recvbuf(1) is corrupted at T6 Mrecv().' + endif + if (recvbuf(2) .ne. 1309737967) then + errs = errs + 1 + print *, 'recvbuf(2) is corrupted at T6 Mrecv().' + endif + if (s2(MPI_SOURCE) .ne. MPI_PROC_NULL) then + errs = errs + 1 + print *, 's2(MPI_SOURCE) != MPI_PROC_NULL at T6 Mrecv().' + endif + if (s2(MPI_TAG) .ne. MPI_ANY_TAG) then + errs = errs + 1 + print *, 's2(MPI_TAG) != MPI_ANY_TAG at T6 Mrecv().' + endif + if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then + errs = errs + 1 + print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T6 Mrecv().' + endif + if (msg .ne. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NULL at T6 Mrecv().' + endif + + count = -1 + call MPI_Get_count(s2, MPI_INTEGER, count, ierr) + if (count .ne. 0) then + errs = errs + 1 + print *, 'recv buffer does not have 0 MPI_INTEGER.' + endif + endif + +C Test 7: Improbe+Imrecv with MPI_PROC_NULL + if (.true.) then + do idx = 1, MPI_STATUS_SIZE + s1(idx) = 0 + s2(idx) = 0 + enddo +C the error fields are initialized for modification check. + s1(MPI_ERROR) = MPI_ERR_DIMS + s2(MPI_ERROR) = MPI_ERR_OTHER + + found = .false. + msg = MPI_MESSAGE_NULL + call MPI_Improbe(MPI_PROC_NULL, 5, MPI_COMM_WORLD, + . found, msg, s1, ierr) + if (.not. found) then + errs = errs + 1 + print *, 'found is false at T7 Improbe().' + endif + if (s1(MPI_SOURCE) .ne. MPI_PROC_NULL) then + errs = errs + 1 + print *, 's1(MPI_SOURCE) != MPI_PROC_NULL at T7 Improbe()' + endif + if (s1(MPI_TAG) .ne. MPI_ANY_TAG) then + errs = errs + 1 + print *, 's1(MPI_TAG) != MPI_ANY_TAG at T7 Improbe().' + endif + if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then + errs = errs + 1 + print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T7 Improbe().' + endif + if (msg .ne. MPI_MESSAGE_NO_PROC) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NO_PROC at T7 Improbe().' + endif + + count = -1 + call MPI_Get_count(s1, MPI_INTEGER, count, ierr) + if (count .ne. 0) then + errs = errs + 1 + print *, 'probed buffer does not have 0 MPI_INTEGER.' + endif + + rreq = MPI_REQUEST_NULL + recvbuf(1) = 19088743 + recvbuf(2) = 1309737967 + call MPI_Imrecv(recvbuf, count, MPI_INTEGER, msg, rreq, ierr) + if (rreq .eq. MPI_REQUEST_NULL) then + errs = errs + 1 + print *, 'rreq == MPI_REQUEST_NULL at T7 Imrecv().' + endif + flag = .false. + call MPI_Test(rreq, flag, s2, ierr) + if (.not. flag) then + errs = errs + 1 + print *, 'flag is false at T7 Imrecv().' + endif +C recvbuf() should remain unmodified + if (recvbuf(1) .ne. 19088743) then + errs = errs + 1 + print *, 'recvbuf(1) is corrupted at T7 Imrecv().' + endif + if (recvbuf(2) .ne. 1309737967) then + errs = errs + 1 + print *, 'recvbuf(2) is corrupted at T7 Imrecv().' + endif + if (s2(MPI_SOURCE) .ne. MPI_PROC_NULL) then + errs = errs + 1 + print *, 's2(MPI_SOURCE) != MPI_PROC_NULL at T7 Imrecv().' + endif + if (s2(MPI_TAG) .ne. MPI_ANY_TAG) then + errs = errs + 1 + print *, 's2(MPI_TAG) != MPI_ANY_TAG at T7 Imrecv().' + endif + if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then + errs = errs + 1 + print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T7 Imrecv().' + endif + if (msg .ne. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NULL at T7 Imrecv().' + endif + + count = -1 + call MPI_Get_count(s2, MPI_INTEGER, count, ierr) + if (count .ne. 0) then + errs = errs + 1 + print *, 'recv buffer does not have 0 MPI_INTEGER.' + endif + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/pt2pt/statusesf.f b/teshsuite/smpi/mpich3-test/f77/pt2pt/statusesf.f new file mode 100644 index 0000000000..b01d26bc6a --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/pt2pt/statusesf.f @@ -0,0 +1,56 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none +C Test support for MPI_STATUS_IGNORE and MPI_STATUSES_IGNORE + include 'mpif.h' + integer nreqs + parameter (nreqs = 100) + integer reqs(nreqs) + integer ierr, rank, i + integer errs + + ierr = -1 + errs = 0 + call mpi_init( ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + print *, 'Unexpected return from MPI_INIT', ierr + endif + + ierr = -1 + call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + print *, 'Unexpected return from MPI_COMM_WORLD', ierr + endif + do i=1, nreqs, 2 + ierr = -1 + call mpi_isend( MPI_BOTTOM, 0, MPI_BYTE, rank, i, + $ MPI_COMM_WORLD, reqs(i), ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + print *, 'Unexpected return from MPI_ISEND', ierr + endif + ierr = -1 + call mpi_irecv( MPI_BOTTOM, 0, MPI_BYTE, rank, i, + $ MPI_COMM_WORLD, reqs(i+1), ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + print *, 'Unexpected return from MPI_IRECV', ierr + endif + enddo + + ierr = -1 + call mpi_waitall( nreqs, reqs, MPI_STATUSES_IGNORE, ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + print *, 'Unexpected return from MPI_WAITALL', ierr + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/pt2pt/testlist b/teshsuite/smpi/mpich3-test/f77/pt2pt/testlist new file mode 100644 index 0000000000..3385b9d641 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/pt2pt/testlist @@ -0,0 +1,4 @@ +#statusesf 1 +#greqf 1 +allpairf 2 +#mprobef 2 mpiversion=3.0 diff --git a/teshsuite/smpi/mpich3-test/f77/util/mtestf.f b/teshsuite/smpi/mpich3-test/f77/util/mtestf.f new file mode 100644 index 0000000000..ba7092ef17 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/util/mtestf.f @@ -0,0 +1,112 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + subroutine MTest_Init( ierr ) +C Place the include first so that we can automatically create a +C Fortran 90 version that uses the mpi module instead. If +C the module is in a different place, the compiler can complain +C about out-of-order statements + implicit none + include 'mpif.h' + integer ierr + logical flag + logical dbgflag + integer wrank + common /mtest/ dbgflag, wrank + + call MPI_Initialized( flag, ierr ) + if (.not. flag) then + call MPI_Init( ierr ) + endif + + dbgflag = .false. + call MPI_Comm_rank( MPI_COMM_WORLD, wrank, ierr ) + end +C + subroutine MTest_Finalize( errs ) + implicit none + include 'mpif.h' + integer errs + integer rank, toterrs, ierr + + call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr ) + + call MPI_Allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, + * MPI_COMM_WORLD, ierr ) + + if (rank .eq. 0) then + if (toterrs .gt. 0) then + print *, " Found ", toterrs, " errors" + else + print *, " No Errors" + endif + endif + end +C +C A simple get intracomm for now + logical function MTestGetIntracomm( comm, min_size, qsmaller ) + implicit none + include 'mpif.h' + integer ierr + integer comm, min_size, size, rank + logical qsmaller + integer myindex + common /grr/ myindex + + comm = MPI_COMM_NULL + if (myindex .eq. 0) then + comm = MPI_COMM_WORLD + else if (myindex .eq. 1) then + call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr ) + else if (myindex .eq. 2) then + call mpi_comm_size( MPI_COMM_WORLD, size, ierr ) + call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr ) + call mpi_comm_split( MPI_COMM_WORLD, 0, size - rank, comm, + & ierr ) + else + if (min_size .eq. 1 .and. myindex .eq. 3) then + comm = MPI_COMM_SELF + endif + endif + myindex = mod( myindex, 4 ) + 1 + MTestGetIntracomm = comm .ne. MPI_COMM_NULL + end +C + subroutine MTestFreeComm( comm ) + implicit none + include 'mpif.h' + integer comm, ierr + if (comm .ne. MPI_COMM_WORLD .and. + & comm .ne. MPI_COMM_SELF .and. + & comm .ne. MPI_COMM_NULL) then + call mpi_comm_free( comm, ierr ) + endif + end +C + subroutine MTestPrintError( errcode ) + implicit none + include 'mpif.h' + integer errcode + integer errclass, slen, ierr + character*(MPI_MAX_ERROR_STRING) string + + call MPI_Error_class( errcode, errclass, ierr ) + call MPI_Error_string( errcode, string, slen, ierr ) + print *, "Error class ", errclass, "(", string(1:slen), ")" + end +C + subroutine MTestPrintErrorMsg( msg, errcode ) + implicit none + include 'mpif.h' + character*(*) msg + integer errcode + integer errclass, slen, ierr + character*(MPI_MAX_ERROR_STRING) string + + call MPI_Error_class( errcode, errclass, ierr ) + call MPI_Error_string( errcode, string, slen, ierr ) + print *, msg, ": Error class ", errclass, " + $ (", string(1:slen), ")" + end diff --git a/teshsuite/smpi/mpich3-test/runtests b/teshsuite/smpi/mpich3-test/runtests index 03c9b88d15..3efbc12941 100755 --- a/teshsuite/smpi/mpich3-test/runtests +++ b/teshsuite/smpi/mpich3-test/runtests @@ -154,7 +154,7 @@ foreach $_ (@ARGV) { elsif (/--?maxnp=(.*)/) { $np_max = $1; } elsif (/--?tests=(.*)/) { $listfiles = $1; } elsif (/--?srcdir=(.*)/) { $srcdir = $1; - $mpiexec="$mpiexec -platform ${srcdir}/../../../../examples/msg/small_platform_with_routers.xml -hostfile ${srcdir}/../hostfile --log=root.thr:critical"; } + $mpiexec="$mpiexec -platform ${srcdir}/../small_platform_with_routers.xml -hostfile ${srcdir}/../hostfile --log=root.thr:critical --cfg=smpi/running_power:1e9"; } elsif (/--?verbose/) { $verbose = 1; } elsif (/--?showprogress/) { $showProgress = 1; } elsif (/--?debug/) { $debug = 1; } diff --git a/teshsuite/smpi/mpich3-test/testlist b/teshsuite/smpi/mpich3-test/testlist index f4764eed5a..2110a22696 100644 --- a/teshsuite/smpi/mpich3-test/testlist +++ b/teshsuite/smpi/mpich3-test/testlist @@ -16,7 +16,7 @@ pt2pt #topo #perf #io -#f77 +f77 #cxx # #