From be2e1849322a818224270fabdda2c7f591df7d60 Mon Sep 17 00:00:00 2001 From: degomme Date: Sat, 12 Jul 2014 01:52:13 +0200 Subject: [PATCH] Add f77 RMA tests --- buildtools/Cmake/DefinePackages.cmake | 1 + buildtools/Cmake/MakeExe.cmake | 1 + src/smpi/smpi_f77.c | 53 +++++- .../smpi/mpich3-test/f77/rma/CMakeLists.txt | 80 ++++++++ teshsuite/smpi/mpich3-test/f77/rma/addsize.h | 6 + .../smpi/mpich3-test/f77/rma/baseattrwinf.f | 81 ++++++++ teshsuite/smpi/mpich3-test/f77/rma/c2f2cwin.c | 91 +++++++++ .../smpi/mpich3-test/f77/rma/c2f2cwinf.f | 53 ++++++ teshsuite/smpi/mpich3-test/f77/rma/testlist | 19 ++ teshsuite/smpi/mpich3-test/f77/rma/winaccf.f | 94 +++++++++ .../smpi/mpich3-test/f77/rma/winattr2f.f | 86 +++++++++ teshsuite/smpi/mpich3-test/f77/rma/winattrf.f | 180 ++++++++++++++++++ teshsuite/smpi/mpich3-test/f77/rma/winerrf.f | 140 ++++++++++++++ .../smpi/mpich3-test/f77/rma/winfencef.f | 94 +++++++++ teshsuite/smpi/mpich3-test/f77/rma/wingetf.f | 94 +++++++++ .../smpi/mpich3-test/f77/rma/wingroupf.f | 41 ++++ teshsuite/smpi/mpich3-test/f77/rma/winnamef.f | 78 ++++++++ .../smpi/mpich3-test/f77/rma/winscale1f.f | 106 +++++++++++ .../smpi/mpich3-test/f77/rma/winscale2f.f | 111 +++++++++++ teshsuite/smpi/mpich3-test/f77/testlist | 2 +- 20 files changed, 1404 insertions(+), 7 deletions(-) create mode 100644 teshsuite/smpi/mpich3-test/f77/rma/CMakeLists.txt create mode 100644 teshsuite/smpi/mpich3-test/f77/rma/addsize.h create mode 100644 teshsuite/smpi/mpich3-test/f77/rma/baseattrwinf.f create mode 100644 teshsuite/smpi/mpich3-test/f77/rma/c2f2cwin.c create mode 100644 teshsuite/smpi/mpich3-test/f77/rma/c2f2cwinf.f create mode 100644 teshsuite/smpi/mpich3-test/f77/rma/testlist create mode 100644 teshsuite/smpi/mpich3-test/f77/rma/winaccf.f create mode 100644 teshsuite/smpi/mpich3-test/f77/rma/winattr2f.f create mode 100644 teshsuite/smpi/mpich3-test/f77/rma/winattrf.f create mode 100644 teshsuite/smpi/mpich3-test/f77/rma/winerrf.f create mode 100644 teshsuite/smpi/mpich3-test/f77/rma/winfencef.f create mode 100644 teshsuite/smpi/mpich3-test/f77/rma/wingetf.f create mode 100644 teshsuite/smpi/mpich3-test/f77/rma/wingroupf.f create mode 100644 teshsuite/smpi/mpich3-test/f77/rma/winnamef.f create mode 100644 teshsuite/smpi/mpich3-test/f77/rma/winscale1f.f create mode 100644 teshsuite/smpi/mpich3-test/f77/rma/winscale2f.f diff --git a/buildtools/Cmake/DefinePackages.cmake b/buildtools/Cmake/DefinePackages.cmake index efb204b811..6ed8362412 100644 --- a/buildtools/Cmake/DefinePackages.cmake +++ b/buildtools/Cmake/DefinePackages.cmake @@ -1077,6 +1077,7 @@ set(TESHSUITE_CMAKEFILES_TXT teshsuite/smpi/mpich3-test/f77/pt2pt/CMakeLists.txt teshsuite/smpi/mpich3-test/f77/util/CMakeLists.txt teshsuite/smpi/mpich3-test/f77/topo/CMakeLists.txt + teshsuite/smpi/mpich3-test/f77/rma/CMakeLists.txt teshsuite/smpi/mpich3-test/f90/coll/CMakeLists.txt teshsuite/smpi/mpich3-test/f90/datatype/CMakeLists.txt teshsuite/smpi/mpich3-test/f90/init/CMakeLists.txt diff --git a/buildtools/Cmake/MakeExe.cmake b/buildtools/Cmake/MakeExe.cmake index d412dd22b8..24981f1653 100644 --- a/buildtools/Cmake/MakeExe.cmake +++ b/buildtools/Cmake/MakeExe.cmake @@ -147,6 +147,7 @@ add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/ext) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/init) 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/coll) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f90/datatype) diff --git a/src/smpi/smpi_f77.c b/src/smpi/smpi_f77.c index 32200bf849..16690d67f0 100644 --- a/src/smpi/smpi_f77.c +++ b/src/smpi/smpi_f77.c @@ -15,6 +15,7 @@ static xbt_dict_t group_lookup = NULL; static xbt_dict_t request_lookup = NULL; static xbt_dict_t datatype_lookup = NULL; static xbt_dict_t op_lookup = NULL; +static xbt_dict_t win_lookup = NULL; static int running_processes = 0; #if defined(__alpha__) || defined(__sparc64__) || defined(__x86_64__) || defined(__ia64__) @@ -169,15 +170,35 @@ static void free_op(int op) { xbt_dict_remove(op_lookup, get_key(key, op)); } +static int new_win(MPI_Win win) { + static int win_id = 0; + char key[KEY_SIZE]; + xbt_dict_set(win_lookup, get_key(key, win_id), win, NULL); + win_id++; + return win_id-1; +} + +static MPI_Win get_win(int win) { + char key[KEY_SIZE]; + return win >= 0 + ? (MPI_Win)xbt_dict_get_or_null(win_lookup, get_key(key, win)) + : MPI_WIN_NULL; +} + +static void free_win(int win) { + char key[KEY_SIZE]; + xbt_dict_remove(win_lookup, get_key(key, win)); +} + + void mpi_init_(int* ierr) { if(!comm_lookup){ comm_lookup = xbt_dict_new_homogeneous(NULL); new_comm(MPI_COMM_WORLD); group_lookup = xbt_dict_new_homogeneous(NULL); - request_lookup = xbt_dict_new_homogeneous(NULL); - datatype_lookup = xbt_dict_new_homogeneous(NULL); + win_lookup = xbt_dict_new_homogeneous(NULL); new_datatype(MPI_BYTE); new_datatype(MPI_CHAR); #if defined(__alpha__) || defined(__sparc64__) || defined(__x86_64__) || defined(__ia64__) @@ -679,15 +700,23 @@ void mpi_error_string_(int* errorcode, char* string, int* resultlen, int* ierr){ } void mpi_win_fence_( int* assert, int* win, int* ierr){ - *ierr = MPI_Win_fence(* assert, *(MPI_Win*)win); + *ierr = MPI_Win_fence(* assert, get_win(*win)); } void mpi_win_free_( int* win, int* ierr){ - *ierr = MPI_Win_free( (MPI_Win*)win); + MPI_Win tmp = get_win(*win); + *ierr = MPI_Win_free(&tmp); + if(*ierr == MPI_SUCCESS) { + free_win(*win); + } } void mpi_win_create_( int *base, MPI_Aint* size, int* disp_unit, int* info, int* comm, int *win, int* ierr){ - *ierr = MPI_Win_create( (void*)base, *size, *disp_unit, *(MPI_Info*)info, get_comm(*comm),(MPI_Win*)win); + MPI_Win tmp; + *ierr = MPI_Win_create( (void*)base, *size, *disp_unit, *(MPI_Info*)info, get_comm(*comm),&tmp); + if(*ierr == MPI_SUCCESS) { + *win = new_win(tmp); + } } void mpi_info_create_( int *info, int* ierr){ @@ -705,7 +734,19 @@ void mpi_info_free_(int* info, int* ierr){ void mpi_get_( int *origin_addr, int* origin_count, int* origin_datatype, int *target_rank, MPI_Aint* target_disp, int *target_count, int* target_datatype, int* win, int* ierr){ *ierr = MPI_Get( (void*)origin_addr,*origin_count, get_datatype(*origin_datatype),*target_rank, - *target_disp, *target_count,get_datatype(*target_datatype), *(MPI_Win *)win); + *target_disp, *target_count,get_datatype(*target_datatype), get_win(*win)); +} + +void mpi_accumulate_( int *origin_addr, int* origin_count, int* origin_datatype, int *target_rank, + MPI_Aint* target_disp, int *target_count, int* target_datatype, int* op, int* win, int* ierr){ + *ierr = MPI_Accumulate( (void*)origin_addr,*origin_count, get_datatype(*origin_datatype),*target_rank, + *target_disp, *target_count,get_datatype(*target_datatype), get_op(*op), get_win(*win)); +} + +void mpi_put_( int *origin_addr, int* origin_count, int* origin_datatype, int *target_rank, + MPI_Aint* target_disp, int *target_count, int* target_datatype, int* win, int* ierr){ + *ierr = MPI_Put( (void*)origin_addr,*origin_count, get_datatype(*origin_datatype),*target_rank, + *target_disp, *target_count,get_datatype(*target_datatype), get_win(*win)); } diff --git a/teshsuite/smpi/mpich3-test/f77/rma/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f77/rma/CMakeLists.txt new file mode 100644 index 0000000000..910697ec21 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/rma/CMakeLists.txt @@ -0,0 +1,80 @@ +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/smpiff") + 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(winaccf winaccf.f) +# add_executable(winerrf winerrf.f) + add_executable(winfencef winfencef.f) +# add_executable(wingroupf wingroupf.f) +# add_executable(baseattrwinf baseattrwinf.f) +# add_executable(winattr2f winattr2f.f) +# add_executable(winattrf winattrf.f) +# add_executable(c2f2cwinf c2f2cwinf.f c2f2cwin.c) + add_executable(wingetf wingetf.f) +# add_executable(winnamef winnamef.f) +# add_executable(winscale1f winscale1f.f) +# add_executable(winscale2f winscale2f.f) + +target_link_libraries(winaccf simgrid mtest_f77) +#target_link_libraries(winerrf simgrid mtest_f77) +target_link_libraries(winfencef simgrid mtest_f77) +#target_link_libraries(wingroupf simgrid mtest_f77) +#target_link_libraries(baseattrwinf simgrid mtest_f77) +#target_link_libraries(c2f2cwinf simgrid mtest_f77) +#target_link_libraries(winattr2f simgrid mtest_f77) +#target_link_libraries(winattrf simgrid mtest_f77) +target_link_libraries(wingetf simgrid mtest_f77) +#target_link_libraries(winnamef simgrid mtest_f77) +#target_link_libraries(winscale1f simgrid mtest_f77) +#target_link_libraries(winscale2f simgrid mtest_f77) + + +endif() + +set(tesh_files + ${tesh_files} + PARENT_SCOPE + ) +set(xml_files + ${xml_files} + PARENT_SCOPE + ) +set(examples_src + ${examples_src} + ${CMAKE_CURRENT_SOURCE_DIR}/winaccf.f + ${CMAKE_CURRENT_SOURCE_DIR}/winerrf.f + ${CMAKE_CURRENT_SOURCE_DIR}/winfencef.f + ${CMAKE_CURRENT_SOURCE_DIR}/wingroupf.f + ${CMAKE_CURRENT_SOURCE_DIR}/addsize.h.in + ${CMAKE_CURRENT_SOURCE_DIR}/baseattrwinf.f + ${CMAKE_CURRENT_SOURCE_DIR}/c2f2cwin.c + ${CMAKE_CURRENT_SOURCE_DIR}/c2f2cwinf.f + ${CMAKE_CURRENT_SOURCE_DIR}/testlist + ${CMAKE_CURRENT_SOURCE_DIR}/winattr2f.f + ${CMAKE_CURRENT_SOURCE_DIR}/winattrf.f + ${CMAKE_CURRENT_SOURCE_DIR}/wingetf.f + ${CMAKE_CURRENT_SOURCE_DIR}/winnamef.f + ${CMAKE_CURRENT_SOURCE_DIR}/winscale1f.f + ${CMAKE_CURRENT_SOURCE_DIR}/winscale2f.f + ${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/f77/rma/addsize.h b/teshsuite/smpi/mpich3-test/f77/rma/addsize.h new file mode 100644 index 0000000000..6b8e09342c --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/rma/addsize.h @@ -0,0 +1,6 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + integer asize diff --git a/teshsuite/smpi/mpich3-test/f77/rma/baseattrwinf.f b/teshsuite/smpi/mpich3-test/f77/rma/baseattrwinf.f new file mode 100644 index 0000000000..58b86f6c58 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/rma/baseattrwinf.f @@ -0,0 +1,81 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + include 'attraints.h' + logical flag + integer ierr, errs + integer base(1024) + integer disp + integer win + integer commsize +C Include addsize defines asize as an address-sized integer + include 'addsize.h' + + errs = 0 + + call mtest_init( ierr ) + call mpi_comm_size( MPI_COMM_WORLD, commsize, ierr ) + +C 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 ) +C +C In order to check the base, we need an address-of function. +C 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" +C +C There is no easy way to get the actual value of base to compare +C against. MPI_Address gives a value relative to MPI_BOTTOM, which +C is different from 0 in Fortran (unless you can define MPI_BOTTOM +C as something like %pointer(0)). +C else +C +CC For this Fortran 77 version, we use the older MPI_Address function +C call MPI_Address( base, baseadd, ierr ) +C if (valout .ne. baseadd) then +C errs = errs + 1 +C print *, "Got incorrect value for WIN_BASE (", valout, +C & ", should be ", baseadd, ")" +C 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/f77/rma/c2f2cwin.c b/teshsuite/smpi/mpich3-test/f77/rma/c2f2cwin.c new file mode 100644 index 0000000000..c09933ebd4 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/rma/c2f2cwin.c @@ -0,0 +1,91 @@ +/* -*- 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/f77/rma/c2f2cwinf.f b/teshsuite/smpi/mpich3-test/f77/rma/c2f2cwinf.f new file mode 100644 index 0000000000..c757f1e38f --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/rma/c2f2cwinf.f @@ -0,0 +1,53 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C Test just MPI-RMA +C + program main + implicit none + include 'mpif.h' + integer errs, toterrs, ierr + integer wrank, wsize + integer wgroup, info, req, win + integer result + integer c2fwin +C The integer asize must be of ADDRESS_KIND size + include 'addsize.h' + errs = 0 + + call mpi_init( ierr ) + +C +C Test passing a Fortran MPI object to C + call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr ) + 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 ) + +C +C Test using a C routine to provide the Fortran handle + call f2cwin( win ) +C no info, in comm world, created with no memory (base address 0, +C displacement unit 1 + call mpi_win_free( win, ierr ) + +C +C Summarize the errors +C + call mpi_allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, + $ MPI_COMM_WORLD, ierr ) + if (wrank .eq. 0) then + if (toterrs .eq. 0) then + print *, ' No Errors' + else + print *, ' Found ', toterrs, ' errors' + endif + endif + + call mpi_finalize( ierr ) + end + diff --git a/teshsuite/smpi/mpich3-test/f77/rma/testlist b/teshsuite/smpi/mpich3-test/f77/rma/testlist new file mode 100644 index 0000000000..7c99beb049 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/rma/testlist @@ -0,0 +1,19 @@ +#Needs post,start, complete, wait +#winscale1f 4 +winfencef 4 +wingetf 5 +#Needs post,start, complete, wait +#winscale2f 4 +#Needs win error handling +#winerrf 1 +#Needs win set/get name +#winnamef 1 +#Needs win get group +#wingroupf 4 +winaccf 4 +#Needs mpi_win_f2c +#c2f2cwinf 1 +#Needs attr +#baseattrwinf 1 +#winattrf 1 +#winattr2f 1 diff --git a/teshsuite/smpi/mpich3-test/f77/rma/winaccf.f b/teshsuite/smpi/mpich3-test/f77/rma/winaccf.f new file mode 100644 index 0000000000..24eaf9dacf --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/rma/winaccf.f @@ -0,0 +1,94 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer ierr, errs + integer 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 +C Include addsize defines asize as an address-sized integer + include 'addsize.h' + + 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 +C +C 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 ) +C + 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 ) +C + call mpi_win_fence( MPI_MODE_NOSTORE + MPI_MODE_NOPUT + + & MPI_MODE_NOSUCCEED, win, ierr ) +C +C 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/f77/rma/winattr2f.f b/teshsuite/smpi/mpich3-test/f77/rma/winattr2f.f new file mode 100644 index 0000000000..1bae8363c3 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/rma/winattr2f.f @@ -0,0 +1,86 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C This is a modified version of winattrf.f that uses two of the +C default functions +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + include 'attraints.h' + integer comm, win, buf(10) + integer keyval + logical flag +C +C The only difference between the MPI-2 and MPI-1 attribute caching +C routines in Fortran is that the take an address-sized integer +C instead of a simple integer. These still are not pointers, +C so the values are still just integers. +C + errs = 0 + call mtest_init( ierr ) + call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr ) +C 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 ) +C + 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 +C +C 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 + +C 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/f77/rma/winattrf.f b/teshsuite/smpi/mpich3-test/f77/rma/winattrf.f new file mode 100644 index 0000000000..7b1336265b --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/rma/winattrf.f @@ -0,0 +1,180 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + include 'attraints.h' + integer comm, win, buf(10) + integer curcount, keyval + logical flag + external mycopyfn, mydelfn + integer callcount, delcount + common /myattr/ callcount, delcount +C +C The only difference between the MPI-2 and MPI-1 attribute caching +C routines in Fortran is that the take an address-sized integer +C instead of a simple integer. These still are not pointers, +C so the values are still just integers. +C + errs = 0 + callcount = 0 + delcount = 0 + call mtest_init( ierr ) + call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr ) +C 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 ) +C + 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 +C +C 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 + +C 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 +C +C The MPI standard defines null copy and duplicate functions. +C However, are only used when an object is duplicated. Since +C MPI_Win objects cannot be duplicated, so under normal circumstances, +C these will not be called. Since they are defined, they should behave +C 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 +C + call mpi_comm_free( comm, ierr ) + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end +C +C Note that the copyfn is unused for MPI windows, since there is +C (and because of alias rules, can be) no MPI_Win_dup function + subroutine mycopyfn( oldwin, keyval, extrastate, valin, valout, + & flag, ierr ) + implicit none + include 'mpif.h' + integer oldwin, keyval, ierr + include 'attraints.h' + logical flag + integer callcount, delcount + common /myattr/ callcount, delcount +C increment the attribute by 2 + valout = valin + 2 + callcount = callcount + 1 +C +C Since we should *never* call this, indicate an error + print *, ' Unexpected use of mycopyfn' + flag = .false. + ierr = MPI_ERR_OTHER + end +C + subroutine mydelfn( win, keyval, val, extrastate, ierr ) + implicit none + include 'mpif.h' + integer win, keyval, ierr + include 'attraints.h' + integer callcount, delcount + common /myattr/ callcount, delcount + delcount = delcount + 1 + if (extrastate .eq. 1001) then + ierr = MPI_SUCCESS + else + print *, ' Unexpected value of extrastate = ', extrastate + ierr = MPI_ERR_OTHER + endif + end diff --git a/teshsuite/smpi/mpich3-test/f77/rma/winerrf.f b/teshsuite/smpi/mpich3-test/f77/rma/winerrf.f new file mode 100644 index 0000000000..6d3d4f8cc1 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/rma/winerrf.f @@ -0,0 +1,140 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr, code(2), newerrclass, eclass + character*(MPI_MAX_ERROR_STRING) errstring + integer comm, rlen, intsize + integer buf(10) + integer win + external myerrhanfunc +CF90 INTERFACE +CF90 SUBROUTINE myerrhanfunc(vv0,vv1) +CF90 INTEGER vv0,vv1 +CF90 END SUBROUTINE +CF90 END INTERFACE + integer myerrhan, qerr + include 'addsize.h' + integer callcount, codesSeen(3) + common /myerrhan/ callcount, codesSeen + + errs = 0 + callcount = 0 + call mtest_init( ierr ) +C +C Setup some new codes and classes + call mpi_add_error_class( newerrclass, ierr ) + call mpi_add_error_code( newerrclass, code(1), ierr ) + call mpi_add_error_code( newerrclass, code(2), ierr ) + call mpi_add_error_string( newerrclass, "New Class", ierr ) + call mpi_add_error_string( code(1), "First new code", ierr ) + call mpi_add_error_string( code(2), "Second new code", ierr ) +C + call mpi_win_create_errhandler( myerrhanfunc, myerrhan, ierr ) +C +C Create a new communicator so that we can leave the default errors-abort +C on MPI_COMM_WORLD. Use this comm for win_create, just to leave a little +C more separation from comm_world +C + 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 ) +C + 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 ) +C 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 ) +C +C 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 +C + subroutine myerrhanfunc( win, errcode ) + implicit none + include 'mpif.h' + integer win, errcode + integer rlen, ierr + integer callcount, codesSeen(3) + character*(MPI_MAX_ERROR_STRING) errstring + common /myerrhan/ callcount, codesSeen + + callcount = callcount + 1 +C Remember the code we've seen + if (callcount .le. 3) then + codesSeen(callcount) = errcode + endif + call mpi_error_string( errcode, errstring, rlen, ierr ) + if (ierr .ne. MPI_SUCCESS) then + print *, ' Panic! could not get error string' + call mpi_abort( MPI_COMM_WORLD, 1, ierr ) + endif + end diff --git a/teshsuite/smpi/mpich3-test/f77/rma/winfencef.f b/teshsuite/smpi/mpich3-test/f77/rma/winfencef.f new file mode 100644 index 0000000000..565cc5bddf --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/rma/winfencef.f @@ -0,0 +1,94 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer ierr, errs + integer 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 +C Include addsize defines asize as an address-sized integer + include 'addsize.h' + + 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 +C +C 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 ) +C + 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 ) +C + call mpi_win_fence( MPI_MODE_NOSTORE + MPI_MODE_NOPUT + + & MPI_MODE_NOSUCCEED, win, ierr ) +C +C 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/f77/rma/wingetf.f b/teshsuite/smpi/mpich3-test/f77/rma/wingetf.f new file mode 100644 index 0000000000..3d5115881a --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/rma/wingetf.f @@ -0,0 +1,94 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer ierr, errs + integer 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 +C Include addsize defines asize as an address-sized integer + include 'addsize.h' + + 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 +C +C 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 ) +C + 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 ) +C + call mpi_win_fence( MPI_MODE_NOSTORE + MPI_MODE_NOPUT + + & MPI_MODE_NOSUCCEED, win, ierr ) +C +C 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/f77/rma/wingroupf.f b/teshsuite/smpi/mpich3-test/f77/rma/wingroupf.f new file mode 100644 index 0000000000..8c0cb760a6 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/rma/wingroupf.f @@ -0,0 +1,41 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer ierr, errs + integer buf(10) + integer comm, group1, group2, result, win, intsize + logical mtestGetIntraComm + include 'addsize.h' + + 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 +C + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/rma/winnamef.f b/teshsuite/smpi/mpich3-test/f77/rma/winnamef.f new file mode 100644 index 0000000000..5f59d6e3b1 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/rma/winnamef.f @@ -0,0 +1,78 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + integer win, rlen, ln + character*(MPI_MAX_OBJECT_NAME) cname + integer buf(10) + integer intsize +C Include addsize defines asize as an address-sized integer + include 'addsize.h' + logical found +C + errs = 0 + call mtest_init( ierr ) +C +C Create a window and get, set the names on it +C + 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 ) +C +C 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 +C +C 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 +C + call mpi_win_free( win, ierr ) + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/rma/winscale1f.f b/teshsuite/smpi/mpich3-test/f77/rma/winscale1f.f new file mode 100644 index 0000000000..9a978f6658 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/rma/winscale1f.f @@ -0,0 +1,106 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer ierr, errs + integer 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 +C Include addsize defines asize as an address-sized integer + include 'addsize.h' + + 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 ) + +C 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 ) +C +C 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 ) +C + 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 ) +C + call mpi_win_complete( win, ierr ) + call mpi_win_wait( win, ierr ) +C +C 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/f77/rma/winscale2f.f b/teshsuite/smpi/mpich3-test/f77/rma/winscale2f.f new file mode 100644 index 0000000000..8b1108c3de --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/rma/winscale2f.f @@ -0,0 +1,111 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer ierr, errs + integer 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 +C Include addsize defines asize as an address-sized integer + include 'addsize.h' + + 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 ) + +C 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 ) +C +C 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 ) +C + 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 ) +C + call mpi_win_complete( win, ierr ) + flag = .false. + do while (.not. flag) + call mpi_win_test( win, flag, ierr ) + enddo +C +C 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/f77/testlist b/teshsuite/smpi/mpich3-test/f77/testlist index 1e34a0374d..e275a57ead 100644 --- a/teshsuite/smpi/mpich3-test/f77/testlist +++ b/teshsuite/smpi/mpich3-test/f77/testlist @@ -5,7 +5,7 @@ pt2pt #info #spawn #io -# +rma init #comm ext -- 2.20.1