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)
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!")
+ ADD_TEST(smpi-mpich3-thread-f90 ${CMAKE_COMMAND} -E chdir ${CMAKE_BINARY_DIR}/teshsuite/smpi/mpich3-test/f90/ ${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/runtests -mpiexec=${CMAKE_BINARY_DIR}/smpi_script/bin/smpirun -srcdir=${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f90/ -tests=testlist -execarg=--cfg=contexts/factory:thread)
+ set_tests_properties(smpi-mpich3-thread-f90 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/smpi/mpich3-test/f77/datatype/CMakeLists.txt
teshsuite/smpi/mpich3-test/f77/ext/CMakeLists.txt
teshsuite/smpi/mpich3-test/f77/init/CMakeLists.txt
+ teshsuite/smpi/mpich3-test/f90/coll/CMakeLists.txt
+ teshsuite/smpi/mpich3-test/f9077/pt2pt/CMakeLists.txt
+ teshsuite/smpi/mpich3-test/f90/datatype/CMakeLists.txt
+ teshsuite/smpi/mpich3-test/f90/init/CMakeLists.txt
)
endif()
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/smpi/mpich3-test/f90/coll)
+add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f90/pt2pt)
+add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f90/datatype)
+add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f90/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}/checktests
${CMAKE_CURRENT_SOURCE_DIR}/util/mtest.c
${CMAKE_CURRENT_SOURCE_DIR}/f77/testlist
+ ${CMAKE_CURRENT_SOURCE_DIR}/f90/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/smpif90")
+ 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")
+ include_directories("${CMAKE_HOME_DIRECTORY}/include/smpi")
+
+ add_executable(allredint8f90 allredint8f90.f90 ../util/mtestf90.f90)
+ add_executable(allredopttf90 allredopttf90.f90 ../util/mtestf90.f90)
+ add_executable(alltoallvf90 alltoallvf90.f90 ../util/mtestf90.f90)
+ add_executable(alltoallwf90 alltoallwf90.f90 ../util/mtestf90.f90)
+ add_executable(exscanf90 exscanf90.f90 ../util/mtestf90.f90)
+ add_executable(inplacef90 inplacef90.f90 ../util/mtestf90.f90)
+ # add_executable(nonblockingf90 nonblockingf90.f90 ../util/mtestf90.f90)
+ # add_executable(nonblocking_inpf90 nonblocking_inpf90.f90 ../util/mtestf90.f90)
+ add_executable(red_scat_blockf90 red_scat_blockf90.f90 ../util/mtestf90.f90)
+ add_executable(redscatf90 redscatf90.f90 ../util/mtestf90.f90)
+ add_executable(reducelocalf90 reducelocalf90.f90 ../util/mtestf90.f90)
+ add_executable(split_typef90 split_typef90.f90 ../util/mtestf90.f90)
+ add_executable(uallreducef90 uallreducef90.f90 ../util/mtestf90.f90)
+ add_executable(vw_inplacef90 vw_inplacef90.f90 ../util/mtestf90.f90)
+ target_link_libraries(allredint8f90 simgrid)
+ target_link_libraries(allredopttf90 simgrid)
+ target_link_libraries(alltoallvf90 simgrid)
+ target_link_libraries(alltoallwf90 simgrid)
+ target_link_libraries(exscanf90 simgrid)
+ target_link_libraries(inplacef90 simgrid)
+ # target_link_libraries(nonblockingf90 simgrid)
+ # target_link_libraries(nonblocking_inpf90 simgrid)
+ target_link_libraries(red_scat_blockf90 simgrid)
+ target_link_libraries(redscatf90 simgrid)
+ target_link_libraries(reducelocalf90 simgrid)
+ target_link_libraries(split_typef90 simgrid)
+ target_link_libraries(uallreducef90 simgrid)
+ target_link_libraries(vw_inplacef90 simgrid)
+ set_target_properties(allredint8f90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(allredopttf90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(alltoallvf90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(alltoallwf90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(exscanf90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(inplacef90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ # set_target_properties(nonblockingf90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ # set_target_properties(nonblocking_inpf90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(red_scat_blockf90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(redscatf90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(reducelocalf90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(split_typef90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(uallreducef90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(vw_inplacef90 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}/allredint8f90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/allredopttf90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/alltoallvf90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/alltoallwf90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/exscanf90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/inplacef90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/nonblockingf90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/nonblocking_inpf90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/red_scat_blockf90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/redscatf90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/reducelocalf90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/split_typef90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/uallreducef90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/vw_inplacef90.f90
+ PARENT_SCOPE
+ )
+set(bin_files
+ ${bin_files}
+ PARENT_SCOPE
+ )
+set(txt_files
+ ${txt_files}
+ ${CMAKE_CURRENT_SOURCE_DIR}/../util/mtestf90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/testlist
+ PARENT_SCOPE
+ )
--- /dev/null
+! This file created from test/mpi/f77/coll/allredint8f.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2006 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ integer*8 inbuf, outbuf
+ integer errs, ierr
+
+ errs = 0
+
+ call mtest_init( ierr )
+!
+! 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
+! This file created from test/mpi/f77/coll/allredopttf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2007 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ 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 )
+!
+! 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
+! This file created from test/mpi/f77/coll/alltoallvf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2011 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ 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 )
+
+! 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
+! Initialize the data. Just use this as an all to all
+! Use the same test as alltoallwf.c , except displacements are in units of
+! 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 )
+!
+! check rbuf(i) = data from the ith location of the ith send buf, or
+! 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
+!
+! A halo-exchange example - mostly zero counts
+!
+ 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
+
+!
+! 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 )
+!
+! Check the neighbor values are correctly moved
+!
+ 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
+! This file created from test/mpi/f77/coll/alltoallwf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ 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 )
+
+! 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
+! 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 )
+!
+! check rbuf(i) = data from the ith location of the ith send buf, or
+! 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
+! This file created from test/mpi/f77/coll/exscanf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ subroutine uop( cin, cout, count, datatype )
+ use mpi
+ 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
+!
+ program main
+ use mpi
+ integer, dimension(:), allocatable :: inbuf, outbuf
+ integer ans, rank, size, comm
+ integer errs, ierr
+ integer sumop, status
+ external uop
+ allocate(inbuf(2), STAT=status)
+ allocate(outbuf(2), STAT=status)
+ errs = 0
+
+ call mtest_init( ierr )
+!
+! 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 )
+! this process has the sum of i from 0 to rank-1, which is
+! (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
+!
+! Try a user-defined operation
+!
+ 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 )
+! this process has the sum of i from 0 to rank-1, which is
+! (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 )
+
+!
+! Try a user-defined operation (and don't claim it is commutative)
+!
+ 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 )
+! this process has the sum of i from 0 to rank-1, which is
+! (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 )
+ deallocate(inbuf)
+ deallocate(outbuf)
+ call mtest_finalize( errs )
+ call mpi_finalize( ierr )
+ end
--- /dev/null
+! This file created from test/mpi/f77/coll/inplacef.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2005 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! This is a simple test that Fortran support the MPI_IN_PLACE value
+!
+ program main
+ use mpi
+ 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
+! 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
+
+! 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
+
+! 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
+! This file created from test/mpi/f77/coll/nonblocking_inpf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2012 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! A simple test for Fortran support of the MPI_IN_PLACE value in Alltoall[vw].
+!
+ program main
+ use mpi
+ 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
+! This file created from test/mpi/f77/coll/nonblockingf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2012 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ 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)
+!
+ 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
+! This file created from test/mpi/f77/coll/red_scat_blockf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2012 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! A simple test for Fortran support of Reduce_scatter_block
+! with or withoutMPI_IN_PLACE.
+!
+ program main
+ use mpi
+ 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
+
+! 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
+! This file created from test/mpi/f77/coll/redscatf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2011 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ subroutine uop( cin, cout, count, datatype )
+ use mpi
+ 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
+!
+! Test of reduce scatter.
+!
+! Each processor contributes its rank + the index to the reduction,
+! then receives the ith sum
+!
+! Can be called with any number of processors.
+!
+
+ program main
+ use mpi
+ integer errs, ierr, toterr
+ integer maxsize
+ parameter (maxsize=1024)
+ integer recvbuf
+ integer size, rank, i, sumval
+ integer comm, sumop
+ external uop
+ integer status
+ integer, dimension(:),allocatable :: sendbuf,recvcounts
+ ALLOCATE(sendbuf(maxsize), STAT=status)
+ ALLOCATE(recvcounts(maxsize), STAT=status)
+ 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
+! 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
+! 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 )
+ DEALLOCATE(sendbuf)
+ DEALLOCATE(recvcounts)
+ call mtest_finalize( errs )
+ call mpi_finalize( ierr )
+
+ end
--- /dev/null
+! This file created from test/mpi/f77/coll/reducelocalf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2009 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+!
+! Test Fortran MPI_Reduce_local with MPI_OP_SUM and with user-defined operation.
+!
+ subroutine user_op( invec, outvec, count, datatype )
+ use mpi
+ 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
+ use mpi
+ 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 )
+! 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 )
+! 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
+! This file created from test/mpi/f77/coll/split_typef.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2011 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ 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
+# This file generated by f77tof90
+uallreducef90 4
+exscanf90 5
+#alltoallwf90 7
+alltoallvf90 7
+inplacef90 4
+reducelocalf90 2 mpiversion=2.2
+redscatf90 4
+split_typef90 4 mpiversion=3.0
+#nonblockingf90 4 mpiversion=3.0
+vw_inplacef90 4 mpiversion=2.2
+red_scat_blockf90 4 mpiversion=2.2
+#nonblocking_inpf90 4 mpiversion=3.0
--- /dev/null
+! This file created from test/mpi/f77/coll/uallreducef.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+!
+! Test user-defined operations. This tests a simple commutative operation
+!
+ subroutine uop( cin, cout, count, datatype )
+ use mpi
+ integer cin(*), cout(*)
+ integer count, datatype
+ integer i
+
+! if (datatype .ne. MPI_INTEGER) then
+! print *, 'Invalid datatype (',datatype,') passed to user_op()'
+! return
+! endif
+
+ do i=1, count
+ cout(i) = cin(i) + cout(i)
+ enddo
+ end
+
+ program main
+ use mpi
+ external uop
+ integer ierr, errs
+ integer count, sumop, i, size
+ integer, DIMENSION(:), ALLOCATABLE :: vin, vout
+ integer comm
+ integer status
+
+ errs = 0
+ ALLOCATE(vin(65000), STAT=status)
+ ALLOCATE(vout(65000), STAT=status)
+
+ 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 )
+! 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 )
+ DEALLOCATE(vout)
+ DEALLOCATE(vin)
+ call mtest_finalize(errs)
+ call mpi_finalize(ierr)
+ end
--- /dev/null
+! This file created from test/mpi/f77/coll/vw_inplacef.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2012 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! A simple test for Fortran support of the MPI_IN_PLACE value in Alltoall[vw].
+!
+ program main
+ use mpi
+ 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
+!
+ 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
+! 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/smpif90")
+ 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")
+ include_directories("${CMAKE_HOME_DIRECTORY}/include/smpi")
+
+ add_executable(allctypesf90 allctypesf90.f90 ../util/mtestf90.f90)
+ # add_executable(createf90 createf90.f90 ../util/mtestf90.f90)
+ add_executable(gaddressf90 gaddressf90.f90 ../util/mtestf90.f90)
+ # add_executable(get_elem_d get_elem_d.f90 ../util/mtestf90.f90)
+ # add_executable(get_elem_u get_elem_u.f90 ../util/mtestf90.f90)
+ add_executable(hindex1f90 hindex1f90.f90 ../util/mtestf90.f90)
+ add_executable(hindexed_blockf90 hindexed_blockf90.f90 ../util/mtestf90.f90)
+ add_executable(indtype indtype.f90 ../util/mtestf90.f90)
+ add_executable(kinds kinds.f90 ../util/mtestf90.f90)
+ add_executable(packef90 packef90.f90 ../util/mtestf90.f90)
+ # add_executable(sizeof sizeof.f90 ../util/mtestf90.f90)
+ # add_executable(structf structf.f90 ../util/mtestf90.f90)
+ # add_executable(trf90 trf90.f90 ../util/mtestf90.f90)
+ add_executable(typecntsf90 typecntsf90.f90 ../util/mtestf90.f90)
+ add_executable(typem2f90 typem2f90.f90 ../util/mtestf90.f90)
+ add_executable(typename3f90 typename3f90.f90 ../util/mtestf90.f90)
+ add_executable(typenamef90 typenamef90.f90 ../util/mtestf90.f90)
+ add_executable(typesnamef90 typesnamef90.f90 ../util/mtestf90.f90)
+ add_executable(typesubf90 typesubf90.f90 ../util/mtestf90.f90)
+ target_link_libraries(allctypesf90 simgrid)
+ # target_link_libraries(createf90 simgrid)
+ target_link_libraries(gaddressf90 simgrid)
+ # target_link_libraries(get_elem_d simgrid)
+ # target_link_libraries(get_elem_u simgrid)
+ target_link_libraries(hindex1f90 simgrid)
+ target_link_libraries(hindexed_blockf90 simgrid)
+ target_link_libraries(indtype simgrid)
+ target_link_libraries(kinds simgrid)
+ target_link_libraries(packef90 simgrid)
+ # target_link_libraries(sizeof simgrid)
+ # target_link_libraries(structf simgrid)
+ # target_link_libraries(trf90 simgrid)
+ target_link_libraries(typecntsf90 simgrid)
+ target_link_libraries(typem2f90 simgrid)
+ target_link_libraries(typename3f90 simgrid)
+ target_link_libraries(typenamef90 simgrid)
+ target_link_libraries(typesnamef90 simgrid)
+ target_link_libraries(typesubf90 simgrid)
+ set_target_properties(allctypesf90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ # set_target_properties(createf90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(gaddressf90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ # set_target_properties(get_elem_d PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ # set_target_properties(get_elem_u PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(hindex1f90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(hindexed_blockf90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(indtype PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(kinds PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(packef90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ # set_target_properties(sizeof PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ # set_target_properties(structf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ # set_target_properties(trf90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(typecntsf90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(typem2f90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(typename3f90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(typenamef90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(typesnamef90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(typesubf90 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}/allctypesf90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/createf90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/gaddressf90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/get_elem_d.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/get_elem_u.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/hindex1f90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/hindexed_blockf90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/indtype.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/kinds.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/packef90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/sizeof.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/structf.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/trf90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/typecntsf90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/typem2f90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/typename3f90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/typenamef90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/typesnamef90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/typesubf90.f90
+ PARENT_SCOPE
+ )
+set(bin_files
+ ${bin_files}
+ PARENT_SCOPE
+ )
+set(txt_files
+ ${txt_files}
+ ${CMAKE_CURRENT_SOURCE_DIR}/testlist
+ PARENT_SCOPE
+ )
--- /dev/null
+! This file created from test/mpi/f77/datatype/allctypesf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2004 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ integer atype, ierr
+!
+ call mtest_init(ierr)
+ call mpi_comm_set_errhandler( MPI_COMM_WORLD, MPI_ERRORS_RETURN, &
+ & ierr )
+!
+! Check that all Ctypes are available in Fortran (MPI 2.1, p 483, line 46)
+!
+ 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
+!
+! Check that all Ctypes are available in Fortran (MPI 2.2)
+! Note that because of implicit declarations in Fortran, this
+! code should compile even with pre MPI 2.2 implementations.
+!
+ 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 )
+! 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
+! address/offset types
+ call checkdtype( MPI_AINT, "MPI_AINT", ierr )
+ call checkdtype( MPI_OFFSET, "MPI_OFFSET", ierr )
+ endif
+!
+ call mtest_finalize( ierr )
+ call MPI_Finalize( ierr )
+ end
+!
+! Check name of datatype
+ subroutine CheckDtype( intype, name, ierr )
+ use mpi
+ integer intype, ierr
+ character *(*) name
+ integer ir, rlen
+ character *(MPI_MAX_OBJECT_NAME) outname
+!
+ 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
+!
+! Check name of datatype (allows alias)
+ subroutine CheckDtype2( intype, name, name2, ierr )
+ use mpi
+ integer intype, ierr
+ character *(*) name, name2
+ integer ir, rlen
+ character *(MPI_MAX_OBJECT_NAME) outname
+!
+ 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) 2004 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ integer ierr
+ integer errs
+ integer nints, nadds, ndtypes, combiner
+ integer nparms(2), dummy(1)
+ integer (kind=MPI_ADDRESS_KIND) adummy(1)
+ integer ntype1, nsize, ntype2, ntype3, i
+!
+! Test the Type_create_f90_xxx routines
+!
+ errs = 0
+ call mtest_init( ierr )
+
+! integers with upto 9 are 4 bytes integers; r of 4 are 2 byte,
+! and r of 2 is 1 byte
+ call mpi_type_create_f90_integer( 9, ntype1, ierr )
+!
+! Check with get contents and envelope...
+ call mpi_type_get_envelope( ntype1, nints, nadds, ndtypes, &
+ combiner, ierr )
+ if (nadds .ne. 0) then
+ errs = errs + 1
+ print *, "There should be no addresses on created type (r=9)"
+ endif
+ if (ndtypes .ne. 0) then
+ errs = errs + 1
+ print *, "There should be no datatypes on created type (r=9)"
+ endif
+ if (nints .ne. 1) then
+ errs = errs + 1
+ print *, "There should be exactly 1 integer on create type (r=9)"
+ endif
+ if (combiner .ne. MPI_COMBINER_F90_INTEGER) then
+ errs = errs + 1
+ print *, "The combiner should be INTEGER, not ", combiner
+ endif
+ if (nints .eq. 1) then
+ call mpi_type_get_contents( ntype1, 1, 0, 0, &
+ nparms, adummy, dummy, ierr )
+ if (nparms(1) .ne. 9) then
+ errs = errs + 1
+ print *, "parameter was ", nparms(1), " should be 9"
+ endif
+ endif
+
+ call mpi_type_create_f90_integer( 8, ntype2, ierr )
+ if (ntype1 .eq. ntype2) then
+ errs = errs + 1
+ print *, "Types with r = 8 and r = 9 are the same, ", &
+ "should be distinct"
+ endif
+
+!
+! Check that we don't create new types each time. This test will fail only
+! if the MPI implementation checks for un-freed types or runs out of space
+ do i=1, 100000
+ call mpi_type_create_f90_integer( 8, ntype3, ierr )
+ enddo
+
+ call mtest_finalize( errs )
+ call mpi_finalize( ierr )
+
+ end
--- /dev/null
+! This file created from test/mpi/f77/datatype/gaddressf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ integer max_asizev
+ parameter (max_asizev=2)
+ integer (kind=MPI_ADDRESS_KIND) aint, aintv(max_asizev)
+
+ 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
+! -*- Mode: Fortran; -*-
+!
+! (C) 2013 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+
+! Based on a test written by Jim Hoekstra on behalf of Cray, Inc.
+! see ticket #884 https://trac.mpich.org/projects/mpich/ticket/884
+
+program get_elem_d
+
+ use mpi
+! implicit none
+
+ integer, parameter :: verbose=0
+ integer, parameter :: cmax=100,dmax=100,imax=60
+ integer, parameter :: nb=2
+ integer :: comm,rank,size,dest,ierror,errs=0
+ integer :: status(MPI_STATUS_SIZE)
+ integer :: i,ii,count,ka,j,jj,k,kj,krat,tag=100
+ integer :: blklen(nb)=(/2,2/)
+ integer :: types(nb)=(/MPI_DOUBLE_PRECISION,MPI_INTEGER/)
+ integer(kind=MPI_ADDRESS_KIND) :: disp(nb)
+ integer :: newtype,ntlen,ians(0:23),ians0(0:3),ians1(20),ians2(20)
+ double precision :: dbuff(dmax), a
+ integer :: ibuff(imax)
+ character :: cbuff(cmax)='X'
+
+ call MPI_Init(ierror)
+ comm=MPI_COMM_WORLD
+ call MPI_Comm_size(comm, size, ierror)
+ dest=size-1
+ call MPI_Comm_rank(comm, rank, ierror)
+ call MPI_Sizeof (j, kj, ierror)
+ call MPI_Sizeof (a, ka, ierror)
+ ntlen=2*ka+2*kj
+ krat=ntlen/kj
+ disp=(/0,2*ka/)
+
+ ! calculate answers for expected i values for Get_elements with derived type
+ ians0(0)=ka
+ ians0(1)=2*ka
+ ians0(2)=2*ka+kj
+ ians0(3)=2*ka+2*kj
+ ii=0
+ do i=1,24
+ if (i .eq. ians0(ii)) ii=ii+1
+ ians1(i)=ii
+ enddo
+ if (rank == 0 .and. verbose > 0) print *, (ians1(k),k=1,24)
+ jj=0
+ do j=0,19,4
+ ians(j)=jj+ka/kj
+ ians(j+1)=jj+2*(ka/kj)
+ ians(j+2)=jj+2*(ka/kj)+1
+ ians(j+3)=jj+2*(ka/kj)+2
+ if (rank == 0 .and. verbose > 0) print *, (ians(k),k=j,j+3)
+ jj=jj+ntlen/kj
+ enddo
+ ii=0
+ do i=1,20
+ if (i .eq. ians(ii)) ii=ii+1
+ ians2(i)=ii
+ enddo
+ if (rank == 0 .and. verbose > 0) print *, (ians2(k),k=1,20)
+
+ if (verbose > 0) print *, MPI_UNDEFINED
+
+ call MPI_Type_create_struct(nb, blklen, disp, types, newtype, ierror)
+ call MPI_Type_commit(newtype, ierror)
+
+ do i=1,24
+ if (rank == 0) then
+ call MPI_Send(cbuff, i, MPI_BYTE, dest, 100, comm, ierror)
+
+ else if (rank == dest) then
+
+ ! first receive
+ call MPI_Recv(dbuff, dmax, newtype, 0, 100, comm, status, ierror)
+ ! check on MPI_Get_elements
+ call MPI_Get_elements(status, newtype, count, ierror)
+ if (count .ne. ians1(i)) then
+ errs=errs+1
+ write (*,fmt="(i2,' R1 Get_elements count=',i3,&
+ &' but should be ',i3)") i,count,ians1(i)
+ endif
+
+ else
+ ! other ranks do not participate
+ endif
+ enddo
+
+ do i=1,20
+ if (rank == 0) then
+ call MPI_Send(ibuff, i, MPI_INTEGER, dest, 100, comm, ierror)
+
+ else if (rank == dest) then
+
+ ! second receive
+ call MPI_Recv(dbuff, dmax, newtype, 0, 100, comm, status, ierror)
+ ! check on MPI_Get_elements
+ call MPI_Get_elements(status, newtype, count, ierror)
+ if (count .ne. ians2(i)) then
+ errs=errs+1
+ write (*,fmt="(i2,' R2 Get_elements count=',i3,&
+ &' but should be ',i3)") i,count,ians2(i)
+ endif
+ else
+ ! other ranks do not participate
+ endif
+ enddo
+
+ if (rank .eq. dest) then
+ if (errs .eq. 0) then
+ write (*,*) " No Errors"
+ else
+ print *, 'errs=',errs
+ endif
+ endif
+
+ call MPI_Type_free(newtype, ierror)
+ call MPI_Finalize(ierror)
+
+end program get_elem_d
--- /dev/null
+! -*- Mode: Fortran; -*-
+!
+! (C) 2013 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+
+! Based on a test written by Jim Hoekstra on behalf of Cray, Inc.
+! see ticket #884 https://trac.mpich.org/projects/mpich/ticket/884
+
+PROGRAM get_elem_u
+
+ USE mpi
+ IMPLICIT NONE
+ INTEGER RANK, SIZE, IERR, COMM, errs
+ INTEGER MAX, I, K, dest
+ INTEGER STATUS(MPI_STATUS_SIZE)
+
+ INTEGER, PARAMETER :: nb=2
+ INTEGER :: blklen(nb)=(/1,1/)
+ INTEGER :: types(nb)=(/MPI_DOUBLE_PRECISION,MPI_CHAR/)
+ INTEGER(kind=MPI_ADDRESS_KIND) :: disp(nb)=(/0,8/)
+
+ INTEGER, PARAMETER :: amax=200
+ INTEGER :: type1, type2, extent
+ REAL :: a(amax)
+
+ errs = 0
+ CALL MPI_Init( ierr )
+ COMM = MPI_COMM_WORLD
+ CALL MPI_Comm_rank(COMM,RANK,IERR)
+ CALL MPI_Comm_size(COMM,SIZE,IERR)
+ dest=size-1
+
+ CALL MPI_Type_create_struct(nb, blklen, disp, types, type1, ierr)
+ CALL MPI_Type_commit(type1, ierr)
+ CALL MPI_Type_extent(type1, extent, ierr)
+
+ CALL MPI_Type_contiguous(4, Type1, Type2, ierr)
+ CALL MPI_Type_commit(Type2, ierr)
+ CALL MPI_Type_extent(Type2, extent, ierr)
+
+ DO k=1,17
+
+ IF(rank .EQ. 0) THEN
+
+ ! send k copies of datatype Type1
+ CALL MPI_Send(a, k, Type1, dest, 0, comm, ierr)
+
+ ELSE IF (rank == dest) THEN
+
+ CALL MPI_Recv(a, 200, Type2, 0, 0, comm, status, ierr)
+ CALL MPI_Get_elements(status, Type2, i, ierr)
+ IF (i .NE. 2*k) THEN
+ errs = errs+1
+ PRINT *, "k=",k," MPI_Get_elements returns", i, ", but it should be", 2*k
+ END IF
+
+ ELSE
+ ! thix rank does not particupate
+ END IF
+ enddo
+
+ CALL MPI_Type_free(type1, ierr)
+ CALL MPI_Type_free(type2, ierr)
+
+ CALL MPI_Finalize( ierr )
+
+ IF(rank .EQ. 0 .AND. errs .EQ. 0) THEN
+ PRINT *, " No Errors"
+ END IF
+
+END PROGRAM get_elem_u
--- /dev/null
+! This file created from test/mpi/f77/datatype/hindex1f.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+!
+! (C) 2011 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ 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
+!
+! Test for hindexed;
+!
+ 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 )
+!
+ 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 )
+!
+ len = position
+ position = 0
+ call mpi_unpack( packbuf, len, position, outbuf, 10, &
+ & MPI_INTEGER, MPI_COMM_WORLD, ierr )
+!
+ 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
+!
+ call mpi_type_free( dtype, ierr )
+!
+ call mtest_finalize( errs )
+ call mpi_finalize( ierr )
+ end
--- /dev/null
+! This file created from test/mpi/f77/datatype/hindexed_blockf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ integer errs, ierr, i, intsize
+ integer type1, type2, type3, type4, type5
+ integer max_asizev
+ parameter (max_asizev = 10)
+ integer (kind=MPI_ADDRESS_KIND) aint, aintv(max_asizev)
+
+ 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 )
+!
+ call mpi_type_size( MPI_INTEGER, intsize, ierr )
+!
+ 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
+!
+ 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 )
+!
+ aint = 3 * intsize
+ call mpi_type_create_hvector( 10, 1, aint, MPI_INTEGER, type3, &
+ & ierr )
+ call mpi_type_commit( type3, ierr )
+!
+ 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 )
+!
+! 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
+!
+ 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
+!
+ 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
+!
+ 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
+!
+ 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
+!
+ 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
+! -*- Mode: Fortran; -*-
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! This test contributed by Kim McMahon, Cray
+!
+ program main
+ implicit none
+ use mpi
+
+ integer ierr, i, j, type, count,errs
+ parameter (count = 4)
+ integer rank, size, xfersize
+ integer status(MPI_STATUS_SIZE)
+ integer blocklens(count), displs(count)
+ double precision,dimension(:,:),allocatable :: sndbuf, rcvbuf
+ logical verbose
+
+ verbose = .false.
+ call mtest_init ( ierr )
+ call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
+ call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
+ if (size .lt. 2) then
+ print *, "Must have at least 2 processes"
+ call MPI_Abort( 1, MPI_COMM_WORLD, ierr )
+ endif
+
+ errs = 0
+ allocate(sndbuf(7,100))
+ allocate(rcvbuf(7,100))
+
+ do j=1,100
+ do i=1,7
+ sndbuf(i,j) = (i+j) * 1.0
+ enddo
+ enddo
+
+ do i=1,count
+ blocklens(i) = 7
+ enddo
+
+! bug occurs when first two displacements are 0
+ displs(1) = 0
+ displs(2) = 0
+ displs(3) = 10
+ displs(4) = 10
+
+ call mpi_type_indexed( count, blocklens, displs*blocklens(1), &
+ & MPI_DOUBLE_PRECISION, type, ierr )
+
+ call mpi_type_commit( type, ierr )
+
+! send using this new type
+
+ if (rank .eq. 0) then
+
+ call mpi_send( sndbuf(1,1), 1, type, 1, 0, MPI_COMM_WORLD,ierr )
+
+ else if (rank .eq. 1) then
+
+ xfersize=count * blocklens(1)
+ call mpi_recv( rcvbuf(1,1), xfersize, MPI_DOUBLE_PRECISION, 0, 0, &
+ & MPI_COMM_WORLD,status, ierr )
+
+
+! Values that should be sent
+
+ if (verbose) then
+! displacement = 0
+ j=1
+ do i=1, 7
+ print*,'sndbuf(',i,j,') = ',sndbuf(i,j)
+ enddo
+
+! displacement = 10
+ j=11
+ do i=1,7
+ print*,'sndbuf(',i,j,') = ',sndbuf(i,j)
+ enddo
+ print*,' '
+
+! Values received
+ do j=1,count
+ do i=1,7
+ print*,'rcvbuf(',i,j,') = ',rcvbuf(i,j)
+ enddo
+ enddo
+ endif
+
+! Error checking
+ do j=1,2
+ do i=1,7
+ if (rcvbuf(i,j) .ne. sndbuf(i,1)) then
+ print*,'ERROR in rcvbuf(',i,j,')'
+ print*,'Received ', rcvbuf(i,j),' expected ',sndbuf(i,11)
+ errs = errs+1
+ endif
+ enddo
+ enddo
+
+ do j=3,4
+ do i=1,7
+ if (rcvbuf(i,j) .ne. sndbuf(i,11)) then
+ print*,'ERROR in rcvbuf(',i,j,')'
+ print*,'Received ', rcvbuf(i,j),' expected ',sndbuf(i,11)
+ errs = errs+1
+ endif
+ enddo
+ enddo
+ endif
+!
+ call mpi_type_free( type, ierr )
+ call mtest_finalize( errs )
+ call mpi_finalize( ierr )
+
+ end
--- /dev/null
+! -*- Mode: Fortran; -*-
+!
+! (C) 2011 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! This program tests that all of the integer kinds defined in MPI 2.2 are
+! available.
+!
+ program main
+ use mpi
+ integer (kind=MPI_ADDRESS_KIND) aint, taint
+ integer (kind=MPI_OFFSET_KIND) oint, toint
+ integer (kind=MPI_INTEGER_KIND) iint, tiint
+ integer s(MPI_STATUS_SIZE)
+ integer i, wsize, wrank, ierr, errs
+!
+ errs = 0
+!
+ call MTEST_INIT(ierr)
+ call MPI_COMM_SIZE(MPI_COMM_WORLD,wsize,ierr)
+ call MPI_COMM_RANK(MPI_COMM_WORLD,wrank,ierr)
+ if (wsize .lt. 2) then
+ print *, "This test requires at least 2 processes"
+ call MPI_ABORT( MPI_COMM_WORLD, 1, ierr )
+ endif
+!
+! Some compilers (e.g., gfortran) will issue an error if, at compile time,
+! an assignment would cause overflow, even if appropriated guarded. To
+! avoid this problem, we must compute the value in the integer (the
+! code here is simple; there are faster fixes for this but this is easy
+ if (wrank .eq. 0) then
+ if (range(aint) .ge. 10) then
+ aint = 1
+ do i=1, range(aint)-1
+ aint = aint * 10
+ enddo
+ aint = aint - 1
+ else
+ aint = 12345678
+ endif
+ if (range(oint) .ge. 10) then
+ oint = 1
+ do i=1, range(oint)-1
+ oint = oint * 10
+ enddo
+ oint = oint - 1
+ else
+ oint = 12345678
+ endif
+ if (range(iint) .ge. 10) then
+ iint = 1
+ do i=1, range(iint)-1
+ iint = iint * 10
+ enddo
+ iint = iint - 1
+ else
+ iint = 12345678
+ endif
+ call MPI_SEND( aint, 1, MPI_AINT, 1, 0, MPI_COMM_WORLD, ierr )
+ call MPI_SEND( oint, 1, MPI_OFFSET, 1, 1, MPI_COMM_WORLD, ierr )
+ call MPI_SEND( iint, 1, MPI_INTEGER, 1, 2, MPI_COMM_WORLD, ierr )
+!
+ else if (wrank .eq. 1) then
+ if (range(taint) .ge. 10) then
+ taint = 1
+ do i=1, range(taint)-1
+ taint = taint * 10
+ enddo
+ taint = taint - 1
+ else
+ taint = 12345678
+ endif
+ if (range(toint) .ge. 10) then
+ toint = 1
+ do i=1, range(toint)-1
+ toint = toint * 10
+ enddo
+ toint = toint - 1
+ else
+ toint = 12345678
+ endif
+ if (range(tiint) .ge. 10) then
+ tiint = 1
+ do i=1, range(tiint)-1
+ tiint = tiint * 10
+ enddo
+ tiint = tiint - 1
+ else
+ tiint = 12345678
+ endif
+ call MPI_RECV( aint, 1, MPI_AINT, 0, 0, MPI_COMM_WORLD, s, ierr )
+ if (taint .ne. aint) then
+ print *, "Address-sized int not correctly transfered"
+ print *, "Value should be ", taint, " but is ", aint
+ errs = errs + 1
+ endif
+ call MPI_RECV( oint, 1, MPI_OFFSET, 0, 1, MPI_COMM_WORLD, s, ierr )
+ if (toint .ne. oint) then
+ print *, "Offset-sized int not correctly transfered"
+ print *, "Value should be ", toint, " but is ", oint
+ errs = errs + 1
+ endif
+ call MPI_RECV( iint, 1, MPI_INTEGER, 0, 2, MPI_COMM_WORLD, s, ierr )
+ if (tiint .ne. iint) then
+ print *, "Integer (by kind) not correctly transfered"
+ print *, "Value should be ", tiint, " but is ", iint
+ errs = errs + 1
+ endif
+!
+ endif
+!
+ call MTEST_FINALIZE(errs)
+ call MPI_FINALIZE(ierr)
+
+ end
--- /dev/null
+! This file created from test/mpi/f77/datatype/packef.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ 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)
+ integer (kind=MPI_ADDRESS_KIND) aint, aintv(max_asizev)
+
+
+ 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
+
+!
+! Initialize values
+!
+ 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
+!
+ aintv(1) = pbufsize
+ aintv(2) = 0
+ aintv(3) = 0
+! One MPI implementation failed to increment the position; instead,
+! it set the value with the amount of data packed in this call
+! 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)
+!
+! 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 )
+!
+! Now, test the values
+!
+ 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
+!
+ call mtest_finalize( errs )
+ call mpi_finalize( ierr )
+ end
--- /dev/null
+! -*- Mode: Fortran; -*-
+!
+! (C) 2007 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! This program tests that the MPI_SIZEOF routine is implemented for the
+! predefined scalar Fortran types. It confirms that the size of these
+! types matches the size of the corresponding MPI datatypes.
+!
+ program main
+ use mpi
+ integer ierr, errs
+ integer rank, size, mpisize
+ logical verbose
+ real r1,r1v(2)
+ double precision d1,d1v(3)
+ complex c1,c1v(4)
+ integer i1,i1v(5)
+ character ch1,ch1v(6)
+ logical l1,l1v(7)
+
+ verbose = .false.
+ errs = 0
+ call mtest_init ( ierr )
+ call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
+
+! Test of scalar types
+ call mpi_sizeof( r1, size, ierr )
+ call mpi_type_size( MPI_REAL, mpisize, ierr )
+ if (size .ne. mpisize) then
+ errs = errs + 1
+ print *, "Size of MPI_REAL = ", mpisize, &
+ & " but MPI_SIZEOF gives ", size
+ endif
+
+ call mpi_sizeof( d1, size, ierr )
+ call mpi_type_size( MPI_DOUBLE_PRECISION, mpisize, ierr )
+ if (size .ne. mpisize) then
+ errs = errs + 1
+ print *, "Size of MPI_DOUBLE_PRECISION = ", mpisize, &
+ " but MPI_SIZEOF gives ", size
+ endif
+
+ call mpi_sizeof( i1, size, ierr )
+ call mpi_type_size( MPI_INTEGER, mpisize, ierr )
+ if (size .ne. mpisize) then
+ errs = errs + 1
+ print *, "Size of MPI_INTEGER = ", mpisize, &
+ & " but MPI_SIZEOF gives ", size
+ endif
+
+ call mpi_sizeof( c1, size, ierr )
+ call mpi_type_size( MPI_COMPLEX, mpisize, ierr )
+ if (size .ne. mpisize) then
+ errs = errs + 1
+ print *, "Size of MPI_COMPLEX = ", mpisize, &
+ & " but MPI_SIZEOF gives ", size
+ endif
+
+ call mpi_sizeof( ch1, size, ierr )
+ call mpi_type_size( MPI_CHARACTER, mpisize, ierr )
+ if (size .ne. mpisize) then
+ errs = errs + 1
+ print *, "Size of MPI_CHARACTER = ", mpisize, &
+ " but MPI_SIZEOF gives ", size
+ endif
+
+ call mpi_sizeof( l1, size, ierr )
+ call mpi_type_size( MPI_LOGICAL, mpisize, ierr )
+ if (size .ne. mpisize) then
+ errs = errs + 1
+ print *, "Size of MPI_LOGICAL = ", mpisize, &
+ & " but MPI_SIZEOF gives ", size
+ endif
+!
+! Test of vector types (1-dimensional)
+ call mpi_sizeof( r1v, size, ierr )
+ call mpi_type_size( MPI_REAL, mpisize, ierr )
+ if (size .ne. mpisize) then
+ errs = errs + 1
+ print *, "Size of MPI_REAL = ", mpisize, &
+ & " but MPI_SIZEOF gives ", size
+ endif
+
+ call mpi_sizeof( d1v, size, ierr )
+ call mpi_type_size( MPI_DOUBLE_PRECISION, mpisize, ierr )
+ if (size .ne. mpisize) then
+ errs = errs + 1
+ print *, "Size of MPI_DOUBLE_PRECISION = ", mpisize, &
+ " but MPI_SIZEOF gives ", size
+ endif
+
+ call mpi_sizeof( i1v, size, ierr )
+ call mpi_type_size( MPI_INTEGER, mpisize, ierr )
+ if (size .ne. mpisize) then
+ errs = errs + 1
+ print *, "Size of MPI_INTEGER = ", mpisize, &
+ & " but MPI_SIZEOF gives ", size
+ endif
+
+ call mpi_sizeof( c1v, size, ierr )
+ call mpi_type_size( MPI_COMPLEX, mpisize, ierr )
+ if (size .ne. mpisize) then
+ errs = errs + 1
+ print *, "Size of MPI_COMPLEX = ", mpisize, &
+ & " but MPI_SIZEOF gives ", size
+ endif
+
+ call mpi_sizeof( ch1v, size, ierr )
+ call mpi_type_size( MPI_CHARACTER, mpisize, ierr )
+ if (size .ne. mpisize) then
+ errs = errs + 1
+ print *, "Size of MPI_CHARACTER = ", mpisize, &
+ " but MPI_SIZEOF gives ", size
+ endif
+
+ call mpi_sizeof( l1v, size, ierr )
+ call mpi_type_size( MPI_LOGICAL, mpisize, ierr )
+ if (size .ne. mpisize) then
+ errs = errs + 1
+ print *, "Size of MPI_LOGICAL = ", mpisize, &
+ & " but MPI_SIZEOF gives ", size
+ endif
+
+ call mtest_finalize( errs )
+ call mpi_finalize( ierr )
+
+ end
--- /dev/null
+!
+! (C) 2004 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! Thanks to
+! William R. Magro
+! for this test
+!
+! It has been modifiedly slightly to work with the automated MPI
+! tests.
+! WDG.
+!
+! It was further modified to use MPI_Get_address instead of MPI_Address
+! for MPICH, and to fit in the MPICH test harness - WDG
+!
+ program bustit
+ implicit none
+ use mpi
+
+ integer comm
+ integer newtype
+ integer me
+ integer position
+ integer type(5)
+ integer length(5)
+ integer (kind=MPI_ADDRESS_KIND) disp(5)
+ integer bufsize
+ integer errs, toterrs
+ parameter (bufsize=100)
+ character buf(bufsize)
+ character name*(10)
+ integer status(MPI_STATUS_SIZE)
+ integer i, size
+ double precision x
+ integer src, dest
+ integer ierr
+
+ errs = 0
+! Enroll in MPI
+ call mpi_init(ierr)
+
+! get my rank
+ call mpi_comm_rank(MPI_COMM_WORLD, me, ierr)
+ call mpi_comm_size(MPI_COMM_WORLD, size, ierr )
+ if (size .lt. 2) then
+ print *, "Must have at least 2 processes"
+ call MPI_Abort( 1, MPI_COMM_WORLD, ierr )
+ endif
+
+ comm = MPI_COMM_WORLD
+ src = 0
+ dest = 1
+
+ if(me.eq.src) then
+ i=5
+ x=5.1234d0
+ name="Hello"
+
+ type(1)=MPI_CHARACTER
+ length(1)=5
+ call mpi_get_address(name,disp(1),ierr)
+
+ type(2)=MPI_DOUBLE_PRECISION
+ length(2)=1
+ call mpi_get_address(x,disp(2),ierr)
+
+ call mpi_type_create_struct(2,length,disp,type,newtype,ierr)
+ call mpi_type_commit(newtype,ierr)
+ call mpi_barrier( MPI_COMM_WORLD, ierr )
+ call mpi_send(MPI_BOTTOM,1,newtype,dest,1,comm,ierr)
+ call mpi_type_free(newtype,ierr)
+! write(*,*) "Sent ",name(1:5),x
+ else
+! Everyone calls barrier incase size > 2
+ call mpi_barrier( MPI_COMM_WORLD, ierr )
+ if (me.eq.dest) then
+ position=0
+
+ name = " "
+ x = 0.0d0
+ call mpi_recv(buf,bufsize,MPI_PACKED, src, &
+ & 1, comm, status, ierr)
+
+ call mpi_unpack(buf,bufsize,position, &
+ & name,5,MPI_CHARACTER, comm,ierr)
+ call mpi_unpack(buf,bufsize,position, &
+ & x,1,MPI_DOUBLE_PRECISION, comm,ierr)
+! Check the return values (/= is not-equal in F90)
+ if (name /= "Hello") then
+ errs = errs + 1
+ print *, "Received ", name, " but expected Hello"
+ endif
+ if (abs(x-5.1234) .gt. 1.0e-6) then
+ errs = errs + 1
+ print *, "Received ", x, " but expected 5.1234"
+ endif
+ endif
+ endif
+!
+! Sum up errs and report the result
+ call mpi_reduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, 0, &
+ & MPI_COMM_WORLD, ierr )
+ if (me .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
+# This file generated by f77tof90
+#typenamef90 1
+#typename3f90 1 mpiversion=3.0
+#typesnamef90 1
+#typecntsf90 1
+#typem2f90 1
+#typesubf90 1
+#packef90 1
+gaddressf90 1
+#allctypesf90 1
+#hindex1f90 1
+#hindexed_blockf90 1 mpiversion=1.0
+#structf 2
+indtype 2
+#createf90 1
+#sizeof 1
+kinds 2 mpiversion=1.0
+#trf90 1
+#get_elem_d 2
+#get_elem_u 2
--- /dev/null
+! -*- Mode: Fortran; -*-
+!
+! (C) 2011 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! Based on a sample program that triggered a segfault in MPICH
+program testf90_mpi
+ implicit none
+ use mpi
+
+ integer errs
+ integer :: rk_mpi, ierr, ctype
+
+ errs = 0
+ call mtest_init(ierr)
+
+ call MPI_Type_create_f90_real(15, MPI_UNDEFINED, rk_mpi, ierr)
+ call MPI_Type_contiguous(19, rk_mpi, ctype, ierr)
+ call MPI_Type_commit(ctype, ierr)
+ call MPI_Type_free(ctype, ierr)
+
+ call mtest_finalize(errs)
+ call MPI_Finalize(ierr)
+
+end program testf90_mpi
--- /dev/null
+! This file created from test/mpi/f77/datatype/typecntsf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ integer errs, ierr
+ integer ntype1, ntype2
+!
+! This is a very simple test that just tests that the contents/envelope
+! routines can be called. This should be upgraded to test the new
+! MPI-2 datatype routines (which use address-sized integers)
+!
+
+ 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 )
+
+!
+ call mtest_finalize( errs )
+ call mpi_finalize( ierr )
+ end
+!
+ subroutine explore( dtype, mycomb, errs )
+ use mpi
+ 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)
+ integer (kind=MPI_ADDRESS_KIND) aint, aintv(max_asizev)
+
+!
+ call mpi_type_get_envelope( dtype, nints, nadds, ntype, &
+ & combiner, ierr )
+!
+ if (combiner .ne. MPI_COMBINER_NAMED) then
+ call mpi_type_get_contents( dtype, &
+ & max_nints, max_asizev, max_dtypes, &
+ & intv, aintv, dtypesv, ierr )
+!
+! dtypesv of constructed types must be free'd now
+!
+ 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
+!
+! 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
+! This file created from test/mpi/f77/datatype/typem2f.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ integer errs, ierr, i, intsize
+ integer type1, type2, type3, type4, type5
+ integer max_asizev
+ parameter (max_asizev = 10)
+ integer (kind=MPI_ADDRESS_KIND) aint, aintv(max_asizev)
+
+ 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 )
+!
+ call mpi_type_size( MPI_INTEGER, intsize, ierr )
+!
+ 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
+!
+ 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 )
+!
+ aint = 3 * intsize
+ call mpi_type_create_hvector( 10, 1, aint, MPI_INTEGER, type3, &
+ & ierr )
+ call mpi_type_commit( type3, ierr )
+!
+ 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 )
+!
+! 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
+!
+ 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
+!
+ 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
+!
+ 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
+!
+ 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
+!
+ 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
+! This file created from test/mpi/f77/datatype/typename3f.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+!
+! (C) 2012 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ character*(MPI_MAX_OBJECT_NAME) name
+ integer namelen
+ integer ierr, errs
+
+ errs = 0
+
+ call mtest_init( ierr )
+!
+! Check each Fortran datatype, including the size-specific ones
+! 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
+! This file created from test/mpi/f77/datatype/typenamef.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ character*(MPI_MAX_OBJECT_NAME) name
+ integer namelen
+ integer ierr, errs
+
+ errs = 0
+
+ call mtest_init( ierr )
+!
+! Check each Fortran datatype, including the size-specific ones
+! 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
+
+! 2COMPLEX was present only in MPI 1.0
+! call MPI_Type_get_name( MPI_2COMPLEX, name, namelen, ierr )
+! if (name(1:namelen) .ne. "MPI_2COMPLEX") then
+! errs = errs + 1
+! print *, "Expected MPI_2COMPLEX but got "//name(1:namelen)
+! endif
+!
+ 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
+
+! 2DOUBLE_COMPLEX isn't in MPI 2.1
+! call MPI_Type_get_name( MPI_2DOUBLE_COMPLEX, name, namelen, ierr )
+! if (name(1:namelen) .ne. "MPI_2DOUBLE_COMPLEX") then
+! errs = errs + 1
+! print *, "Expected MPI_2DOUBLE_COMPLEX but got "//
+! & name(1:namelen)
+! 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
+
+! MPI_INTEGER16 is in MPI 2.1, but it is missing from most tables
+! Some MPI implementations may not provide it
+! if (MPI_INTEGER16 .ne. MPI_DATATYPE_NULL) then
+! call MPI_Type_get_name( MPI_INTEGER16, name, namelen, ierr )
+! if (name(1:namelen) .ne. "MPI_INTEGER16") then
+! errs = errs + 1
+! print *, "Expected MPI_INTEGER16 but got "//
+! & name(1:namelen)
+! endif
+! endif
+
+ call mtest_finalize( errs )
+ call MPI_Finalize( ierr )
+ end
--- /dev/null
+! This file created from test/mpi/f77/datatype/typesnamef.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ 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
+!
+! 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
+! This file created from test/mpi/f77/datatype/typesubf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ 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 )
+!
+! Create a Fortran-style subarray
+ fullsizes(1) = maxn
+ fullsizes(2) = maxm
+ subsizes(1) = maxn - 3
+ subsizes(2) = maxm - 4
+! starts are from zero, even in Fortran
+ starts(1) = 1
+ starts(2) = 2
+! In Fortran 90 notation, the original array is
+! integer a(maxn,maxm)
+! and the subarray is
+! a(1+1:(maxn-3) +(1+1)-1,2+1:(maxm-4)+(2+1)-1)
+! 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 )
+!
+! 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 )
+!
+! 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/smpif90")
+ 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")
+ include_directories("${CMAKE_HOME_DIRECTORY}/include/smpi")
+
+ add_executable(baseenvf90 baseenvf90.f90 ../util/mtestf90.f90)
+ target_link_libraries(baseenvf90 simgrid)
+ set_target_properties(baseenvf90 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}/baseenvf90.f90
+ PARENT_SCOPE
+ )
+set(bin_files
+ ${bin_files}
+ PARENT_SCOPE
+ )
+set(txt_files
+ ${txt_files}
+ ${CMAKE_CURRENT_SOURCE_DIR}/testlist
+ PARENT_SCOPE
+ )
--- /dev/null
+! This file created from test/mpi/f77/init/baseenvf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ 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
+# This file generated by f77tof90
+baseenvf90 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/smpif90")
+ 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")
+ include_directories("${CMAKE_HOME_DIRECTORY}/include/smpi")
+
+ add_executable(allpairf90 allpairf90.f90 ../util/mtestf90.f90)
+ add_executable(greqf90 greqf90.f90 dummyf90.f90 ../util/mtestf90.f90)
+# add_executable(mprobef90 mprobef90.f90 ../util/mtestf90.f90)
+ add_executable(statusesf90 statusesf90.f90 ../util/mtestf90.f90)
+ target_link_libraries(allpairf90 simgrid)
+ target_link_libraries(greqf90 simgrid)
+# target_link_libraries(mprobef90 simgrid)
+ target_link_libraries(statusesf90 simgrid)
+ set_target_properties(allpairf90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(greqf90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+# set_target_properties(mprobef90 PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}")
+ set_target_properties(statusesf90 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}/allpairf90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/dummyf90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/greqf90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/mprobef90.f90
+ ${CMAKE_CURRENT_SOURCE_DIR}/statusesf90.f90
+ PARENT_SCOPE
+ )
+set(bin_files
+ ${bin_files}
+ PARENT_SCOPE
+ )
+set(txt_files
+ ${txt_files}
+ ${CMAKE_CURRENT_SOURCE_DIR}/testlist
+ PARENT_SCOPE
+ )
--- /dev/null
+! This file created from test/mpi/f77/pt2pt/allpairf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2012 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! This program is based on the allpair.f test from the MPICH-1 test
+! (test/pt2pt/allpair.f), which in turn was inspired by a bug report from
+! fsset@corelli.lerc.nasa.gov (Scott Townsend)
+
+ program allpair
+ use mpi
+ integer ierr, errs, comm
+ logical mtestGetIntraComm
+ logical verbose
+ common /flags/ verbose
+
+ errs = 0
+ verbose = .false.
+! 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
+!
+ call MTest_Finalize( errs )
+ call MPI_Finalize(ierr)
+!
+ end
+!
+ subroutine test_pair_send( comm, errs )
+ use mpi
+ 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
+!
+ if (verbose) then
+ print *, ' Send and recv'
+ endif
+!
+ call mpi_comm_rank( comm, rank, ierr )
+ call mpi_comm_size( comm, size, ierr )
+ next = rank + 1
+ if (next .ge. size) next = 0
+!
+ prev = rank - 1
+ if (prev .lt. 0) prev = size - 1
+!
+ tag = 1123
+ 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_Send(send_buf, count, MPI_REAL, next, tag, &
+ & comm, ierr)
+!
+ call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
+ & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, status, ierr)
+!
+ 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 )
+!
+ call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, comm, ierr)
+ end if
+!
+ end
+!
+ subroutine test_pair_rsend( comm, errs )
+ use mpi
+ 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
+!
+ if (verbose) then
+ print *, ' Rsend and recv'
+ endif
+!
+!
+ call mpi_comm_rank( comm, rank, ierr )
+ call mpi_comm_size( comm, size, ierr )
+ next = rank + 1
+ if (next .ge. size) next = 0
+!
+ prev = rank - 1
+ if (prev .lt. 0) prev = size - 1
+!
+ tag = 1456
+ count = TEST_SIZE / 3
+!
+ call clear_test_data(recv_buf,TEST_SIZE)
+!
+ if (rank .eq. 0) then
+!
+ call init_test_data(send_buf,TEST_SIZE)
+!
+ call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag, &
+ & comm, status, ierr )
+!
+ call MPI_Rsend(send_buf, count, MPI_REAL, next, tag, &
+ & comm, ierr)
+!
+ call MPI_Probe(MPI_ANY_SOURCE, tag, comm, status, ierr)
+!
+ if (status(MPI_SOURCE) .ne. next) then
+ print *, 'Rsend: Incorrect source, expected', next, &
+ & ', got', status(MPI_SOURCE)
+ errs = errs + 1
+ end if
+!
+ if (status(MPI_TAG) .ne. tag) then
+ print *, 'Rsend: Incorrect tag, expected', tag, &
+ & ', got', status(MPI_TAG)
+ errs = errs + 1
+ end if
+!
+ call MPI_Get_count(status, MPI_REAL, i, ierr)
+!
+ if (i .ne. count) then
+ print *, 'Rsend: Incorrect count, expected', count, &
+ & ', got', i
+ errs = errs + 1
+ end if
+!
+ call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
+ & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
+ & status, ierr)
+!
+ call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, &
+ & 'rsend and recv', errs )
+!
+ else if (prev .eq. 0) then
+!
+ 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 )
+!
+ call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, &
+ & comm, ierr)
+ end if
+!
+ end
+!
+ subroutine test_pair_ssend( comm, errs )
+ use mpi
+ 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
+!
+ if (verbose) then
+ print *, ' Ssend and recv'
+ endif
+!
+!
+ call mpi_comm_rank( comm, rank, ierr )
+ call mpi_comm_size( comm, size, ierr )
+ next = rank + 1
+ if (next .ge. size) next = 0
+!
+ prev = rank - 1
+ if (prev .lt. 0) prev = size - 1
+!
+ tag = 1789
+ count = TEST_SIZE / 3
+!
+ call clear_test_data(recv_buf,TEST_SIZE)
+!
+ if (rank .eq. 0) then
+!
+ call init_test_data(send_buf,TEST_SIZE)
+!
+ call MPI_Iprobe(MPI_ANY_SOURCE, tag, &
+ & comm, flag, status, ierr)
+!
+ if (flag) then
+ print *, 'Ssend: Iprobe succeeded! source', &
+ & status(MPI_SOURCE), &
+ & ', tag', status(MPI_TAG)
+ errs = errs + 1
+ end if
+!
+ call MPI_Ssend(send_buf, count, MPI_REAL, next, tag, &
+ & comm, ierr)
+!
+ do while (.not. flag)
+ call MPI_Iprobe(MPI_ANY_SOURCE, tag, &
+ & comm, flag, status, ierr)
+ end do
+!
+ if (status(MPI_SOURCE) .ne. next) then
+ print *, 'Ssend: Incorrect source, expected', next, &
+ & ', got', status(MPI_SOURCE)
+ errs = errs + 1
+ end if
+!
+ if (status(MPI_TAG) .ne. tag) then
+ print *, 'Ssend: Incorrect tag, expected', tag, &
+ & ', got', status(MPI_TAG)
+ errs = errs + 1
+ end if
+!
+ call MPI_Get_count(status, MPI_REAL, i, ierr)
+!
+ if (i .ne. count) then
+ print *, 'Ssend: Incorrect count, expected', count, &
+ & ', got', i
+ errs = errs + 1
+ end if
+!
+ call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
+ & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
+ & status, ierr)
+!
+ call msg_check( recv_buf, next, tag, count, status, &
+ & TEST_SIZE, 'ssend 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, &
+ & 'ssend and recv', errs )
+!
+ call MPI_Ssend(recv_buf, count, MPI_REAL, prev, tag, &
+ & comm, ierr)
+ end if
+!
+ end
+!
+ subroutine test_pair_isend( comm, errs )
+ use mpi
+ 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
+!
+ if (verbose) then
+ print *, ' isend and irecv'
+ endif
+!
+!
+ call mpi_comm_rank( comm, rank, ierr )
+ call mpi_comm_size( comm, size, ierr )
+ next = rank + 1
+ if (next .ge. size) next = 0
+!
+ prev = rank - 1
+ if (prev .lt. 0) prev = size - 1
+!
+ tag = 2123
+ count = TEST_SIZE / 5
+!
+ call clear_test_data(recv_buf,TEST_SIZE)
+!
+ if (rank .eq. 0) then
+!
+ call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
+ & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
+ & requests(1), ierr)
+!
+ call init_test_data(send_buf,TEST_SIZE)
+!
+ call MPI_Isend(send_buf, count, MPI_REAL, next, tag, &
+ & comm, requests(2), ierr)
+!
+ call MPI_Waitall(2, requests, statuses, ierr)
+!
+ call rq_check( requests, 2, 'isend and irecv' )
+!
+ call msg_check( recv_buf, next, tag, count, statuses(1,1), &
+ & TEST_SIZE, 'isend and irecv', 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, &
+ & 'isend and irecv', errs )
+!
+ call MPI_Isend(recv_buf, count, MPI_REAL, prev, tag, &
+ & comm, requests(1), ierr)
+!
+ call MPI_Wait(requests(1), status, ierr)
+!
+ call rq_check( requests(1), 1, 'isend and irecv' )
+!
+ end if
+!
+ end
+!
+ subroutine test_pair_irsend( comm, errs )
+ use mpi
+ 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
+!
+ if (verbose) then
+ print *, ' Irsend and irecv'
+ endif
+!
+ call mpi_comm_rank( comm, rank, ierr )
+ call mpi_comm_size( comm, size, ierr )
+ next = rank + 1
+ if (next .ge. size) next = 0
+!
+ prev = rank - 1
+ if (prev .lt. 0) prev = size - 1
+!
+ call mpi_comm_dup( comm, dupcom, ierr )
+!
+ tag = 2456
+ count = TEST_SIZE / 3
+!
+ call clear_test_data(recv_buf,TEST_SIZE)
+!
+ if (rank .eq. 0) then
+!
+ call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
+ & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
+ & requests(1), ierr)
+!
+ call init_test_data(send_buf,TEST_SIZE)
+!
+ call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, next, 0, &
+ & MPI_BOTTOM, 0, MPI_INTEGER, next, 0, &
+ & dupcom, status, ierr )
+!
+ call MPI_Irsend(send_buf, count, MPI_REAL, next, tag, &
+ & comm, requests(2), ierr)
+!
+ index = -1
+ do while (index .ne. 1)
+ call MPI_Waitany(2, requests, index, statuses, ierr)
+ end do
+!
+ call rq_check( requests(1), 1, 'irsend and irecv' )
+!
+ call msg_check( recv_buf, next, tag, count, statuses, &
+ & TEST_SIZE, 'irsend and irecv', errs )
+!
+ else if (prev .eq. 0) then
+!
+ call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
+ & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
+ & requests(1), ierr)
+!
+ call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, prev, 0, &
+ & MPI_BOTTOM, 0, MPI_INTEGER, prev, 0, &
+ & dupcom, status, ierr )
+!
+ flag = .FALSE.
+ do while (.not. flag)
+ call MPI_Test(requests(1), flag, status, ierr)
+ end do
+!
+ call rq_check( requests, 1, 'irsend and irecv (test)' )
+!
+ call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
+ & 'irsend and irecv', errs )
+!
+ call MPI_Irsend(recv_buf, count, MPI_REAL, prev, tag, &
+ & comm, requests(1), ierr)
+!
+ call MPI_Waitall(1, requests, statuses, ierr)
+!
+ call rq_check( requests, 1, 'irsend and irecv' )
+!
+ end if
+!
+ call mpi_comm_free( dupcom, ierr )
+!
+ end
+!
+ subroutine test_pair_issend( comm, errs )
+ use mpi
+ 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
+!
+ if (verbose) then
+ print *, ' issend and irecv (testall)'
+ endif
+!
+!
+ call mpi_comm_rank( comm, rank, ierr )
+ call mpi_comm_size( comm, size, ierr )
+ next = rank + 1
+ if (next .ge. size) next = 0
+!
+ prev = rank - 1
+ if (prev .lt. 0) prev = size - 1
+!
+ tag = 2789
+ count = TEST_SIZE / 3
+!
+ call clear_test_data(recv_buf,TEST_SIZE)
+!
+ if (rank .eq. 0) then
+!
+ call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
+ & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
+ & requests(1), ierr)
+!
+ call init_test_data(send_buf,TEST_SIZE)
+!
+ call MPI_Issend(send_buf, count, MPI_REAL, next, tag, &
+ & comm, requests(2), ierr)
+!
+ flag = .FALSE.
+ do while (.not. flag)
+ call MPI_Testall(2, requests, flag, statuses, ierr)
+ end do
+!
+ call rq_check( requests, 2, 'issend and irecv (testall)' )
+!
+ call msg_check( recv_buf, next, tag, count, statuses(1,1), &
+ & TEST_SIZE, 'issend and recv (testall)', 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, &
+ & 'issend and recv', errs )
+
+ call MPI_Issend(recv_buf, count, MPI_REAL, prev, tag, &
+ & comm, requests(1), ierr)
+!
+ flag = .FALSE.
+ do while (.not. flag)
+ call MPI_Testany(1, requests(1), index, flag, &
+ & statuses(1,1), ierr)
+ end do
+!
+ call rq_check( requests, 1, 'issend and recv (testany)' )
+!
+ end if
+!
+ end
+!
+ subroutine test_pair_psend( comm, errs )
+ use mpi
+ 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
+!
+ if (verbose) then
+ print *, ' Persistent send and recv'
+ endif
+!
+ call mpi_comm_rank( comm, rank, ierr )
+ call mpi_comm_size( comm, size, ierr )
+ next = rank + 1
+ if (next .ge. size) next = 0
+!
+ prev = rank - 1
+ if (prev .lt. 0) prev = size - 1
+!
+ tag = 3123
+ count = TEST_SIZE / 5
+!
+ 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)
+!
+ if (rank .eq. 0) then
+!
+ call init_test_data(send_buf,TEST_SIZE)
+!
+ call MPI_Send_init(send_buf, count, MPI_REAL, next, tag, &
+ & comm, requests(1), ierr)
+!
+ call MPI_Startall(2, requests, ierr)
+ call MPI_Waitall(2, requests, statuses, ierr)
+!
+ call msg_check( recv_buf, next, tag, count, statuses(1,2), &
+ & TEST_SIZE, 'persistent send/recv', errs )
+!
+ call MPI_Request_free(requests(1), ierr)
+!
+ else if (prev .eq. 0) then
+!
+ 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)
+!
+ call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
+ & 'persistent send/recv', errs )
+!
+ do i = 1,count
+ send_buf(i) = recv_buf(i)
+ end do
+!
+ call MPI_Start(requests(1), ierr)
+ call MPI_Wait(requests(1), status, ierr)
+!
+ call MPI_Request_free(requests(1), ierr)
+ end if
+!
+ call dummyRef( send_buf, count, ierr )
+ call MPI_Request_free(requests(2), ierr)
+!
+ end
+!
+ subroutine test_pair_prsend( comm, errs )
+ use mpi
+ 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
+!
+ if (verbose) then
+ print *, ' Persistent Rsend and recv'
+ endif
+!
+ call mpi_comm_rank( comm, rank, ierr )
+ call mpi_comm_size( comm, size, ierr )
+ next = rank + 1
+ if (next .ge. size) next = 0
+!
+ prev = rank - 1
+ if (prev .lt. 0) prev = size - 1
+!
+ tag = 3456
+ count = TEST_SIZE / 3
+!
+ 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)
+!
+ if (rank .eq. 0) then
+!
+ call MPI_Rsend_init(send_buf, count, MPI_REAL, next, tag, &
+ & comm, requests(1), ierr)
+!
+ call init_test_data(send_buf,TEST_SIZE)
+!
+ call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag, &
+ & comm, status, ierr )
+!
+ call MPI_Startall(2, requests, ierr)
+!
+ index = -1
+!
+ 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
+!
+ call MPI_Request_free(requests(1), ierr)
+ else if (prev .eq. 0) then
+!
+ call MPI_Rsend_init(send_buf, count, MPI_REAL, prev, tag, &
+ & comm, requests(1), ierr)
+!
+ call MPI_Start(requests(2), ierr)
+!
+ call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, prev, tag, &
+ & comm, ierr )
+!
+ 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 )
+!
+ do i = 1,count
+ send_buf(i) = recv_buf(i)
+ end do
+!
+ call MPI_Start(requests(1), ierr)
+ call MPI_Wait(requests(1), status, ierr)
+!
+ call MPI_Request_free(requests(1), ierr)
+ end if
+!
+ call dummyRef( send_buf, count, ierr )
+ call MPI_Request_free(requests(2), ierr)
+!
+ end
+!
+ subroutine test_pair_pssend( comm, errs )
+ use mpi
+ 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
+!
+ if (verbose) then
+ print *, ' Persistent Ssend and recv'
+ endif
+!
+ call mpi_comm_rank( comm, rank, ierr )
+ call mpi_comm_size( comm, size, ierr )
+ next = rank + 1
+ if (next .ge. size) next = 0
+!
+ prev = rank - 1
+ if (prev .lt. 0) prev = size - 1
+!
+ tag = 3789
+ count = TEST_SIZE / 3
+!
+ 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(1), ierr)
+!
+ if (rank .eq. 0) then
+!
+ call MPI_Ssend_init(send_buf, count, MPI_REAL, next, tag, &
+ & comm, requests(2), ierr)
+!
+ call init_test_data(send_buf,TEST_SIZE)
+!
+ call MPI_Startall(2, requests, ierr)
+!
+ 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
+!
+ call MPI_Request_free(requests(2), ierr)
+!
+ else if (prev .eq. 0) then
+!
+ call MPI_Ssend_init(send_buf, count, MPI_REAL, prev, tag, &
+ & comm, requests(2), ierr)
+!
+ call MPI_Start(requests(1), ierr)
+!
+ 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
+!
+ call MPI_Start(requests(2), ierr)
+ call MPI_Wait(requests(2), status, ierr)
+!
+ call MPI_Request_free(requests(2), ierr)
+!
+ end if
+!
+ call dummyRef( send_buf, count, ierr )
+ call MPI_Request_free(requests(1), ierr)
+!
+ end
+!
+ subroutine test_pair_sendrecv( comm, errs )
+ use mpi
+ 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
+!
+ if (verbose) then
+ print *, ' Sendrecv'
+ endif
+!
+!
+ call mpi_comm_rank( comm, rank, ierr )
+ call mpi_comm_size( comm, size, ierr )
+ next = rank + 1
+ if (next .ge. size) next = 0
+!
+ prev = rank - 1
+ if (prev .lt. 0) prev = size - 1
+!
+ 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
+!
+ end
+!
+ subroutine test_pair_sendrecvrepl( comm, errs )
+ use mpi
+ 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
+!
+ if (verbose) then
+ print *, ' Sendrecv replace'
+ endif
+!
+ call mpi_comm_rank( comm, rank, ierr )
+ call mpi_comm_size( comm, size, ierr )
+ next = rank + 1
+ if (next .ge. size) next = 0
+!
+ prev = rank - 1
+ if (prev .lt. 0) prev = size - 1
+!
+ tag = 4456
+ count = TEST_SIZE / 3
+
+ if (rank .eq. 0) then
+!
+ call init_test_data(recv_buf, TEST_SIZE)
+!
+ do 11 i = count+1,TEST_SIZE
+ recv_buf(i) = 0.0
+ 11 continue
+!
+ 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
+!
+ end
+!
+!------------------------------------------------------------------------------
+!
+! Check for correct source, tag, count, and data in test message.
+!
+!------------------------------------------------------------------------------
+ subroutine msg_check( recv_buf, source, tag, count, status, n, &
+ & name, errs )
+ use mpi
+ 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
+!------------------------------------------------------------------------------
+!
+! Check that requests have been set to null
+!
+!------------------------------------------------------------------------------
+ subroutine rq_check( requests, n, msg )
+ use mpi
+ integer n, requests(n)
+ character*(*) msg
+ integer i
+!
+ do 10 i=1, n
+ if (requests(i) .ne. MPI_REQUEST_NULL) then
+ print *, 'Nonnull request in ', msg
+ endif
+ 10 continue
+!
+ end
+!------------------------------------------------------------------------------
+!
+! Initialize test data buffer with integral sequence.
+!
+!------------------------------------------------------------------------------
+ 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
+
+!------------------------------------------------------------------------------
+!
+! Clear test data buffer
+!
+!------------------------------------------------------------------------------
+ subroutine clear_test_data(buf, n)
+ integer n
+ real buf(n)
+ integer i
+
+ do 10 i = 1, n
+ buf(i) = 0.
+ 10 continue
+
+ end
+
+!------------------------------------------------------------------------------
+!
+! Verify test data buffer
+!
+!------------------------------------------------------------------------------
+ subroutine verify_test_data( buf, count, n, name, errs )
+ use mpi
+ integer n, errs
+ real buf(n)
+ character *(*) name
+ integer count, ierr, i
+!
+ 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
+!
+ 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
+!
+100 format('Invalid data', f6.1, ' at ', i4, ' of ', i4, ' in ', a)
+!
+ end
+!
+! This routine is used to prevent the compiler from deallocating the
+! array "a", which may happen in some of the tests (see the text in
+! the MPI standard about why this may be a problem in valid Fortran
+! codes). Without this, for example, tests fail with the Cray ftn
+! compiler.
+!
+ subroutine dummyRef( a, n, ie )
+ integer n, ie
+ real a(n)
+! 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
+! This file created from test/mpi/f77/pt2pt/dummyf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2010 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+!
+! This file is used to disable certain compiler optimizations that
+! can cause incorrect results with the test in greqf.f. It provides a
+! point where extrastate may be modified, limiting the compilers ability
+! to move code around.
+! The include of mpif.h is not needed in the F77 case but in the
+! F90 case it is, because in that case, extrastate is defined as an
+! integer (kind=MPI_ADDRESS_KIND), and the script that creates the
+! F90 tests from the F77 tests looks for mpif.h
+ subroutine dummyupdate( extrastate )
+ use mpi
+ integer (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val
+
+ end
--- /dev/null
+! This file created from test/mpi/f77/pt2pt/greqf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ subroutine query_fn( extrastate, status, ierr )
+ use mpi
+ integer status(MPI_STATUS_SIZE), ierr
+ integer (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val
+
+!
+! 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
+!
+ subroutine free_fn( extrastate, ierr )
+ use mpi
+ integer value, ierr
+ integer (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val
+
+ integer freefncall
+ common /fnccalls/ freefncall
+!
+! For testing purposes, the following print can be used to check whether
+! the free_fn is called
+! print *, 'Free_fn called'
+!
+ extrastate = extrastate - 1
+! The value returned by the free function is the error code
+! returned by the wait/test function
+ ierr = MPI_SUCCESS
+ end
+!
+ subroutine cancel_fn( extrastate, complete, ierr )
+ use mpi
+ integer ierr
+ logical complete
+ integer (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val
+
+
+ ierr = MPI_SUCCESS
+ end
+!
+!
+! This is a very simple test of generalized requests. Normally, the
+! MPI_Grequest_complete function would be called from another routine,
+! often running in a separate thread. This simple code allows us to
+! check that requests can be created, tested, and waited on in the
+! case where the request is complete before the wait is called.
+!
+! Note that MPI did *not* define a routine that can be called within
+! test or wait to advance the state of a generalized request.
+! Most uses of generalized requests will need to use a separate thread.
+!
+ program main
+ use mpi
+ integer errs, ierr
+ logical flag
+ integer status(MPI_STATUS_SIZE)
+ integer request
+ external query_fn, free_fn, cancel_fn
+ integer (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val
+
+ 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 )
+!
+! The following routine may prevent an optimizing compiler from
+! 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
+!
+ call MTest_Finalize( errs )
+ call mpi_finalize( ierr )
+ end
+!
--- /dev/null
+! This file created from test/mpi/f77/pt2pt/mprobef.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2012 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi
+ 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'
+! 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
+
+! 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
+! 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
+
+! 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
+! 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
+
+! 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
+! 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
+
+! 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
+! 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
+
+! Test 4: Mprobe+Mrecv with MPI_PROC_NULL
+ if (.true.) then
+ do idx = 1, MPI_STATUS_SIZE
+ s1(idx) = 0
+ s2(idx) = 0
+ enddo
+! 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)
+! 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
+
+! Test 5: Mprobe+Imrecv with MPI_PROC_NULL
+ if (.true.) then
+ do idx = 1, MPI_STATUS_SIZE
+ s1(idx) = 0
+ s2(idx) = 0
+ enddo
+! 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
+! 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
+
+! Test 6: Improbe+Mrecv with MPI_PROC_NULL
+ if (.true.) then
+ do idx = 1, MPI_STATUS_SIZE
+ s1(idx) = 0
+ s2(idx) = 0
+ enddo
+! 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)
+! 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
+
+! Test 7: Improbe+Imrecv with MPI_PROC_NULL
+ if (.true.) then
+ do idx = 1, MPI_STATUS_SIZE
+ s1(idx) = 0
+ s2(idx) = 0
+ enddo
+! 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
+! 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
+! This file created from test/mpi/f77/pt2pt/statusesf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+! Test support for MPI_STATUS_IGNORE and MPI_STATUSES_IGNORE
+ use mpi
+ 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
+# This file generated by f77tof90
+statusesf90 1
+#greqf90 1
+#allpairf90 2
+mprobef90 2 mpiversion=3.0
--- /dev/null
+#attr
+coll
+#comm
+#ext
+#info
+init
+#io
+#misc
+pt2pt
+datatype
+#f90types
+#
+#spawn
+#timer
+#topo
--- /dev/null
+! This file created from test/mpi/f77/util/mtestf.f with f77tof90
+! -*- Mode: Fortran; -*-
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ subroutine MTest_Init( ierr )
+! Place the include first so that we can automatically create a
+! Fortran 90 version that uses the mpi module instead. If
+! the module is in a different place, the compiler can complain
+! about out-of-order statements
+ use mpi
+ 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
+!
+ subroutine MTest_Finalize( errs )
+ use mpi
+ 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
+
+module array
+ integer, dimension(:), allocatable :: myindex
+end module
+
+!
+! A simple get intracomm for now
+ logical function MTestGetIntracomm( comm, min_size, qsmaller )
+ use array
+ use mpi
+
+ integer ierr
+ integer comm, min_size, size, rank
+ logical qsmaller
+
+ integer status
+ call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
+
+ if(.not. allocated(myindex)) then
+ allocate(myindex(size), STAT=status)
+ call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
+ myindex(rank+1)=0
+ endif
+
+ !data myindex /0/
+
+
+
+ if (myindex(rank+1) .eq. 0) then
+ comm = MPI_COMM_WORLD
+ else if (myindex(rank+1) .eq. 1) then
+ call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
+ else if (myindex(rank+1) .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(rank+1) .eq. 3) then
+ comm = MPI_COMM_SELF
+ endif
+ endif
+ myindex(rank+1) = mod( myindex(rank+1), 4 ) + 1
+ MTestGetIntracomm = comm .ne. MPI_COMM_NULL
+ end
+!
+ subroutine MTestFreeComm( comm )
+ use mpi
+ 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
+!
+ subroutine MTestPrintError( errcode )
+ use mpi
+ 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
+!
+ subroutine MTestPrintErrorMsg( msg, errcode )
+ use mpi
+ 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
