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()
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
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)
${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)
--- /dev/null
+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
+ )
--- /dev/null
+C -*- Mode: Fortran; -*-
+C
+C (C) 2003 by Argonne National Laboratory.
+C See COPYRIGHT in top-level directory.
+C
+ integer extrastate, valin, valout, val
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
+
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+attrmpi1f 1
+baseattrf 1
+baseattr2f 1
+commattrf 1
+commattr2f 1
+commattr3f 1
+typeattrf 1
+typeattr2f 1
+typeattr3f 1
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
+ )
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
+
--- /dev/null
+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
+
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
+ )
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+#commnamef 2
+#commerrf 2
--- /dev/null
+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
+ )
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+#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
--- /dev/null
+C -*- Mode: Fortran; -*-
+C
+C (C) 2003 by Argonne National Laboratory.
+C See COPYRIGHT in top-level directory.
+C
+ integer aint, aintv(max_asizev)
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
+ )
--- /dev/null
+C -*- Mode: Fortran; -*-
+C
+C (C) 2003 by Argonne National Laboratory.
+C See COPYRIGHT in top-level directory.
+C
+ integer asize
--- /dev/null
+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
--- /dev/null
+/* -*- 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 <stdio.h>
+#include "mpi.h"
+#include "../../include/mpitestconf.h"
+#include <string.h>
+
+/*
+ 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 );
+}
+
--- /dev/null
+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
+
--- /dev/null
+/* -*- 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 <stdio.h>
+#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;
+}
--- /dev/null
+/* -*- 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 <stdio.h>
+#include "mpi.h"
+#include "../../include/mpitestconf.h"
+#include <string.h>
+
+/* 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;
+}
--- /dev/null
+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
--- /dev/null
+#c2f2cf 1
+#c2fmult 1
+#ctypesinf 1
+
--- /dev/null
+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
+ )
--- /dev/null
+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
--- /dev/null
+#include "mpi.h"
+#include <stdio.h>
+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;
+}
--- /dev/null
+baseenvf 1
--- /dev/null
+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
+ )
--- /dev/null
+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
--- /dev/null
+C -*- Mode: Fortran; -*-
+C
+C (C) 2003 by Argonne National Laboratory.
+C See COPYRIGHT in top-level directory.
+C
+ integer extrastate, valin, valout, val
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+#statusesf 1
+#greqf 1
+allpairf 2
+#mprobef 2 mpiversion=3.0
--- /dev/null
+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
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; }
#topo
#perf
#io
-#f77
+f77
#cxx
#
#
