From: Augustin Degomme Date: Wed, 17 Jul 2013 14:18:03 +0000 (+0200) Subject: add fortran 90 tests X-Git-Tag: v3_9_90~128^2~61 X-Git-Url: http://info.iut-bm.univ-fcomte.fr/pub/gitweb/simgrid.git/commitdiff_plain/4137195804cd6cf88d6077d42a80cd6b41e09814 add fortran 90 tests --- diff --git a/buildtools/Cmake/AddTests.cmake b/buildtools/Cmake/AddTests.cmake index e38d36e5af..007ee47195 100644 --- a/buildtools/Cmake/AddTests.cmake +++ b/buildtools/Cmake/AddTests.cmake @@ -465,7 +465,8 @@ if(NOT enable_memcheck) 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() diff --git a/buildtools/Cmake/DefinePackages.cmake b/buildtools/Cmake/DefinePackages.cmake index a6b4b421d2..fef303030b 100644 --- a/buildtools/Cmake/DefinePackages.cmake +++ b/buildtools/Cmake/DefinePackages.cmake @@ -934,6 +934,10 @@ if(SMPI_F2C) 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() diff --git a/buildtools/Cmake/MakeExe.cmake b/buildtools/Cmake/MakeExe.cmake index fac59a6a1c..740f0b3704 100644 --- a/buildtools/Cmake/MakeExe.cmake +++ b/buildtools/Cmake/MakeExe.cmake @@ -99,6 +99,10 @@ add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/pt2pt) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/ext) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/datatype) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/init) +add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/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) diff --git a/teshsuite/smpi/mpich3-test/CMakeLists.txt b/teshsuite/smpi/mpich3-test/CMakeLists.txt index 82b588bc1c..645ace8aa1 100644 --- a/teshsuite/smpi/mpich3-test/CMakeLists.txt +++ b/teshsuite/smpi/mpich3-test/CMakeLists.txt @@ -41,6 +41,7 @@ set(txt_files ${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) diff --git a/teshsuite/smpi/mpich3-test/f90/coll/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f90/coll/CMakeLists.txt new file mode 100644 index 0000000000..a2d349c92b --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/coll/CMakeLists.txt @@ -0,0 +1,95 @@ +cmake_minimum_required(VERSION 2.6) + +if(enable_smpi) + if(WIN32) + set(CMAKE_C_FLAGS "-include ${CMAKE_HOME_DIRECTORY}/include/smpi/smpi_main.h") + else() + set(CMAKE_C_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpicc") + set(CMAKE_Fortran_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/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 + ) diff --git a/teshsuite/smpi/mpich3-test/f90/coll/allredint8f90.f90 b/teshsuite/smpi/mpich3-test/f90/coll/allredint8f90.f90 new file mode 100644 index 0000000000..d91ec1a5bb --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/coll/allredint8f90.f90 @@ -0,0 +1,23 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/coll/allredopttf90.f90 b/teshsuite/smpi/mpich3-test/f90/coll/allredopttf90.f90 new file mode 100644 index 0000000000..ffe1ffc729 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/coll/allredopttf90.f90 @@ -0,0 +1,46 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/coll/alltoallvf90.f90 b/teshsuite/smpi/mpich3-test/f90/coll/alltoallvf90.f90 new file mode 100644 index 0000000000..0c535e6223 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/coll/alltoallvf90.f90 @@ -0,0 +1,146 @@ +! 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 + diff --git a/teshsuite/smpi/mpich3-test/f90/coll/alltoallwf90.f90 b/teshsuite/smpi/mpich3-test/f90/coll/alltoallwf90.f90 new file mode 100644 index 0000000000..45456ba0ac --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/coll/alltoallwf90.f90 @@ -0,0 +1,67 @@ +! 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 + diff --git a/teshsuite/smpi/mpich3-test/f90/coll/exscanf90.f90 b/teshsuite/smpi/mpich3-test/f90/coll/exscanf90.f90 new file mode 100644 index 0000000000..1f1ec517e7 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/coll/exscanf90.f90 @@ -0,0 +1,108 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/coll/inplacef90.f90 b/teshsuite/smpi/mpich3-test/f90/coll/inplacef90.f90 new file mode 100644 index 0000000000..e9716cf86c --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/coll/inplacef90.f90 @@ -0,0 +1,91 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/coll/nonblocking_inpf90.f90 b/teshsuite/smpi/mpich3-test/f90/coll/nonblocking_inpf90.f90 new file mode 100644 index 0000000000..c9aed02a3c --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/coll/nonblocking_inpf90.f90 @@ -0,0 +1,124 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/coll/nonblockingf90.f90 b/teshsuite/smpi/mpich3-test/f90/coll/nonblockingf90.f90 new file mode 100644 index 0000000000..a07df71d8b --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/coll/nonblockingf90.f90 @@ -0,0 +1,98 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/coll/red_scat_blockf90.f90 b/teshsuite/smpi/mpich3-test/f90/coll/red_scat_blockf90.f90 new file mode 100644 index 0000000000..35a1546e3d --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/coll/red_scat_blockf90.f90 @@ -0,0 +1,56 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/coll/redscatf90.f90 b/teshsuite/smpi/mpich3-test/f90/coll/redscatf90.f90 new file mode 100644 index 0000000000..66339f216a --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/coll/redscatf90.f90 @@ -0,0 +1,88 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/coll/reducelocalf90.f90 b/teshsuite/smpi/mpich3-test/f90/coll/reducelocalf90.f90 new file mode 100644 index 0000000000..14229525b9 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/coll/reducelocalf90.f90 @@ -0,0 +1,96 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/coll/split_typef90.f90 b/teshsuite/smpi/mpich3-test/f90/coll/split_typef90.f90 new file mode 100644 index 0000000000..867fadfbd1 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/coll/split_typef90.f90 @@ -0,0 +1,46 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/coll/testlist b/teshsuite/smpi/mpich3-test/f90/coll/testlist new file mode 100644 index 0000000000..522e1a1887 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/coll/testlist @@ -0,0 +1,13 @@ +# 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 diff --git a/teshsuite/smpi/mpich3-test/f90/coll/uallreducef90.f90 b/teshsuite/smpi/mpich3-test/f90/coll/uallreducef90.f90 new file mode 100644 index 0000000000..023eec013b --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/coll/uallreducef90.f90 @@ -0,0 +1,67 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/coll/vw_inplacef90.f90 b/teshsuite/smpi/mpich3-test/f90/coll/vw_inplacef90.f90 new file mode 100644 index 0000000000..1ed0bf75f5 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/coll/vw_inplacef90.f90 @@ -0,0 +1,109 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f90/datatype/CMakeLists.txt new file mode 100644 index 0000000000..f03c073ac6 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/CMakeLists.txt @@ -0,0 +1,114 @@ +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 + ) diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/allctypesf90.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/allctypesf90.f90 new file mode 100644 index 0000000000..1e1841f33e --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/allctypesf90.f90 @@ -0,0 +1,139 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/createf90.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/createf90.f90 new file mode 100644 index 0000000000..b2edf87b6f --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/createf90.f90 @@ -0,0 +1,68 @@ +! +! (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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/gaddressf90.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/gaddressf90.f90 new file mode 100644 index 0000000000..b146f4f4b9 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/gaddressf90.f90 @@ -0,0 +1,39 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/get_elem_d.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/get_elem_d.f90 new file mode 100644 index 0000000000..00c112347f --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/get_elem_d.f90 @@ -0,0 +1,124 @@ +! -*- 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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/get_elem_u.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/get_elem_u.f90 new file mode 100644 index 0000000000..aa9f8feaaa --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/get_elem_u.f90 @@ -0,0 +1,72 @@ +! -*- 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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/hindex1f90.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/hindex1f90.f90 new file mode 100644 index 0000000000..7941ced3c5 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/hindex1f90.f90 @@ -0,0 +1,61 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/hindexed_blockf90.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/hindexed_blockf90.f90 new file mode 100644 index 0000000000..32a59e7ac4 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/hindexed_blockf90.f90 @@ -0,0 +1,179 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/indtype.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/indtype.f90 new file mode 100644 index 0000000000..79829e7a2f --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/indtype.f90 @@ -0,0 +1,117 @@ +! -*- 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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/kinds.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/kinds.f90 new file mode 100644 index 0000000000..3d42946571 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/kinds.f90 @@ -0,0 +1,115 @@ +! -*- 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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/packef90.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/packef90.f90 new file mode 100644 index 0000000000..801f1aafcf --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/packef90.f90 @@ -0,0 +1,188 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/sizeof.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/sizeof.f90 new file mode 100644 index 0000000000..7ace5f2c4f --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/sizeof.f90 @@ -0,0 +1,128 @@ +! -*- 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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/structf.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/structf.f90 new file mode 100644 index 0000000000..abc17daf16 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/structf.f90 @@ -0,0 +1,113 @@ +! +! (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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/testlist b/teshsuite/smpi/mpich3-test/f90/datatype/testlist new file mode 100644 index 0000000000..715c66a050 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/testlist @@ -0,0 +1,20 @@ +# 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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/trf90.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/trf90.f90 new file mode 100644 index 0000000000..946e4cdd46 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/trf90.f90 @@ -0,0 +1,25 @@ +! -*- 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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/typecntsf90.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/typecntsf90.f90 new file mode 100644 index 0000000000..cfe399371c --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/typecntsf90.f90 @@ -0,0 +1,91 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/typem2f90.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/typem2f90.f90 new file mode 100644 index 0000000000..c5eb8e535e --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/typem2f90.f90 @@ -0,0 +1,178 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/typename3f90.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/typename3f90.f90 new file mode 100644 index 0000000000..4e91774ec7 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/typename3f90.f90 @@ -0,0 +1,41 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/typenamef90.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/typenamef90.f90 new file mode 100644 index 0000000000..eda12ddf49 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/typenamef90.f90 @@ -0,0 +1,205 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/typesnamef90.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/typesnamef90.f90 new file mode 100644 index 0000000000..27f6a0335d --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/typesnamef90.f90 @@ -0,0 +1,67 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/typesubf90.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/typesubf90.f90 new file mode 100644 index 0000000000..aea04d9029 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/datatype/typesubf90.f90 @@ -0,0 +1,73 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/init/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f90/init/CMakeLists.txt new file mode 100644 index 0000000000..e4d1d8009c --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/init/CMakeLists.txt @@ -0,0 +1,42 @@ +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 + ) diff --git a/teshsuite/smpi/mpich3-test/f90/init/baseenvf90.f90 b/teshsuite/smpi/mpich3-test/f90/init/baseenvf90.f90 new file mode 100644 index 0000000000..a206c430fb --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/init/baseenvf90.f90 @@ -0,0 +1,90 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/init/testlist b/teshsuite/smpi/mpich3-test/f90/init/testlist new file mode 100644 index 0000000000..bee590b1e3 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/init/testlist @@ -0,0 +1,2 @@ +# This file generated by f77tof90 +baseenvf90 1 diff --git a/teshsuite/smpi/mpich3-test/f90/pt2pt/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f90/pt2pt/CMakeLists.txt new file mode 100644 index 0000000000..3766a83ca2 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/pt2pt/CMakeLists.txt @@ -0,0 +1,55 @@ +cmake_minimum_required(VERSION 2.6) + +if(enable_smpi) + if(WIN32) + set(CMAKE_C_FLAGS "-include ${CMAKE_HOME_DIRECTORY}/include/smpi/smpi_main.h") + else() + set(CMAKE_C_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpicc") + set(CMAKE_Fortran_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/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 + ) diff --git a/teshsuite/smpi/mpich3-test/f90/pt2pt/allpairf90.f90 b/teshsuite/smpi/mpich3-test/f90/pt2pt/allpairf90.f90 new file mode 100644 index 0000000000..a7726e9c37 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/pt2pt/allpairf90.f90 @@ -0,0 +1,1016 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/pt2pt/dummyf90.f90 b/teshsuite/smpi/mpich3-test/f90/pt2pt/dummyf90.f90 new file mode 100644 index 0000000000..957ed25d5f --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/pt2pt/dummyf90.f90 @@ -0,0 +1,20 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/pt2pt/greqf90.f90 b/teshsuite/smpi/mpich3-test/f90/pt2pt/greqf90.f90 new file mode 100644 index 0000000000..8844ce7294 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/pt2pt/greqf90.f90 @@ -0,0 +1,112 @@ +! 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 +! diff --git a/teshsuite/smpi/mpich3-test/f90/pt2pt/mprobef90.f90 b/teshsuite/smpi/mpich3-test/f90/pt2pt/mprobef90.f90 new file mode 100644 index 0000000000..0ba759b0a1 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/pt2pt/mprobef90.f90 @@ -0,0 +1,667 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/pt2pt/statusesf90.f90 b/teshsuite/smpi/mpich3-test/f90/pt2pt/statusesf90.f90 new file mode 100644 index 0000000000..940555464a --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/pt2pt/statusesf90.f90 @@ -0,0 +1,56 @@ +! 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 diff --git a/teshsuite/smpi/mpich3-test/f90/pt2pt/testlist b/teshsuite/smpi/mpich3-test/f90/pt2pt/testlist new file mode 100644 index 0000000000..b39a1a0462 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/pt2pt/testlist @@ -0,0 +1,5 @@ +# This file generated by f77tof90 +statusesf90 1 +#greqf90 1 +#allpairf90 2 +mprobef90 2 mpiversion=3.0 diff --git a/teshsuite/smpi/mpich3-test/f90/testlist b/teshsuite/smpi/mpich3-test/f90/testlist new file mode 100644 index 0000000000..bfe6f299d3 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/testlist @@ -0,0 +1,15 @@ +#attr +coll +#comm +#ext +#info +init +#io +#misc +pt2pt +datatype +#f90types +# +#spawn +#timer +#topo diff --git a/teshsuite/smpi/mpich3-test/f90/util/mtestf90.f90 b/teshsuite/smpi/mpich3-test/f90/util/mtestf90.f90 new file mode 100644 index 0000000000..ea6f4138d3 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/util/mtestf90.f90 @@ -0,0 +1,124 @@ +! 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