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
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)
> [0.000000] [surf_config/INFO] Switching workstation model to compound since you changed the network and/or cpu model(s)
> [Jupiter:1:(0) 0.000000] [smpi_replay/VERBOSE] 1 Irecv 0 1e6 0.000000
> [Jupiter:1:(0) 6.553424] [smpi_replay/VERBOSE] 1 compute 5e8 6.553424
-> [Jupiter:1:(0) 6.553424] [smpi_replay/VERBOSE] 1 test 0.000000
+> [Jupiter:1:(0) 6.553524] [smpi_replay/VERBOSE] 1 test 0.000100
> [Tremblay:0:(0) 10.194200] [smpi_replay/VERBOSE] 0 compute 1e9 10.194200
> [Tremblay:0:(0) 10.358662] [smpi_replay/VERBOSE] 0 send 1 1e6 0.164463
-> [Jupiter:1:(0) 13.106847] [smpi_replay/VERBOSE] 1 compute 5e8 6.553424
-> [Jupiter:1:(0) 13.106847] [smpi_replay/VERBOSE] 1 wait 0.000000
+> [Jupiter:1:(0) 13.106947] [smpi_replay/VERBOSE] 1 compute 5e8 6.553424
+> [Jupiter:1:(0) 13.106947] [smpi_replay/VERBOSE] 1 wait 0.000000
> [Tremblay:0:(0) 20.552862] [smpi_replay/VERBOSE] 0 compute 1e9 10.194200
> [Fafard:2:(0) 26.213694] [smpi_replay/VERBOSE] 2 compute 2e9 26.213694
> [Fafard:2:(0) 26.213694] [smpi_replay/VERBOSE] 2 Irecv 1 1e6 0.000000
-> [Jupiter:1:(0) 26.401165] [smpi_replay/VERBOSE] 1 send 2 1e6 13.294318
+> [Jupiter:1:(0) 26.401165] [smpi_replay/VERBOSE] 1 send 2 1e6 13.294218
> [Fafard:2:(0) 29.490406] [smpi_replay/VERBOSE] 2 compute 2.5e8 3.276712
-> [Fafard:2:(0) 29.490406] [smpi_replay/VERBOSE] 2 test 0.000000
-> [Fafard:2:(0) 32.767118] [smpi_replay/VERBOSE] 2 compute 2.5e8 3.276712
-> [Fafard:2:(0) 32.767118] [smpi_replay/VERBOSE] 2 Isend 0 1e6 0.000000
-> [Tremblay:0:(0) 32.920433] [smpi_replay/VERBOSE] 0 recv 2 1e6 12.367571
-> [Fafard:2:(0) 39.320541] [smpi_replay/VERBOSE] 2 compute 5e8 6.553424
-> [Fafard:2:(0) 39.320541] [smpi_replay/INFO] Simulation time 39.320541
+> [Fafard:2:(0) 29.490606] [smpi_replay/VERBOSE] 2 test 0.000200
+> [Fafard:2:(0) 32.767318] [smpi_replay/VERBOSE] 2 compute 2.5e8 3.276712
+> [Fafard:2:(0) 32.767318] [smpi_replay/VERBOSE] 2 Isend 0 1e6 0.000000
+> [Tremblay:0:(0) 32.920633] [smpi_replay/VERBOSE] 0 recv 2 1e6 12.367771
+> [Fafard:2:(0) 39.320741] [smpi_replay/VERBOSE] 2 compute 5e8 6.553424
+> [Fafard:2:(0) 39.320741] [smpi_replay/INFO] Simulation time 39.320741
$ rm -f replay/one_trace
s_mpi_coll_description_t * table);
XBT_PUBLIC(int) find_coll_description(s_mpi_coll_description_t * table,
char *name);
+
+
+extern double smpi_wtime_sleep;
+extern double smpi_iprobe_sleep;
+extern double smpi_test_sleep;
+
#endif /* _SMPI_INTERFAC_H */
static void _sg_cfg_cb__coll_barrier(const char *name, int pos){
_sg_cfg_cb__coll("barrier", mpi_coll_barrier_description, name, pos);
}
+
+static void _sg_cfg_cb__wtime_sleep(const char *name, int pos){
+ smpi_wtime_sleep = xbt_cfg_get_double(_sg_cfg_set, name);
+}
+
+static void _sg_cfg_cb__iprobe_sleep(const char *name, int pos){
+ smpi_iprobe_sleep = xbt_cfg_get_double(_sg_cfg_set, name);
+}
+
+static void _sg_cfg_cb__test_sleep(const char *name, int pos){
+ smpi_test_sleep = xbt_cfg_get_double(_sg_cfg_set, name);
+}
+
+
+
#endif
/* callback of the inclusion path */
xbt_cfg_register(&_sg_cfg_set, "smpi/iprobe",
"Minimum time to inject inside a call to MPI_Iprobe",
- xbt_cfgelm_double, 1, 1, NULL, NULL);
+ xbt_cfgelm_double, 1, 1, _sg_cfg_cb__iprobe_sleep, NULL);
xbt_cfg_setdefault_double(_sg_cfg_set, "smpi/iprobe", 1e-4);
+ xbt_cfg_register(&_sg_cfg_set, "smpi/test",
+ "Minimum time to inject inside a call to MPI_Test",
+ xbt_cfgelm_double, 1, 1, _sg_cfg_cb__test_sleep, NULL);
+ xbt_cfg_setdefault_double(_sg_cfg_set, "smpi/test", 1e-4);
+
+ xbt_cfg_register(&_sg_cfg_set, "smpi/wtime",
+ "Minimum time to inject inside a call to MPI_Wtime",
+ xbt_cfgelm_double, 1, 1, _sg_cfg_cb__wtime_sleep, NULL);
+ xbt_cfg_setdefault_double(_sg_cfg_set, "smpi/wtime", 0.0);
+
xbt_cfg_register(&_sg_cfg_set, "smpi/coll_selector",
"Which collective selector to use",
xbt_cfgelm_string, 1, 1, NULL, NULL);
int smpi_enabled(void);
void smpi_global_init(void);
void smpi_global_destroy(void);
+double smpi_mpi_wtime(void);
int is_datatype_valid(MPI_Datatype datatype);
xbt_dynar_t smpi_or_values = NULL;
xbt_dynar_t smpi_ois_values = NULL;
+double smpi_wtime_sleep = 0.0;
+double smpi_iprobe_sleep = 1e-4;
+double smpi_test_sleep = 1e-4;
+
+
// Methods used to parse and store the values for timing injections in smpi
// These are taken from surf/network.c and generalized to have more factors
// These methods should be merged with those in surf/network.c (moved somewhere in xbt ?)
return current;
}
+double smpi_mpi_wtime(){
+ double time;
+ if (smpi_process_initialized() && !smpi_process_finalized() && !smpi_process_get_sampling()) {
+ smpi_bench_end();
+ time = SIMIX_get_clock();
+ //to avoid deadlocks if called too many times
+ if(smpi_wtime_sleep > 0) simcall_process_sleep(smpi_wtime_sleep);
+ smpi_bench_begin();
+ } else {
+ time = SIMIX_get_clock();
+ }
+ return time;
+}
+
static MPI_Request build_request(void *buf, int count,
MPI_Datatype datatype, int src, int dst,
int tag, MPI_Comm comm, unsigned flags)
int flag;
//assume that request is not MPI_REQUEST_NULL (filtered in PMPI_Test or smpi_mpi_testall before)
+
+ //to avoid deadlocks
+ //multiplier to the sleeptime, to increase speed of execution, each failed test will increase it
+ static int nsleeps = 1;
+ if(smpi_test_sleep > 0) simcall_process_sleep(nsleeps*smpi_test_sleep);
+
smpi_empty_status(status);
flag = 1;
if (!((*request)->flags & PREPARED)) {
flag = simcall_comm_test((*request)->action);
if (flag) {
finish_wait(request, status);
+ nsleeps=1;//reset the number of sleeps we will do next time
if (*request != MPI_REQUEST_NULL && !((*request)->flags & PERSISTENT))
*request = MPI_REQUEST_NULL;
+ }else{
+ nsleeps++;
}
}
return flag;
}
}
if(size > 0) {
+ //multiplier to the sleeptime, to increase speed of execution, each failed testany will increase it
+ static int nsleeps = 1;
+ if(smpi_test_sleep > 0) simcall_process_sleep(nsleeps*smpi_test_sleep);
+
i = simcall_comm_testany(comms);
// not MPI_UNDEFINED, as this is a simix return code
if(i != -1) {
if (requests[*index] != MPI_REQUEST_NULL && (requests[*index]->flags & NON_PERSISTENT))
requests[*index] = MPI_REQUEST_NULL;
flag = 1;
+ nsleeps=1;
+ }else{
+ nsleeps++;
}
}else{
//all requests are null or inactive, return true
comm, PERSISTENT | RECV);
//to avoid deadlock, we have to sleep some time here, or the timer won't advance and we will only do iprobe simcalls
- double sleeptime= sg_cfg_get_double("smpi/iprobe");
//multiplier to the sleeptime, to increase speed of execution, each failed iprobe will increase it
static int nsleeps = 1;
-
- simcall_process_sleep(sleeptime);
-
+ if(smpi_iprobe_sleep > 0) simcall_process_sleep(nsleeps*smpi_iprobe_sleep);
// behave like a receive, but don't do it
smx_rdv_t mailbox;
double PMPI_Wtime(void)
{
- double time;
- if (smpi_process_initialized() && !smpi_process_finalized() && !smpi_process_get_sampling()) {
- smpi_bench_end();
- time = SIMIX_get_clock();
- smpi_bench_begin();
- } else {
- time = SIMIX_get_clock();
- }
- return time;
+ return smpi_mpi_wtime();
}
extern double sg_maxmin_precision;
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
C
+C SimGrid comment :
+C This file holds a value which should have the same size as an MPI_Aint
+C that can hold any pointer. In f90 it's a integer (kind=MPI_ADDRESS_KIND)
+C Original mpich testsuite uses autconf to configure the right size to use
+C Integer is not right on some systems, we set it to integer*8 by default
integer*8 asize
--- /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/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}/c2f902cwin.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
+ PARENT_SCOPE
+ )
+set(bin_files
+ ${bin_files}
+ PARENT_SCOPE
+ )
+set(txt_files
+ ${txt_files}
+ ${CMAKE_CURRENT_SOURCE_DIR}/testlist
+ PARENT_SCOPE
+ )
--- /dev/null
+! This file created from test/mpi/f77/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
--- /dev/null
+! 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
+
--- /dev/null
+/* 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 <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
+# 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
pt2pt
datatype
#f90types
-#
+rma
#spawn
#timer
#topo