From: Augustin Degomme Date: Wed, 16 Jul 2014 12:46:37 +0000 (+0200) Subject: add F90 rma tests X-Git-Tag: v3_12~896^2~6 X-Git-Url: http://info.iut-bm.univ-fcomte.fr/pub/gitweb/simgrid.git/commitdiff_plain/68c6eb0af03e4284f8bb2f4a4f847c253e37ea16?ds=sidebyside add F90 rma tests --- diff --git a/buildtools/Cmake/DefinePackages.cmake b/buildtools/Cmake/DefinePackages.cmake index 6ed8362412..7baf324fad 100644 --- a/buildtools/Cmake/DefinePackages.cmake +++ b/buildtools/Cmake/DefinePackages.cmake @@ -1083,6 +1083,7 @@ set(TESHSUITE_CMAKEFILES_TXT teshsuite/smpi/mpich3-test/f90/init/CMakeLists.txt teshsuite/smpi/mpich3-test/f90/pt2pt/CMakeLists.txt teshsuite/smpi/mpich3-test/f90/util/CMakeLists.txt + teshsuite/smpi/mpich3-test/f90/rma/CMakeLists.txt teshsuite/smpi/mpich3-test/group/CMakeLists.txt teshsuite/smpi/mpich3-test/init/CMakeLists.txt teshsuite/smpi/mpich3-test/pt2pt/CMakeLists.txt diff --git a/buildtools/Cmake/MakeExe.cmake b/buildtools/Cmake/MakeExe.cmake index 24981f1653..99fbd2d6e2 100644 --- a/buildtools/Cmake/MakeExe.cmake +++ b/buildtools/Cmake/MakeExe.cmake @@ -149,6 +149,7 @@ add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/pt2pt) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/topo) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/rma) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f90/util) +add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f90/rma) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f90/coll) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f90/datatype) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f90/init) diff --git a/teshsuite/smpi/mpich3-test/f90/rma/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f90/rma/CMakeLists.txt new file mode 100644 index 0000000000..5fff8b39b7 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/rma/CMakeLists.txt @@ -0,0 +1,79 @@ +cmake_minimum_required(VERSION 2.6) + +if(enable_smpi AND enable_smpi_MPICH3_testsuite AND SMPI_FORTRAN) + 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}") + include_directories("${CMAKE_HOME_DIRECTORY}/include/smpi") + include_directories("${CMAKE_CURRENT_SOURCE_DIR}/../include/") + + add_executable(winaccf90 winaccf90.f90) +# add_executable(winerrf90 winerrf90.f90) + add_executable(winfencef90 winfencef90.f90) +# add_executable(wingroupf90 wingroupf90.f90) +# add_executable(baseattrwinf90 baseattrwinf90.f90) +# add_executable(winattr2f90 winattr2f90.f90) +# add_executable(winattrf90 winattrf90.f90) +# add_executable(c2f2cwinf90 c2f2cwinf90.f90 c2f2cwin.c) + add_executable(wingetf90 wingetf90.f90) +# add_executable(winnamef90 winnamef90.f90) +# add_executable(winscale1f90 winscale1f90.f90) +# add_executable(winscale2f90 winscale2f90.f90) + +target_link_libraries(winaccf90 simgrid mtest_f90) +#target_link_libraries(winerrf90 simgrid mtest_f90) +target_link_libraries(winfencef90 simgrid mtest_f90) +#target_link_libraries(wingroupf90 simgrid mtest_f90) +#target_link_libraries(baseattrwinf90 simgrid mtest_f90) +#target_link_libraries(c2f2cwinf90 simgrid mtest_f90) +#target_link_libraries(winattr2f90 simgrid mtest_f90) +#target_link_libraries(winattrf90 simgrid mtest_f90) +target_link_libraries(wingetf90 simgrid mtest_f90) +#target_link_libraries(winnamef90 simgrid mtest_f90) +#target_link_libraries(winscale1f90 simgrid mtest_f90) +#target_link_libraries(winscale2f90 simgrid mtest_f90) + + +endif() + +set(tesh_files + ${tesh_files} + PARENT_SCOPE + ) +set(xml_files + ${xml_files} + PARENT_SCOPE + ) +set(examples_src + ${examples_src} + ${CMAKE_CURRENT_SOURCE_DIR}/winaccf90.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/winerrf90.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/winfencef90.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/wingroupf90.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/baseattrwinf90.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/c2f2cwin.c + ${CMAKE_CURRENT_SOURCE_DIR}/c2f2cwinf90.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/testlist + ${CMAKE_CURRENT_SOURCE_DIR}/winattr2f90.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/winattrf90.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/wingetf90.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/winnamef90.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/winscale1f90.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/winscale2f90.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/addsize.h + 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/rma/baseattrwinf90.f90 b/teshsuite/smpi/mpich3-test/f90/rma/baseattrwinf90.f90 new file mode 100644 index 0000000000..957d8a2dc1 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/rma/baseattrwinf90.f90 @@ -0,0 +1,83 @@ +! This file created from test/mpi/f77/rma/baseattrwinf.f with f77tof90 +! -*- Mode: Fortran; -*- +! +! (C) 2003 by Argonne National Laboratory. +! See COPYRIGHT in top-level directory. +! + program main + use mpi + integer (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val + + logical flag + integer ierr, errs + integer base(1024) + integer disp + integer win + integer commsize +! Include addsize defines asize as an address-sized integer + integer (kind=MPI_ADDRESS_KIND) asize + + + errs = 0 + + call mtest_init( ierr ) + call mpi_comm_size( MPI_COMM_WORLD, commsize, ierr ) + +! Create a window; then extract the values + asize = 1024 + disp = 4 + call MPI_Win_create( base, asize, disp, MPI_INFO_NULL, & + & MPI_COMM_WORLD, win, ierr ) +! +! In order to check the base, we need an address-of function. +! We use MPI_Get_address, even though that isn't strictly correct + call MPI_Win_get_attr( win, MPI_WIN_BASE, valout, flag, ierr ) + if (.not. flag) then + errs = errs + 1 + print *, "Could not get WIN_BASE" +! +! There is no easy way to get the actual value of base to compare +! against. MPI_Address gives a value relative to MPI_BOTTOM, which +! is different from 0 in Fortran (unless you can define MPI_BOTTOM +! as something like %pointer(0)). +! else +! +!C For this Fortran 77 version, we use the older MPI_Address function +! call MPI_Address( base, baseadd, ierr ) +! if (valout .ne. baseadd) then +! errs = errs + 1 +! print *, "Got incorrect value for WIN_BASE (", valout, +! & ", should be ", baseadd, ")" +! endif + endif + + call MPI_Win_get_attr( win, MPI_WIN_SIZE, valout, flag, ierr ) + if (.not. flag) then + errs = errs + 1 + print *, "Could not get WIN_SIZE" + else + if (valout .ne. asize) then + errs = errs + 1 + print *, "Got incorrect value for WIN_SIZE (", valout, & + & ", should be ", asize, ")" + endif + endif + + call MPI_Win_get_attr( win, MPI_WIN_DISP_UNIT, valout, flag, ierr) + if (.not. flag) then + errs = errs + 1 + print *, "Could not get WIN_DISP_UNIT" + else + if (valout .ne. disp) then + errs = errs + 1 + print *, "Got wrong value for WIN_DISP_UNIT (", valout, & + & ", should be ", disp, ")" + endif + endif + + call MPI_Win_free( win, ierr ) + + call mtest_finalize( errs ) + call MPI_Finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f90/rma/c2f2cwinf90.f90 b/teshsuite/smpi/mpich3-test/f90/rma/c2f2cwinf90.f90 new file mode 100644 index 0000000000..62af7f5c11 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/rma/c2f2cwinf90.f90 @@ -0,0 +1,54 @@ +! This file created from test/mpi/f77/rma/c2f2cwinf.f with f77tof90 +! -*- Mode: Fortran; -*- +! +! (C) 2003 by Argonne National Laboratory. +! See COPYRIGHT in top-level directory. +! +! Test just MPI-RMA +! + program main + use mpi + integer errs, toterrs, ierr + integer wrank, wsize + integer wgroup, info, req, win + integer result + integer c2fwin +! The integer asize must be of ADDRESS_KIND size + integer (kind=MPI_ADDRESS_KIND) asize + + errs = 0 + + call mpi_init( ierr ) + +! +! Test passing a Fortran MPI object to C + call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr ) + asize = 0 + call mpi_win_create( 0, asize, 1, MPI_INFO_NULL, & + & MPI_COMM_WORLD, win, ierr ) + errs = errs + c2fwin( win ) + call mpi_win_free( win, ierr ) + +! +! Test using a C routine to provide the Fortran handle + call f2cwin( win ) +! no info, in comm world, created with no memory (base address 0, +! displacement unit 1 + call mpi_win_free( win, ierr ) + +! +! Summarize the errors +! + call mpi_allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, & + & MPI_COMM_WORLD, ierr ) + if (wrank .eq. 0) then + if (toterrs .eq. 0) then + print *, ' No Errors' + else + print *, ' Found ', toterrs, ' errors' + endif + endif + + call mpi_finalize( ierr ) + end + diff --git a/teshsuite/smpi/mpich3-test/f90/rma/c2f902cwin.c b/teshsuite/smpi/mpich3-test/f90/rma/c2f902cwin.c new file mode 100644 index 0000000000..ce35ccf8f7 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/rma/c2f902cwin.c @@ -0,0 +1,92 @@ +/* This file created from test/mpi/f77/rma/c2f2cwin.c with f77tof90 */ +/* -*- Mode: C; c-basic-offset:4 ; indent-tabs-mode:nil ; -*- */ +/* + * + * (C) 2001 by Argonne National Laboratory. + * See COPYRIGHT in top-level directory. + */ +/* + * This file contains the C routines used in testing the c2f and f2c + * handle conversion functions for MPI_Win + * + * The tests follow this pattern: + * + * Fortran main program + * calls c routine with each handle type, with a prepared + * and valid handle (often requires constructing an object) + * + * C routine uses xxx_f2c routine to get C handle, checks some + * properties (i.e., size and rank of communicator, contents of datatype) + * + * Then the Fortran main program calls a C routine that provides + * a handle, and the Fortran program performs similar checks. + * + * We also assume that a C int is a Fortran integer. If this is not the + * case, these tests must be modified. + */ + +/* style: allow:fprintf:1 sig:0 */ +#include +#include "mpi.h" +#include "../../include/mpitestconf.h" +#include + +/* + Name mapping. All routines are created with names that are lower case + with a single trailing underscore. This matches many compilers. + We use #define to change the name for Fortran compilers that do + not use the lowercase/underscore pattern +*/ + +#ifdef F77_NAME_UPPER +#define c2fwin_ C2FWIN +#define f2cwin_ F2CWIN + +#elif defined(F77_NAME_LOWER) || defined(F77_NAME_MIXED) +/* Mixed is ok because we use lowercase in all uses */ +#define c2fwin_ c2fwin +#define f2cwin_ f2cwin + +#elif defined(F77_NAME_LOWER_2USCORE) || defined(F77_NAME_LOWER_USCORE) || \ + defined(F77_NAME_MIXED_USCORE) +/* Else leave name alone (routines have no underscore, so both + of these map to a lowercase, single underscore) */ +#else +#error 'Unrecognized Fortran name mapping' +#endif + +/* Prototypes to keep compilers happy */ +int c2fwin_( int * ); +void f2cwin_( int * ); + +int c2fwin_( int *win ) +{ + MPI_Win cWin = MPI_Win_f2c( *win ); + MPI_Group group, wgroup; + int result; + + MPI_Win_get_group( cWin, &group ); + MPI_Comm_group( MPI_COMM_WORLD, &wgroup ); + + MPI_Group_compare( group, wgroup, &result ); + if (result != MPI_IDENT) { + fprintf( stderr, "Win: did not get expected group\n" ); + return 1; + } + + MPI_Group_free( &group ); + MPI_Group_free( &wgroup ); + + return 0; +} + +/* + * The following routines provide handles to the calling Fortran program + */ +void f2cwin_( int *win ) +{ + MPI_Win cWin; + MPI_Win_create( 0, 0, 1, MPI_INFO_NULL, MPI_COMM_WORLD, &cWin ); + *win = MPI_Win_c2f( cWin ); +} + diff --git a/teshsuite/smpi/mpich3-test/f90/rma/testlist b/teshsuite/smpi/mpich3-test/f90/rma/testlist new file mode 100644 index 0000000000..fce17ae129 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/rma/testlist @@ -0,0 +1,14 @@ +# This file generated by f77tof90 +#See ../../f77/rma/testlist for reasons of deactivation +#winscale1f90 4 +winfencef90 4 +wingetf90 5 +#winscale2f90 4 +#winerrf90 1 +#winnamef90 1 +#wingroupf90 4 +winaccf90 4 +#c2f2cwinf90 1 +#baseattrwinf90 1 +#winattrf90 1 +#winattr2f90 1 diff --git a/teshsuite/smpi/mpich3-test/f90/rma/winaccf90.f90 b/teshsuite/smpi/mpich3-test/f90/rma/winaccf90.f90 new file mode 100644 index 0000000000..f9b8bb7190 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/rma/winaccf90.f90 @@ -0,0 +1,95 @@ +! This file created from test/mpi/f77/rma/winaccf.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 win, intsize + integer left, right, rank, size + integer nrows, ncols + parameter (nrows=25,ncols=10) + integer buf(1:nrows,0:ncols+1) + integer comm, ans + integer i, j + logical mtestGetIntraComm +! Include addsize defines asize as an address-sized integer + integer (kind=MPI_ADDRESS_KIND) asize + + + errs = 0 + call mtest_init( ierr ) + + call mpi_type_size( MPI_INTEGER, intsize, ierr ) + do while( mtestGetIntraComm( comm, 2, .false. ) ) + asize = nrows * (ncols + 2) * intsize + call mpi_win_create( buf, asize, intsize * nrows, & + & MPI_INFO_NULL, comm, win, ierr ) + + call mpi_comm_size( comm, size, ierr ) + call mpi_comm_rank( comm, rank, ierr ) + left = rank - 1 + if (left .lt. 0) then + left = MPI_PROC_NULL + endif + right = rank + 1 + if (right .ge. size) then + right = MPI_PROC_NULL + endif +! +! Initialize the buffer + do i=1,nrows + buf(i,0) = -1 + buf(i,ncols+1) = -1 + enddo + do j=1,ncols + do i=1,nrows + buf(i,j) = rank * (ncols * nrows) + i + (j-1) * nrows + enddo + enddo + call mpi_win_fence( MPI_MODE_NOPRECEDE, win, ierr ) +! + asize = ncols + 1 + call mpi_accumulate( buf(1,1), nrows, MPI_INTEGER, & + & left, asize, & + & nrows, MPI_INTEGER, MPI_SUM, win, ierr ) + asize = 0 + call mpi_accumulate( buf(1,ncols), nrows, MPI_INTEGER, right, & + & asize, nrows, MPI_INTEGER, MPI_SUM, win, ierr ) +! + call mpi_win_fence( MPI_MODE_NOSTORE + MPI_MODE_NOPUT + & + & MPI_MODE_NOSUCCEED, win, ierr ) +! +! Check the results + if (left .ne. MPI_PROC_NULL) then + do i=1, nrows + ans = rank * (ncols * nrows) - nrows + i - 1 + if (buf(i,0) .ne. ans) then + errs = errs + 1 + if (errs .le. 10) then + print *, ' buf(',i,',0) = ', buf(i,0) + endif + endif + enddo + endif + if (right .ne. MPI_PROC_NULL) then + do i=1, nrows + ans = (rank + 1) * (ncols * nrows) + i - 1 + if (buf(i,ncols+1) .ne. ans) then + errs = errs + 1 + if (errs .le. 10) then + print *, ' buf(',i,',',ncols+1,') = ', & + & buf(i,ncols+1) + endif + endif + enddo + endif + call mpi_win_free( win, ierr ) + call mtestFreeComm( comm ) + enddo + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f90/rma/winattr2f90.f90 b/teshsuite/smpi/mpich3-test/f90/rma/winattr2f90.f90 new file mode 100644 index 0000000000..a898f6cec3 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/rma/winattr2f90.f90 @@ -0,0 +1,87 @@ +! This file created from test/mpi/f77/rma/winattr2f.f with f77tof90 +! -*- Mode: Fortran; -*- +! +! (C) 2003 by Argonne National Laboratory. +! See COPYRIGHT in top-level directory. +! This is a modified version of winattrf.f that uses two of the +! default functions +! + program main + use mpi + integer errs, ierr + integer (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val + + integer comm, win, buf(10) + integer keyval + logical flag +! +! The only difference between the MPI-2 and MPI-1 attribute caching +! routines in Fortran is that the take an address-sized integer +! instead of a simple integer. These still are not pointers, +! so the values are still just integers. +! + errs = 0 + call mtest_init( ierr ) + call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr ) +! Create a new window; use val for an address-sized int + val = 10 + call mpi_win_create( buf, val, 1, & + & MPI_INFO_NULL, comm, win, ierr ) +! + extrastate = 1001 + call mpi_win_create_keyval( MPI_WIN_DUP_FN, & + & MPI_WIN_NULL_DELETE_FN, keyval, & + & extrastate, ierr ) + flag = .true. + call mpi_win_get_attr( win, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' get attr returned true when no attr set' + endif + + valin = 2003 + call mpi_win_set_attr( win, keyval, valin, ierr ) + flag = .false. + valout = -1 + call mpi_win_get_attr( win, keyval, valout, flag, ierr ) + if (valout .ne. 2003) then + errs = errs + 1 + print *, 'Unexpected value (should be 2003)', valout, & + & ' from attr' + endif + + valin = 2001 + call mpi_win_set_attr( win, keyval, valin, ierr ) + flag = .false. + valout = -1 + call mpi_win_get_attr( win, keyval, valout, flag, ierr ) + if (valout .ne. 2001) then + errs = errs + 1 + print *, 'Unexpected value (should be 2001)', valout, & + & ' from attr' + endif +! +! Test the attr delete function + call mpi_win_delete_attr( win, keyval, ierr ) + flag = .true. + call mpi_win_get_attr( win, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' Delete_attr did not delete attribute' + endif + +! Test the delete function on window free + valin = 2001 + call mpi_win_set_attr( win, keyval, valin, ierr ) + call mpi_win_free( win, ierr ) + call mpi_comm_free( comm, ierr ) + ierr = -1 + call mpi_win_free_keyval( keyval, ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + call mtestprinterror( ierr ) + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f90/rma/winattrf90.f90 b/teshsuite/smpi/mpich3-test/f90/rma/winattrf90.f90 new file mode 100644 index 0000000000..b8fef14e58 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/rma/winattrf90.f90 @@ -0,0 +1,181 @@ +! This file created from test/mpi/f77/rma/winattrf.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 (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val + + integer comm, win, buf(10) + integer curcount, keyval + logical flag + external mycopyfn, mydelfn + integer callcount, delcount + common /myattr/ callcount, delcount +! +! The only difference between the MPI-2 and MPI-1 attribute caching +! routines in Fortran is that the take an address-sized integer +! instead of a simple integer. These still are not pointers, +! so the values are still just integers. +! + errs = 0 + callcount = 0 + delcount = 0 + call mtest_init( ierr ) + call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr ) +! Create a new window; use val for an address-sized int + val = 10 + call mpi_win_create( buf, val, 1, & + & MPI_INFO_NULL, comm, win, ierr ) +! + extrastate = 1001 + call mpi_win_create_keyval( mycopyfn, mydelfn, keyval, & + & extrastate, ierr ) + flag = .true. + call mpi_win_get_attr( win, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' get attr returned true when no attr set' + endif + + valin = 2003 + call mpi_win_set_attr( win, keyval, valin, ierr ) + flag = .false. + valout = -1 + call mpi_win_get_attr( win, keyval, valout, flag, ierr ) + if (valout .ne. 2003) then + errs = errs + 1 + print *, 'Unexpected value (should be 2003)', valout, & + & ' from attr' + endif + + valin = 2001 + call mpi_win_set_attr( win, keyval, valin, ierr ) + flag = .false. + valout = -1 + call mpi_win_get_attr( win, keyval, valout, flag, ierr ) + if (valout .ne. 2001) then + errs = errs + 1 + print *, 'Unexpected value (should be 2001)', valout, & + & ' from attr' + endif +! +! Test the attr delete function + delcount = 0 + call mpi_win_delete_attr( win, keyval, ierr ) + if (delcount .ne. 1) then + errs = errs + 1 + print *, ' Delete_attr did not call delete function' + endif + flag = .true. + call mpi_win_get_attr( win, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' Delete_attr did not delete attribute' + endif + +! Test the delete function on window free + valin = 2001 + call mpi_win_set_attr( win, keyval, valin, ierr ) + curcount = delcount + call mpi_win_free( win, ierr ) + if (delcount .ne. curcount + 1) then + errs = errs + 1 + print *, ' did not get expected value of delcount ', & + & delcount, curcount + 1 + endif + + ierr = -1 + call mpi_win_free_keyval( keyval, ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + call mtestprinterror( ierr ) + endif +! +! The MPI standard defines null copy and duplicate functions. +! However, are only used when an object is duplicated. Since +! MPI_Win objects cannot be duplicated, so under normal circumstances, +! these will not be called. Since they are defined, they should behave +! as defined. To test them, we simply call them here + flag = .false. + valin = 7001 + valout = -1 + ierr = -1 + call MPI_WIN_DUP_FN( win, keyval, extrastate, valin, valout, & + & flag, ierr ) + if (.not. flag) then + errs = errs + 1 + print *, " Flag was false after MPI_WIN_DUP_FN" + else if (valout .ne. 7001) then + errs = errs + 1 + if (valout .eq. -1 ) then + print *, " output attr value was not copied in MPI_WIN_DUP_FN" + endif + print *, " value was ", valout, " but expected 7001" + else if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + print *, " MPI_WIN_DUP_FN did not return MPI_SUCCESS" + endif + + flag = .true. + valin = 7001 + valout = -1 + ierr = -1 + call MPI_WIN_NULL_COPY_FN( win, keyval, extrastate, valin, valout & + & ,flag, ierr ) + if (flag) then + errs = errs + 1 + print *, " Flag was true after MPI_WIN_NULL_COPY_FN" + else if (valout .ne. -1) then + errs = errs + 1 + print *, & + & " output attr value was copied in MPI_WIN_NULL_COPY_FN" + else if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + print *, " MPI_WIN_NULL_COPY_FN did not return MPI_SUCCESS" + endif +! + call mpi_comm_free( comm, ierr ) + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end +! +! Note that the copyfn is unused for MPI windows, since there is +! (and because of alias rules, can be) no MPI_Win_dup function + subroutine mycopyfn( oldwin, keyval, extrastate, valin, valout, & + & flag, ierr ) + use mpi + integer oldwin, keyval, ierr + integer (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val + + logical flag + integer callcount, delcount + common /myattr/ callcount, delcount +! increment the attribute by 2 + valout = valin + 2 + callcount = callcount + 1 +! +! Since we should *never* call this, indicate an error + print *, ' Unexpected use of mycopyfn' + flag = .false. + ierr = MPI_ERR_OTHER + end +! + subroutine mydelfn( win, keyval, val, extrastate, ierr ) + use mpi + integer win, keyval, ierr + integer (kind=MPI_ADDRESS_KIND) extrastate, valin, valout, val + + integer callcount, delcount + common /myattr/ callcount, delcount + delcount = delcount + 1 + if (extrastate .eq. 1001) then + ierr = MPI_SUCCESS + else + print *, ' Unexpected value of extrastate = ', extrastate + ierr = MPI_ERR_OTHER + endif + end diff --git a/teshsuite/smpi/mpich3-test/f90/rma/winerrf90.f90 b/teshsuite/smpi/mpich3-test/f90/rma/winerrf90.f90 new file mode 100644 index 0000000000..d21060118b --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/rma/winerrf90.f90 @@ -0,0 +1,140 @@ +! This file created from test/mpi/f77/rma/winerrf.f with f77tof90 +! -*- Mode: Fortran; -*- +! +! (C) 2003 by Argonne National Laboratory. +! See COPYRIGHT in top-level directory. +! + program main + use mpi + integer errs, ierr, code(2), newerrclass, eclass + character*(MPI_MAX_ERROR_STRING) errstring + integer comm, rlen, intsize + integer buf(10) + integer win +! external myerrhanfunc + INTERFACE + SUBROUTINE myerrhanfunc(vv0,vv1) + INTEGER vv0,vv1 + END SUBROUTINE + END INTERFACE + integer myerrhan, qerr + integer (kind=MPI_ADDRESS_KIND) asize + + integer callcount, codesSeen(3) + common /myerrhan/ callcount, codesSeen + + errs = 0 + callcount = 0 + call mtest_init( ierr ) +! +! Setup some new codes and classes + call mpi_add_error_class( newerrclass, ierr ) + call mpi_add_error_code( newerrclass, code(1), ierr ) + call mpi_add_error_code( newerrclass, code(2), ierr ) + call mpi_add_error_string( newerrclass, "New Class", ierr ) + call mpi_add_error_string( code(1), "First new code", ierr ) + call mpi_add_error_string( code(2), "Second new code", ierr ) +! + call mpi_win_create_errhandler( myerrhanfunc, myerrhan, ierr ) +! +! Create a new communicator so that we can leave the default errors-abort +! on MPI_COMM_WORLD. Use this comm for win_create, just to leave a little +! more separation from comm_world +! + call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr ) + call mpi_type_size( MPI_INTEGER, intsize, ierr ) + asize = 10 * intsize + call mpi_win_create( buf, asize, intsize, MPI_INFO_NULL, & + & comm, win, ierr ) +! + call mpi_win_set_errhandler( win, myerrhan, ierr ) + + call mpi_win_get_errhandler( win, qerr, ierr ) + if (qerr .ne. myerrhan) then + errs = errs + 1 + print *, ' Did not get expected error handler' + endif + call mpi_errhandler_free( qerr, ierr ) +! We can free our error handler now + call mpi_errhandler_free( myerrhan, ierr ) + + call mpi_win_call_errhandler( win, newerrclass, ierr ) + call mpi_win_call_errhandler( win, code(1), ierr ) + call mpi_win_call_errhandler( win, code(2), ierr ) + + if (callcount .ne. 3) then + errs = errs + 1 + print *, ' Expected 3 calls to error handler, found ', & + & callcount + else + if (codesSeen(1) .ne. newerrclass) then + errs = errs + 1 + print *, 'Expected class ', newerrclass, ' got ', & + & codesSeen(1) + endif + if (codesSeen(2) .ne. code(1)) then + errs = errs + 1 + print *, 'Expected code ', code(1), ' got ', & + & codesSeen(2) + endif + if (codesSeen(3) .ne. code(2)) then + errs = errs + 1 + print *, 'Expected code ', code(2), ' got ', & + & codesSeen(3) + endif + endif + + call mpi_win_free( win, ierr ) + call mpi_comm_free( comm, ierr ) +! +! Check error strings while here here... + call mpi_error_string( newerrclass, errstring, rlen, ierr ) + if (errstring(1:rlen) .ne. "New Class") then + errs = errs + 1 + print *, ' Wrong string for error class: ', errstring(1:rlen) + endif + call mpi_error_class( code(1), eclass, ierr ) + if (eclass .ne. newerrclass) then + errs = errs + 1 + print *, ' Class for new code is not correct' + endif + call mpi_error_string( code(1), errstring, rlen, ierr ) + if (errstring(1:rlen) .ne. "First new code") then + errs = errs + 1 + print *, ' Wrong string for error code: ', errstring(1:rlen) + endif + call mpi_error_class( code(2), eclass, ierr ) + if (eclass .ne. newerrclass) then + errs = errs + 1 + print *, ' Class for new code is not correct' + endif + call mpi_error_string( code(2), errstring, rlen, ierr ) + if (errstring(1:rlen) .ne. "Second new code") then + errs = errs + 1 + print *, ' Wrong string for error code: ', errstring(1:rlen) + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end +! + subroutine myerrhanfunc( win, errcode ) + use mpi + integer win, errcode + integer rlen, ierr + integer callcount, codesSeen(3) + character*(MPI_MAX_ERROR_STRING) errstring + common /myerrhan/ callcount, codesSeen + + callcount = callcount + 1 +! Remember the code we've seen + if (callcount .le. 3) then + codesSeen(callcount) = errcode + endif + call mpi_error_string( errcode, errstring, rlen, ierr ) + if (ierr .ne. MPI_SUCCESS) then + print *, ' Panic! could not get error string' + call mpi_abort( MPI_COMM_WORLD, 1, ierr ) + endif + end diff --git a/teshsuite/smpi/mpich3-test/f90/rma/winfencef90.f90 b/teshsuite/smpi/mpich3-test/f90/rma/winfencef90.f90 new file mode 100644 index 0000000000..d124423940 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/rma/winfencef90.f90 @@ -0,0 +1,95 @@ +! This file created from test/mpi/f77/rma/winfencef.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 win, intsize + integer left, right, rank, size + integer nrows, ncols + parameter (nrows=25,ncols=10) + integer buf(1:nrows,0:ncols+1) + integer comm, ans + integer i, j + logical mtestGetIntraComm +! Include addsize defines asize as an address-sized integer + integer (kind=MPI_ADDRESS_KIND) asize + + + errs = 0 + call mtest_init( ierr ) + + call mpi_type_size( MPI_INTEGER, intsize, ierr ) + do while( mtestGetIntraComm( comm, 2, .false. ) ) + asize = nrows * (ncols + 2) * intsize + call mpi_win_create( buf, asize, intsize * nrows, & + & MPI_INFO_NULL, comm, win, ierr ) + + call mpi_comm_size( comm, size, ierr ) + call mpi_comm_rank( comm, rank, ierr ) + left = rank - 1 + if (left .lt. 0) then + left = MPI_PROC_NULL + endif + right = rank + 1 + if (right .ge. size) then + right = MPI_PROC_NULL + endif +! +! Initialize the buffer + do i=1,nrows + buf(i,0) = -1 + buf(i,ncols+1) = -1 + enddo + do j=1,ncols + do i=1,nrows + buf(i,j) = rank * (ncols * nrows) + i + (j-1) * nrows + enddo + enddo + call mpi_win_fence( MPI_MODE_NOPRECEDE, win, ierr ) +! + asize = ncols+1 + call mpi_put( buf(1,1), nrows, MPI_INTEGER, left, asize, & + & nrows, MPI_INTEGER, win, ierr ) + asize = 0 + call mpi_put( buf(1,ncols), nrows, MPI_INTEGER, right, asize, & + & nrows, MPI_INTEGER, win, ierr ) +! + call mpi_win_fence( MPI_MODE_NOSTORE + MPI_MODE_NOPUT + & + & MPI_MODE_NOSUCCEED, win, ierr ) +! +! Check the results + if (left .ne. MPI_PROC_NULL) then + do i=1, nrows + ans = rank * (ncols * nrows) - nrows + i + if (buf(i,0) .ne. ans) then + errs = errs + 1 + if (errs .le. 10) then + print *, rank, ' buf(',i,',0) = ', buf(i,0), & + & ' expected', ans + endif + endif + enddo + endif + if (right .ne. MPI_PROC_NULL) then + do i=1, nrows + ans = (rank + 1)* (ncols * nrows) + i + if (buf(i,ncols+1) .ne. ans) then + errs = errs + 1 + if (errs .le. 10) then + print *, rank, ' buf(',i,',',ncols+1,') = ', & + & buf(i,ncols+1), ' expected ', ans + endif + endif + enddo + endif + call mpi_win_free( win, ierr ) + call mtestFreeComm( comm ) + enddo + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f90/rma/wingetf90.f90 b/teshsuite/smpi/mpich3-test/f90/rma/wingetf90.f90 new file mode 100644 index 0000000000..648348ed3a --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/rma/wingetf90.f90 @@ -0,0 +1,95 @@ +! This file created from test/mpi/f77/rma/wingetf.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 win, intsize + integer left, right, rank, size + integer nrows, ncols + parameter (nrows=25,ncols=10) + integer buf(1:nrows,0:ncols+1) + integer comm, ans + integer i, j + logical mtestGetIntraComm +! Include addsize defines asize as an address-sized integer + integer (kind=MPI_ADDRESS_KIND) asize + + + errs = 0 + call mtest_init( ierr ) + + call mpi_type_size( MPI_INTEGER, intsize, ierr ) + do while( mtestGetIntraComm( comm, 2, .false. ) ) + asize = nrows * (ncols + 2) * intsize + call mpi_win_create( buf, asize, intsize * nrows, & + & MPI_INFO_NULL, comm, win, ierr ) + + call mpi_comm_size( comm, size, ierr ) + call mpi_comm_rank( comm, rank, ierr ) + left = rank - 1 + if (left .lt. 0) then + left = MPI_PROC_NULL + endif + right = rank + 1 + if (right .ge. size) then + right = MPI_PROC_NULL + endif +! +! Initialize the buffer + do i=1,nrows + buf(i,0) = -1 + buf(i,ncols+1) = -1 + enddo + do j=1,ncols + do i=1,nrows + buf(i,j) = rank * (ncols * nrows) + i + (j-1) * nrows + enddo + enddo + call mpi_win_fence( MPI_MODE_NOPRECEDE, win, ierr ) +! + asize = 1 + call mpi_get( buf(1,ncols+1), nrows, MPI_INTEGER, right, & + & asize, nrows, MPI_INTEGER, win, ierr ) + asize = ncols + call mpi_get( buf(1,0), nrows, MPI_INTEGER, left, & + & asize, nrows, MPI_INTEGER, win, ierr ) +! + call mpi_win_fence( MPI_MODE_NOSTORE + MPI_MODE_NOPUT + & + & MPI_MODE_NOSUCCEED, win, ierr ) +! +! Check the results + if (left .ne. MPI_PROC_NULL) then + do i=1, nrows + ans = rank * (ncols * nrows) - nrows + i + if (buf(i,0) .ne. ans) then + errs = errs + 1 + if (errs .le. 10) then + print *, rank, ' buf(',i,',0) = ', buf(i,0), & + & ' expected', ans + endif + endif + enddo + endif + if (right .ne. MPI_PROC_NULL) then + do i=1, nrows + ans = (rank + 1)* (ncols * nrows) + i + if (buf(i,ncols+1) .ne. ans) then + errs = errs + 1 + if (errs .le. 10) then + print *, rank, ' buf(',i,',',ncols+1,') = ', & + & buf(i,ncols+1), ' expected ', ans + endif + endif + enddo + endif + call mpi_win_free( win, ierr ) + call mtestFreeComm( comm ) + enddo + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f90/rma/wingroupf90.f90 b/teshsuite/smpi/mpich3-test/f90/rma/wingroupf90.f90 new file mode 100644 index 0000000000..a936c8c38e --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/rma/wingroupf90.f90 @@ -0,0 +1,42 @@ +! This file created from test/mpi/f77/rma/wingroupf.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 buf(10) + integer comm, group1, group2, result, win, intsize + logical mtestGetIntraComm + integer (kind=MPI_ADDRESS_KIND) asize + + + errs = 0 + call mtest_init( ierr ) + + call mpi_type_size( MPI_INTEGER, intsize, ierr ) + do while( mtestGetIntraComm( comm, 2, .false. ) ) + asize = 10 + call mpi_win_create( buf, asize, intsize, & + & MPI_INFO_NULL, comm, win, ierr ) + + call mpi_comm_group( comm, group1, ierr ) + call mpi_win_get_group( win, group2, ierr ) + call mpi_group_compare( group1, group2, result, ierr ) + if (result .ne. MPI_IDENT) then + errs = errs + 1 + print *, ' Did not get the ident groups' + endif + call mpi_group_free( group1, ierr ) + call mpi_group_free( group2, ierr ) + + call mpi_win_free( win, ierr ) + call mtestFreeComm( comm ) + enddo +! + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f90/rma/winnamef90.f90 b/teshsuite/smpi/mpich3-test/f90/rma/winnamef90.f90 new file mode 100644 index 0000000000..00f790b9ea --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/rma/winnamef90.f90 @@ -0,0 +1,79 @@ +! This file created from test/mpi/f77/rma/winnamef.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 win, rlen, ln + character*(MPI_MAX_OBJECT_NAME) cname + integer buf(10) + integer intsize +! Include addsize defines asize as an address-sized integer + integer (kind=MPI_ADDRESS_KIND) asize + + logical found +! + errs = 0 + call mtest_init( ierr ) +! +! Create a window and get, set the names on it +! + call mpi_type_size( MPI_INTEGER, intsize, ierr ) + asize = 10 + call mpi_win_create( buf, asize, intsize, & + & MPI_INFO_NULL, MPI_COMM_WORLD, win, ierr ) +! +! Check that there is no name yet + cname = 'XXXXXX' + rlen = -1 + call mpi_win_get_name( win, cname, rlen, ierr ) + if (rlen .ne. 0) then + errs = errs + 1 + print *, ' Did not get empty name from new window' + else if (cname(1:6) .ne. 'XXXXXX') then + found = .false. + do ln=MPI_MAX_OBJECT_NAME,1,-1 + if (cname(ln:ln) .ne. ' ') then + found = .true. + endif + enddo + if (found) then + errs = errs + 1 + print *, ' Found a non-empty name' + endif + endif +! +! Now, set a name and check it + call mpi_win_set_name( win, 'MyName', ierr ) + cname = 'XXXXXX' + rlen = -1 + call mpi_win_get_name( win, cname, rlen, ierr ) + if (rlen .ne. 6) then + errs = errs + 1 + print *, ' Expected 6, got ', rlen, ' for rlen' + if (rlen .gt. 0 .and. rlen .lt. MPI_MAX_OBJECT_NAME) then + print *, ' Cname = ', cname(1:rlen) + endif + else if (cname(1:6) .ne. 'MyName') then + errs = errs + 1 + print *, ' Expected MyName, got ', cname(1:6) + else + found = .false. + do ln=MPI_MAX_OBJECT_NAME,7,-1 + if (cname(ln:ln) .ne. ' ') then + found = .true. + endif + enddo + if (found) then + errs = errs + 1 + print *, ' window name is not blank padded' + endif + endif +! + call mpi_win_free( win, ierr ) + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f90/rma/winscale1f90.f90 b/teshsuite/smpi/mpich3-test/f90/rma/winscale1f90.f90 new file mode 100644 index 0000000000..fcf0e021c9 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/rma/winscale1f90.f90 @@ -0,0 +1,107 @@ +! This file created from test/mpi/f77/rma/winscale1f.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 win, intsize + integer left, right, rank, size + integer nrows, ncols + parameter (nrows=25,ncols=10) + integer buf(1:nrows,0:ncols+1) + integer comm, group, group2, ans + integer nneighbors, nbrs(2), i, j + logical mtestGetIntraComm +! Include addsize defines asize as an address-sized integer + integer (kind=MPI_ADDRESS_KIND) asize + + + errs = 0 + call mtest_init( ierr ) + + call mpi_type_size( MPI_INTEGER, intsize, ierr ) + do while( mtestGetIntraComm( comm, 2, .false. ) ) + asize = nrows * (ncols + 2) * intsize + call mpi_win_create( buf, asize, intsize * nrows, & + & MPI_INFO_NULL, comm, win, ierr ) + +! Create the group for the neighbors + call mpi_comm_size( comm, size, ierr ) + call mpi_comm_rank( comm, rank, ierr ) + nneighbors = 0 + left = rank - 1 + if (left .lt. 0) then + left = MPI_PROC_NULL + else + nneighbors = nneighbors + 1 + nbrs(nneighbors) = left + endif + right = rank + 1 + if (right .ge. size) then + right = MPI_PROC_NULL + else + nneighbors = nneighbors + 1 + nbrs(nneighbors) = right + endif + call mpi_comm_group( comm, group, ierr ) + call mpi_group_incl( group, nneighbors, nbrs, group2, ierr ) + call mpi_group_free( group, ierr ) +! +! Initialize the buffer + do i=1,nrows + buf(i,0) = -1 + buf(i,ncols+1) = -1 + enddo + do j=1,ncols + do i=1,nrows + buf(i,j) = rank * (ncols * nrows) + i + (j-1) * nrows + enddo + enddo + call mpi_win_post( group2, 0, win, ierr ) + call mpi_win_start( group2, 0, win, ierr ) +! + asize = ncols+1 + call mpi_put( buf(1,1), nrows, MPI_INTEGER, left, asize, & + & nrows, MPI_INTEGER, win, ierr ) + asize = 0 + call mpi_put( buf(1,ncols), nrows, MPI_INTEGER, right, asize, & + & nrows, MPI_INTEGER, win, ierr ) +! + call mpi_win_complete( win, ierr ) + call mpi_win_wait( win, ierr ) +! +! Check the results + if (left .ne. MPI_PROC_NULL) then + do i=1, nrows + ans = rank * (ncols * nrows) - nrows + i + if (buf(i,0) .ne. ans) then + errs = errs + 1 + if (errs .le. 10) then + print *, ' buf(',i,'0) = ', buf(i,0) + endif + endif + enddo + endif + if (right .ne. MPI_PROC_NULL) then + do i=1, nrows + ans = (rank+1) * (ncols * nrows) + i + if (buf(i,ncols+1) .ne. ans) then + errs = errs + 1 + if (errs .le. 10) then + print *, ' buf(',i,',',ncols+1,') = ', & + & buf(i,ncols+1) + endif + endif + enddo + endif + call mpi_group_free( group2, ierr ) + call mpi_win_free( win, ierr ) + call mtestFreeComm( comm ) + enddo + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f90/rma/winscale2f90.f90 b/teshsuite/smpi/mpich3-test/f90/rma/winscale2f90.f90 new file mode 100644 index 0000000000..b9c7812082 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f90/rma/winscale2f90.f90 @@ -0,0 +1,112 @@ +! This file created from test/mpi/f77/rma/winscale2f.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 win, intsize + integer left, right, rank, size + integer nrows, ncols + parameter (nrows=25,ncols=10) + integer buf(1:nrows,0:ncols+1) + integer comm, group, group2, ans + integer nneighbors, nbrs(2), i, j + logical mtestGetIntraComm + logical flag +! Include addsize defines asize as an address-sized integer + integer (kind=MPI_ADDRESS_KIND) asize + + + errs = 0 + call mtest_init( ierr ) + + call mpi_type_size( MPI_INTEGER, intsize, ierr ) + do while( mtestGetIntraComm( comm, 2, .false. ) ) + asize = nrows * (ncols + 2) * intsize + call mpi_win_create( buf, asize, intsize * nrows, & + & MPI_INFO_NULL, comm, win, ierr ) + +! Create the group for the neighbors + call mpi_comm_size( comm, size, ierr ) + call mpi_comm_rank( comm, rank, ierr ) + nneighbors = 0 + left = rank - 1 + if (left .lt. 0) then + left = MPI_PROC_NULL + else + nneighbors = nneighbors + 1 + nbrs(nneighbors) = left + endif + right = rank + 1 + if (right .ge. size) then + right = MPI_PROC_NULL + else + nneighbors = nneighbors + 1 + nbrs(nneighbors) = right + endif + call mpi_comm_group( comm, group, ierr ) + call mpi_group_incl( group, nneighbors, nbrs, group2, ierr ) + call mpi_group_free( group, ierr ) +! +! Initialize the buffer + do i=1,nrows + buf(i,0) = -1 + buf(i,ncols+1) = -1 + enddo + do j=1,ncols + do i=1,nrows + buf(i,j) = rank * (ncols * nrows) + i + (j-1) * nrows + enddo + enddo + call mpi_win_post( group2, 0, win, ierr ) + call mpi_win_start( group2, 0, win, ierr ) +! + asize = ncols+1 + call mpi_put( buf(1,1), nrows, MPI_INTEGER, left, asize, & + & nrows, MPI_INTEGER, win, ierr ) + asize = 0 + call mpi_put( buf(1,ncols), nrows, MPI_INTEGER, right, asize, & + & nrows, MPI_INTEGER, win, ierr ) +! + call mpi_win_complete( win, ierr ) + flag = .false. + do while (.not. flag) + call mpi_win_test( win, flag, ierr ) + enddo +! +! Check the results + if (left .ne. MPI_PROC_NULL) then + do i=1, nrows + ans = rank * (ncols * nrows) - nrows + i + if (buf(i,0) .ne. ans) then + errs = errs + 1 + if (errs .le. 10) then + print *, ' buf(',i,',0) = ', buf(i,0), & + & 'expected ', ans + endif + endif + enddo + endif + if (right .ne. MPI_PROC_NULL) then + do i=1, nrows + ans = (rank+1) * (ncols * nrows) + i + if (buf(i,ncols+1) .ne. ans) then + errs = errs + 1 + if (errs .le. 10) then + print *, ' buf(',i,',',ncols+1,') = ', & + & buf(i,ncols+1), ' expected ', ans + endif + endif + enddo + endif + call mpi_group_free( group2, ierr ) + call mpi_win_free( win, ierr ) + call mtestFreeComm( comm ) + enddo + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f90/testlist b/teshsuite/smpi/mpich3-test/f90/testlist index bfe6f299d3..5e3e7d8841 100644 --- a/teshsuite/smpi/mpich3-test/f90/testlist +++ b/teshsuite/smpi/mpich3-test/f90/testlist @@ -9,7 +9,7 @@ init pt2pt datatype #f90types -# +rma #spawn #timer #topo