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
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)
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__)
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__)
}
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){
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));
}
--- /dev/null
+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
+ )
--- /dev/null
+C -*- Mode: Fortran; -*-
+C
+C (C) 2003 by Argonne National Laboratory.
+C See COPYRIGHT in top-level directory.
+C
+ integer asize
--- /dev/null
+C -*- Mode: Fortran; -*-
+C
+C (C) 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
--- /dev/null
+/* -*- Mode: C; c-basic-offset:4 ; indent-tabs-mode:nil ; -*- */
+/*
+ *
+ * (C) 2001 by Argonne National Laboratory.
+ * See COPYRIGHT in top-level directory.
+ */
+/*
+ * This file contains the C routines used in testing the c2f and f2c
+ * handle conversion functions 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 <stdio.h>
+#include "mpi.h"
+#include "../../include/mpitestconf.h"
+#include <string.h>
+
+/*
+ Name mapping. All routines are created with names that are lower case
+ with a single trailing underscore. This matches many compilers.
+ We use #define to change the name for Fortran compilers that do
+ not use the lowercase/underscore pattern
+*/
+
+#ifdef F77_NAME_UPPER
+#define 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 );
+}
+
--- /dev/null
+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
+
--- /dev/null
+#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
--- /dev/null
+C -*- Mode: Fortran; -*-
+C
+C (C) 2003 by Argonne National Laboratory.
+C See COPYRIGHT in top-level directory.
+C
+ program main
+ implicit none
+ include 'mpif.h'
+ integer ierr, errs
+ integer 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
--- /dev/null
+C -*- Mode: Fortran; -*-
+C
+C (C) 2003 by Argonne National Laboratory.
+C See COPYRIGHT in top-level directory.
+C This is a modified version of 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
--- /dev/null
+C -*- Mode: Fortran; -*-
+C
+C (C) 2003 by Argonne National Laboratory.
+C See COPYRIGHT in top-level directory.
+C
+ program main
+ implicit none
+ include 'mpif.h'
+ integer errs, ierr
+ include 'attraints.h'
+ integer comm, 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
--- /dev/null
+C -*- Mode: Fortran; -*-
+C
+C (C) 2003 by Argonne National Laboratory.
+C See COPYRIGHT in top-level directory.
+C
+ program main
+ implicit none
+ include 'mpif.h'
+ integer errs, ierr, code(2), newerrclass, eclass
+ character*(MPI_MAX_ERROR_STRING) errstring
+ integer comm, rlen, 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
--- /dev/null
+C -*- Mode: Fortran; -*-
+C
+C (C) 2003 by Argonne National Laboratory.
+C See COPYRIGHT in top-level directory.
+C
+ program main
+ implicit none
+ include 'mpif.h'
+ integer ierr, errs
+ integer 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
--- /dev/null
+C -*- Mode: Fortran; -*-
+C
+C (C) 2003 by Argonne National Laboratory.
+C See COPYRIGHT in top-level directory.
+C
+ program main
+ implicit none
+ include 'mpif.h'
+ integer ierr, errs
+ integer 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
--- /dev/null
+C -*- Mode: Fortran; -*-
+C
+C (C) 2003 by Argonne National Laboratory.
+C See COPYRIGHT in top-level directory.
+C
+ program main
+ implicit none
+ include 'mpif.h'
+ integer ierr, errs
+ integer 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
--- /dev/null
+C -*- Mode: Fortran; -*-
+C
+C (C) 2003 by Argonne National Laboratory.
+C See COPYRIGHT in top-level directory.
+C
+ program main
+ implicit none
+ include 'mpif.h'
+ integer errs, ierr
+ integer 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
--- /dev/null
+C -*- Mode: Fortran; -*-
+C
+C (C) 2003 by Argonne National Laboratory.
+C See COPYRIGHT in top-level directory.
+C
+ program main
+ implicit none
+ include 'mpif.h'
+ integer ierr, errs
+ integer 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
--- /dev/null
+C -*- Mode: Fortran; -*-
+C
+C (C) 2003 by Argonne National Laboratory.
+C See COPYRIGHT in top-level directory.
+C
+ program main
+ implicit none
+ include 'mpif.h'
+ integer ierr, errs
+ integer 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
#info
#spawn
#io
-#
+rma
init
#comm
ext