From 35fd56f06e4d1d4bc93a80dd0e53afeb20f7e35d Mon Sep 17 00:00:00 2001 From: degomme Date: Sun, 12 Feb 2017 02:57:28 +0100 Subject: [PATCH] Try to fix mpich tests on systems without privatization --- teshsuite/smpi/mpich3-test/CMakeLists.txt | 4 +- .../smpi/mpich3-test/util/dtypes_manual.c | 387 +++ .../util/mtest_datatype_gen_manual.c | 626 +++++ .../smpi/mpich3-test/util/mtest_manual.c | 2368 +++++++---------- 4 files changed, 2023 insertions(+), 1362 deletions(-) create mode 100644 teshsuite/smpi/mpich3-test/util/dtypes_manual.c create mode 100644 teshsuite/smpi/mpich3-test/util/mtest_datatype_gen_manual.c diff --git a/teshsuite/smpi/mpich3-test/CMakeLists.txt b/teshsuite/smpi/mpich3-test/CMakeLists.txt index 28b482a184..614d90445a 100644 --- a/teshsuite/smpi/mpich3-test/CMakeLists.txt +++ b/teshsuite/smpi/mpich3-test/CMakeLists.txt @@ -22,6 +22,8 @@ set(txt_files ${txt_files} ${CMAKE_CURRENT_SOURCE_DIR}/README ${CMAKE_CURRENT_SOURCE_DIR}/util/mtest_datatype.c ${CMAKE_CURRENT_SOURCE_DIR}/util/mtest_datatype_gen.c ${CMAKE_CURRENT_SOURCE_DIR}/util/mtest_manual.c + ${CMAKE_CURRENT_SOURCE_DIR}/util/mtestt_datatype_gen_manual.c + ${CMAKE_CURRENT_SOURCE_DIR}/util/dtypes_manual.c ${CMAKE_CURRENT_SOURCE_DIR}/f77/testlist ${CMAKE_CURRENT_SOURCE_DIR}/f90/testlist ${CMAKE_CURRENT_SOURCE_DIR}/include/dtypes.h @@ -49,6 +51,6 @@ if(enable_smpi AND enable_smpi_MPICH3_testsuite) if(HAVE_PRIVATIZATION) add_library(mtest_c STATIC util/dtypes.c util/mtest.c util/mtestcheck.c util/mtest_datatype.c util/mtest_datatype_gen.c) else() - add_library(mtest_c STATIC util/mtest_manual.c) + add_library(mtest_c STATIC util/mtest_manual.c util/dtypes_manual.c util/mtestcheck.c util/mtest_datatype.c util/mtest_datatype_gen_manual.c) endif() endif() diff --git a/teshsuite/smpi/mpich3-test/util/dtypes_manual.c b/teshsuite/smpi/mpich3-test/util/dtypes_manual.c new file mode 100644 index 0000000000..bfff4be3fd --- /dev/null +++ b/teshsuite/smpi/mpich3-test/util/dtypes_manual.c @@ -0,0 +1,387 @@ +/* -*- Mode: C; c-basic-offset:4 ; indent-tabs-mode:nil ; -*- */ +/* + * + * (C) 2014 by Argonne National Laboratory. + * See COPYRIGHT in top-level directory. + */ +#include "mpi.h" +#include "mpitestconf.h" +#include "mpitest.h" +#include "dtypes.h" +#if defined(HAVE_STDIO_H) || defined(STDC_HEADERS) +#include +#endif +#if defined(HAVE_STDLIB_H) || defined(STDC_HEADERS) +#include +#endif +#if defined(HAVE_STRING_H) || defined(STDC_HEADERS) +#include +#endif +#ifdef HAVE_STDARG_H +#include +#endif + +/* This file contains code to generate a variety of MPI datatypes for testing + the various MPI routines. + + To simplify the test code, this generates an array of datatypes, buffers with + data and buffers with no data (0 bits) for use in send and receive + routines of various types. + + In addition, this doesn't even test all of the possibilities. For example, + there is currently no test of sending more than one item defined with + MPI_Type_contiguous . + + Note also that this test assumes that the sending and receive types are + the same. MPI requires only that the type signatures match, which is + a weaker requirement. + + This code was drawn from the MPICH-1 test suite and modified to fit the + new MPICH test suite. It provides an alternative set of datatype tests + to the ones in mtest.c. + + */ + +/* Change this to test only the basic, predefined types */ +static int basic_only = 0; + +/* + Arrays types, inbufs, outbufs, and counts are allocated by the + CALLER. n on input is the maximum number; on output, it is the + number defined. + + See MTestDatatype2Allocate below for a routine to allocate these arrays. + + We may want to add a routine to call to check that the proper data + has been received. + */ + +/* + Add a predefined MPI type to the tests. _count instances of the + type will be sent. +*/ +#define SETUPBASICTYPE(_mpitype,_ctype,_count) { \ + int i; _ctype *a; \ + if (cnt > *n) {*n = cnt; return; } \ + types[cnt] = _mpitype; \ + inbufs[cnt] = (void *)calloc(_count,sizeof(_ctype)); \ + outbufs[cnt] = (void *)malloc(sizeof(_ctype) * (_count)); \ + a = (_ctype *)inbufs[cnt]; for (i=0; i<(_count); i++) a[i] = i; \ + a = (_ctype *)outbufs[cnt]; for (i=0; i<(_count); i++) a[i] = 0; \ + counts[cnt] = _count; bytesize[cnt] = sizeof(_ctype) * (_count); cnt++; } + +/* + Add a contiguous version of a predefined type. Send one instance of + the type which contains _count copies of the predefined type. + */ +#define SETUPCONTIGTYPE(_mpitype,_ctype,_count) { \ + int i; _ctype *a; char*myname; \ + char _basename[MPI_MAX_OBJECT_NAME]; int _basenamelen;\ + if (cnt > *n) {*n = cnt; return; }\ + MPI_Type_contiguous(_count, _mpitype, types + cnt);\ + MPI_Type_commit(types + cnt);\ + inbufs[cnt] = (void *)calloc(_count, sizeof(_ctype)); \ + outbufs[cnt] = (void *)malloc(sizeof(_ctype) * (_count)); \ + a = (_ctype *)inbufs[cnt]; for (i=0; i<(_count); i++) a[i] = i; \ + a = (_ctype *)outbufs[cnt]; for (i=0; i<(_count); i++) a[i] = 0; \ + myname = (char *)malloc(100);\ + MPI_Type_get_name(_mpitype, _basename, &_basenamelen); \ + snprintf(myname, 100, "Contig type %s", _basename); \ + MPI_Type_set_name(types[cnt], myname); \ + free(myname); \ + counts[cnt] = 1; bytesize[cnt] = sizeof(_ctype) * (_count); cnt++; } + +/* + Create a vector with _count elements, separated by stride _stride, + of _mpitype. Each block has a single element. + */ +#define SETUPVECTORTYPE(_mpitype,_ctype,_count,_stride,_name) { \ + int i; _ctype *a; char *myname; \ + char _basename[MPI_MAX_OBJECT_NAME]; int _basenamelen;\ + if (cnt > *n) {*n = cnt; return; }\ + MPI_Type_vector(_count, 1, _stride, _mpitype, types + cnt); \ + MPI_Type_commit(types + cnt);\ + inbufs[cnt] = (void *)calloc(sizeof(_ctype) * (_count) * (_stride),1); \ + outbufs[cnt] = (void *)calloc(sizeof(_ctype) * (_count) * (_stride),1); \ + a = (_ctype *)inbufs[cnt]; for (i=0; i<(_count); i++) a[i*(_stride)] = i; \ + a = (_ctype *)outbufs[cnt]; for (i=0; i<(_count); i++) a[i*(_stride)] = 0; \ + myname = (char *)malloc(100);\ + MPI_Type_get_name(_mpitype, _basename, &_basenamelen); \ + snprintf(myname, 100, "Vector type %s", _basename); \ + MPI_Type_set_name(types[cnt], myname); \ + free(myname); \ + counts[cnt] = 1; bytesize[cnt] = sizeof(_ctype) * (_count) * (_stride) ;\ + cnt++; } + +/* This indexed type is setup like a contiguous type . + Note that systems may try to convert this to contiguous, so we'll + eventually need a test that has holes in it */ +#define SETUPINDEXTYPE(_mpitype,_ctype,_count,_name) { \ + int i; int *lens, *disp; _ctype *a; char *myname; \ + char _basename[MPI_MAX_OBJECT_NAME]; int _basenamelen;\ + if (cnt > *n) {*n = cnt; return; }\ + lens = (int *)malloc((_count) * sizeof(int)); \ + disp = (int *)malloc((_count) * sizeof(int)); \ + for (i=0; i<(_count); i++) { lens[i] = 1; disp[i] = i; } \ + MPI_Type_indexed((_count), lens, disp, _mpitype, types + cnt);\ + free(lens); free(disp); \ + MPI_Type_commit(types + cnt);\ + inbufs[cnt] = (void *)calloc((_count), sizeof(_ctype)); \ + outbufs[cnt] = (void *)malloc(sizeof(_ctype) * (_count)); \ + a = (_ctype *)inbufs[cnt]; for (i=0; i<(_count); i++) a[i] = i; \ + a = (_ctype *)outbufs[cnt]; for (i=0; i<(_count); i++) a[i] = 0; \ + myname = (char *)malloc(100);\ + MPI_Type_get_name(_mpitype, _basename, &_basenamelen); \ + snprintf(myname, 100, "Index type %s", _basename); \ + MPI_Type_set_name(types[cnt], myname); \ + free(myname); \ + counts[cnt] = 1; bytesize[cnt] = sizeof(_ctype) * (_count); cnt++; } + +/* This defines a structure of two basic members; by chosing things like + (char, double), various packing and alignment tests can be made */ +#define SETUPSTRUCT2TYPE(_mpitype1,_ctype1,_mpitype2,_ctype2,_count,_tname) { \ + int i; char *myname; \ + MPI_Datatype b[3]; int cnts[3]; \ + struct name { _ctype1 a1; _ctype2 a2; } *a, samp; \ + MPI_Aint disp[3]; \ + if (cnt > *n) {*n = cnt; return; } \ + b[0] = _mpitype1; b[1] = _mpitype2; b[2] = MPI_UB; \ + cnts[0] = 1; cnts[1] = 1; cnts[2] = 1; \ + MPI_Get_address(&(samp.a2), &disp[1]); \ + MPI_Get_address(&(samp.a1), &disp[0]); \ + MPI_Get_address(&(samp) + 1, &disp[2]); \ + disp[1] = disp[1] - disp[0]; disp[2] = disp[2] - disp[0]; disp[0] = 0; \ + MPI_Type_create_struct(3, cnts, disp, b, types + cnt); \ + MPI_Type_commit(types + cnt); \ + inbufs[cnt] = (void *)calloc(sizeof(struct name) * (_count),1); \ + outbufs[cnt] = (void *)calloc(sizeof(struct name) * (_count),1); \ + a = (struct name *)inbufs[cnt]; for (i=0; i<(_count); i++) { a[i].a1 = i; \ + a[i].a2 = i; } \ + a = (struct name *)outbufs[cnt]; for (i=0; i<(_count); i++) { a[i].a1 = 0; \ + a[i].a2 = 0; } \ + myname = (char *)malloc(100); \ + snprintf(myname, 100, "Struct type %s", _tname); \ + MPI_Type_set_name(types[cnt], myname); \ + free(myname); \ + counts[cnt] = (_count); bytesize[cnt] = sizeof(struct name) * (_count);cnt++; } + +/* This accomplished the same effect as VECTOR, but allow a count of > 1 */ +#define SETUPSTRUCTTYPEUB(_mpitype,_ctype,_count,_stride) { \ + int i; _ctype *a; char *myname; \ + int blens[2]; MPI_Aint disps[2]; MPI_Datatype mtypes[2]; \ + char _basename[MPI_MAX_OBJECT_NAME]; int _basenamelen;\ + if (cnt > *n) {*n = cnt; return; } \ + blens[0] = 1; blens[1] = 1; disps[0] = 0; \ + disps[1] = (_stride) * sizeof(_ctype); \ + mtypes[0] = _mpitype; mtypes[1] = MPI_UB; \ + MPI_Type_create_struct(2, blens, disps, mtypes, types + cnt); \ + MPI_Type_commit(types + cnt); \ + inbufs[cnt] = (void *)calloc(sizeof(_ctype) * (_count) * (_stride),1);\ + outbufs[cnt] = (void *)calloc(sizeof(_ctype) * (_count) * (_stride),1);\ + a = (_ctype *)inbufs[cnt]; for (i=0; i<(_count); i++) a[i*(_stride)] = i; \ + a = (_ctype *)outbufs[cnt]; for (i=0; i<(_count); i++) a[i*(_stride)] = 0; \ + myname = (char *)malloc(100); \ + MPI_Type_get_name(_mpitype, _basename, &_basenamelen); \ + snprintf(myname, 100, "Struct (MPI_UB) type %s", _basename); \ + MPI_Type_set_name(types[cnt], myname); \ + free(myname); \ + counts[cnt] = (_count); \ + bytesize[cnt] = sizeof(_ctype) * (_count) * (_stride);\ + cnt++; } + +/* + * Set whether only the basic types should be generated + */ +void MTestDatatype2BasicOnly(void) +{ + basic_only = 1; +} + +SMPI_VARINIT_GLOBAL_AND_SET(nbasic_types, int, 0); /* World rank */ +/* On input, n is the size of the various buffers. On output, + it is the number available types + */ +void MTestDatatype2Generate(MPI_Datatype * types, void **inbufs, void **outbufs, + int *counts, int *bytesize, int *n) +{ + int cnt = 0; /* Number of defined types */ + int typecnt = 10; /* Number of instances to send in most cases */ + int stride = 9; /* Number of elements in vector to stride */ + + /* First, generate an element of each basic type */ + SETUPBASICTYPE(MPI_CHAR, char, typecnt); + SETUPBASICTYPE(MPI_SHORT, short, typecnt); + SETUPBASICTYPE(MPI_INT, int, typecnt); + SETUPBASICTYPE(MPI_LONG, long, typecnt); + SETUPBASICTYPE(MPI_UNSIGNED_CHAR, unsigned char, typecnt); + SETUPBASICTYPE(MPI_UNSIGNED_SHORT, unsigned short, typecnt); + SETUPBASICTYPE(MPI_UNSIGNED, unsigned, typecnt); + SETUPBASICTYPE(MPI_UNSIGNED_LONG, unsigned long, typecnt); + SETUPBASICTYPE(MPI_FLOAT, float, typecnt); + SETUPBASICTYPE(MPI_DOUBLE, double, typecnt); + SETUPBASICTYPE(MPI_BYTE, char, typecnt); +#ifdef HAVE_LONG_LONG_INT + SETUPBASICTYPE(MPI_LONG_LONG_INT, long long, typecnt); +#endif +#ifdef HAVE_LONG_DOUBLE + SETUPBASICTYPE(MPI_LONG_DOUBLE, long double, typecnt); +#endif + SMPI_VARGET_GLOBAL(nbasic_types) = cnt; + + if (basic_only) { + *n = cnt; + return; + } + /* Generate contiguous data items */ + SETUPCONTIGTYPE(MPI_CHAR, char, typecnt); + SETUPCONTIGTYPE(MPI_SHORT, short, typecnt); + SETUPCONTIGTYPE(MPI_INT, int, typecnt); + SETUPCONTIGTYPE(MPI_LONG, long, typecnt); + SETUPCONTIGTYPE(MPI_UNSIGNED_CHAR, unsigned char, typecnt); + SETUPCONTIGTYPE(MPI_UNSIGNED_SHORT, unsigned short, typecnt); + SETUPCONTIGTYPE(MPI_UNSIGNED, unsigned, typecnt); + SETUPCONTIGTYPE(MPI_UNSIGNED_LONG, unsigned long, typecnt); + SETUPCONTIGTYPE(MPI_FLOAT, float, typecnt); + SETUPCONTIGTYPE(MPI_DOUBLE, double, typecnt); + SETUPCONTIGTYPE(MPI_BYTE, char, typecnt); +#ifdef HAVE_LONG_LONG_INT + SETUPCONTIGTYPE(MPI_LONG_LONG_INT, long long, typecnt); +#endif +#ifdef HAVE_LONG_DOUBLE + SETUPCONTIGTYPE(MPI_LONG_DOUBLE, long double, typecnt); +#endif + + /* Generate vector items */ + SETUPVECTORTYPE(MPI_CHAR, char, typecnt, stride, "MPI_CHAR"); + SETUPVECTORTYPE(MPI_SHORT, short, typecnt, stride, "MPI_SHORT"); + SETUPVECTORTYPE(MPI_INT, int, typecnt, stride, "MPI_INT"); + SETUPVECTORTYPE(MPI_LONG, long, typecnt, stride, "MPI_LONG"); + SETUPVECTORTYPE(MPI_UNSIGNED_CHAR, unsigned char, typecnt, stride, "MPI_UNSIGNED_CHAR"); + SETUPVECTORTYPE(MPI_UNSIGNED_SHORT, unsigned short, typecnt, stride, "MPI_UNSIGNED_SHORT"); + SETUPVECTORTYPE(MPI_UNSIGNED, unsigned, typecnt, stride, "MPI_UNSIGNED"); + SETUPVECTORTYPE(MPI_UNSIGNED_LONG, unsigned long, typecnt, stride, "MPI_UNSIGNED_LONG"); + SETUPVECTORTYPE(MPI_FLOAT, float, typecnt, stride, "MPI_FLOAT"); + SETUPVECTORTYPE(MPI_DOUBLE, double, typecnt, stride, "MPI_DOUBLE"); + SETUPVECTORTYPE(MPI_BYTE, char, typecnt, stride, "MPI_BYTE"); +#ifdef HAVE_LONG_LONG_INT + SETUPVECTORTYPE(MPI_LONG_LONG_INT, long long, typecnt, stride, "MPI_LONG_LONG_INT"); +#endif +#ifdef HAVE_LONG_DOUBLE + SETUPVECTORTYPE(MPI_LONG_DOUBLE, long double, typecnt, stride, "MPI_LONG_DOUBLE"); +#endif + + /* Generate indexed items */ + SETUPINDEXTYPE(MPI_CHAR, char, typecnt, "MPI_CHAR"); + SETUPINDEXTYPE(MPI_SHORT, short, typecnt, "MPI_SHORT"); + SETUPINDEXTYPE(MPI_INT, int, typecnt, "MPI_INT"); + SETUPINDEXTYPE(MPI_LONG, long, typecnt, "MPI_LONG"); + SETUPINDEXTYPE(MPI_UNSIGNED_CHAR, unsigned char, typecnt, "MPI_UNSIGNED_CHAR"); + SETUPINDEXTYPE(MPI_UNSIGNED_SHORT, unsigned short, typecnt, "MPI_UNSIGNED_SHORT"); + SETUPINDEXTYPE(MPI_UNSIGNED, unsigned, typecnt, "MPI_UNSIGNED"); + SETUPINDEXTYPE(MPI_UNSIGNED_LONG, unsigned long, typecnt, "MPI_UNSIGNED_LONG"); + SETUPINDEXTYPE(MPI_FLOAT, float, typecnt, "MPI_FLOAT"); + SETUPINDEXTYPE(MPI_DOUBLE, double, typecnt, "MPI_DOUBLE"); + SETUPINDEXTYPE(MPI_BYTE, char, typecnt, "MPI_BYTE"); +#ifdef HAVE_LONG_LONG_INT + SETUPINDEXTYPE(MPI_LONG_LONG_INT, long long, typecnt, "MPI_LONG_LONG_INT"); +#endif +#ifdef HAVE_LONG_DOUBLE + SETUPINDEXTYPE(MPI_LONG_DOUBLE, long double, typecnt, "MPI_LONG_DOUBLE"); +#endif + + /* Generate struct items */ + SETUPSTRUCT2TYPE(MPI_CHAR, char, MPI_DOUBLE, double, typecnt, "char-double"); + SETUPSTRUCT2TYPE(MPI_DOUBLE, double, MPI_CHAR, char, typecnt, "double-char"); + SETUPSTRUCT2TYPE(MPI_UNSIGNED, unsigned, MPI_DOUBLE, double, typecnt, "unsigned-double"); + SETUPSTRUCT2TYPE(MPI_FLOAT, float, MPI_LONG, long, typecnt, "float-long"); + SETUPSTRUCT2TYPE(MPI_UNSIGNED_CHAR, unsigned char, MPI_CHAR, char, typecnt, + "unsigned char-char"); + SETUPSTRUCT2TYPE(MPI_UNSIGNED_SHORT, unsigned short, MPI_DOUBLE, double, + typecnt, "unsigned short-double"); + + /* Generate struct using MPI_UB */ + SETUPSTRUCTTYPEUB(MPI_CHAR, char, typecnt, stride); + SETUPSTRUCTTYPEUB(MPI_SHORT, short, typecnt, stride); + SETUPSTRUCTTYPEUB(MPI_INT, int, typecnt, stride); + SETUPSTRUCTTYPEUB(MPI_LONG, long, typecnt, stride); + SETUPSTRUCTTYPEUB(MPI_UNSIGNED_CHAR, unsigned char, typecnt, stride); + SETUPSTRUCTTYPEUB(MPI_UNSIGNED_SHORT, unsigned short, typecnt, stride); + SETUPSTRUCTTYPEUB(MPI_UNSIGNED, unsigned, typecnt, stride); + SETUPSTRUCTTYPEUB(MPI_UNSIGNED_LONG, unsigned long, typecnt, stride); + SETUPSTRUCTTYPEUB(MPI_FLOAT, float, typecnt, stride); + SETUPSTRUCTTYPEUB(MPI_DOUBLE, double, typecnt, stride); + SETUPSTRUCTTYPEUB(MPI_BYTE, char, typecnt, stride); + + /* 60 different entries to this point + 4 for long long and + * 4 for long double */ + *n = cnt; +} + +/* + MAX_TEST should be 1 + actual max (allows us to check that it was, + indeed, large enough) + */ +#define MAX_TEST 70 +void MTestDatatype2Allocate(MPI_Datatype ** types, void ***inbufs, + void ***outbufs, int **counts, int **bytesize, int *n) +{ + *types = (MPI_Datatype *) malloc(MAX_TEST * sizeof(MPI_Datatype)); + *inbufs = (void **) malloc(MAX_TEST * sizeof(void *)); + *outbufs = (void **) malloc(MAX_TEST * sizeof(void *)); + *counts = (int *) malloc(MAX_TEST * sizeof(int)); + *bytesize = (int *) malloc(MAX_TEST * sizeof(int)); + *n = MAX_TEST; +} + +int MTestDatatype2Check(void *inbuf, void *outbuf, int size_bytes) +{ + char *in = (char *) inbuf, *out = (char *) outbuf; + int i; + for (i = 0; i < size_bytes; i++) { + if (in[i] != out[i]) { + return i + 1; + } + } + return 0; +} + +/* + * This is a version of CheckData that prints error messages + */ +static int MtestDatatype2CheckAndPrint(void *inbuf, void *outbuf, int size_bytes, + char *typename, int typenum) +{ + int errloc, world_rank; + + if ((errloc = MTestDatatype2Check(inbuf, outbuf, size_bytes))) { + char *p1, *p2; + MPI_Comm_rank(MPI_COMM_WORLD, &world_rank); + fprintf(stderr, + "Error in data with type %s (type %d on %d) at byte %d of %d\n", + typename, typenum, world_rank, errloc - 1, size_bytes); + p1 = (char *) inbuf; + p2 = (char *) outbuf; + fprintf(stderr, "Got %x expected %x\n", p2[errloc - 1], p1[errloc - 1]); + } + return errloc; +} + +void MTestDatatype2Free(MPI_Datatype * types, void **inbufs, void **outbufs, + int *counts, int *bytesize, int n) +{ + int i; + for (i = 0; i < n; i++) { + if (inbufs[i]) + free(inbufs[i]); + if (outbufs[i]) + free(outbufs[i]); + /* Only if not basic ... */ + if (i >= SMPI_VARGET_GLOBAL(nbasic_types)) + MPI_Type_free(types + i); + } + free(types); + free(inbufs); + free(outbufs); + free(counts); + free(bytesize); +} diff --git a/teshsuite/smpi/mpich3-test/util/mtest_datatype_gen_manual.c b/teshsuite/smpi/mpich3-test/util/mtest_datatype_gen_manual.c new file mode 100644 index 0000000000..bfc5bdf569 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/util/mtest_datatype_gen_manual.c @@ -0,0 +1,626 @@ +/* -*- Mode: C; c-basic-offset:4 ; indent-tabs-mode:nil ; -*- */ +/* + * + * (C) 2014 by Argonne National Laboratory. + * See COPYRIGHT in top-level directory. + */ +#include "mtest_datatype.h" +#if defined(HAVE_STDIO_H) || defined(STDC_HEADERS) +#include +#endif +#if defined(HAVE_STDLIB_H) || defined(STDC_HEADERS) +#include +#endif +#if defined(HAVE_STRING_H) || defined(STDC_HEADERS) +#include +#endif +#ifdef HAVE_STDARG_H +#include +#endif +/* The following two includes permit the collection of resource usage + data in the tests + */ +#ifdef HAVE_SYS_TIME_H +#include +#endif +#ifdef HAVE_SYS_RESOURCE_H +#include +#endif +#include + +static int dbgflag = 0; /* Flag used for debugging */ +SMPI_VARINIT_GLOBAL_AND_SET(wrank2, int, -1); /* World rank */ +static int verbose = 0; /* Message level (0 is none) */ + +/* + * Utility routines for writing MPI datatype communication tests. + * + * Both basic and derived datatype are included. + * For basic datatypes, every type has a test case that both the send and + * receive buffer use the same datatype and count. + * + * For derived datatypes: + * All the test cases are defined in this file, and the datatype definitions + * are in file mtest_datatype.c. Each test case will be automatically called + * by every datatype. + * + * Test case generation: + * Every datatype tests derived datatype send buffer and + * derived datatype receive buffer separately. Each test contains various sub + * tests for different structures (i.e., different value of count or block + * length). The following four structures are defined: + * L count & S block length & S stride + * S count & L block length & S stride + * L count & S block length & L stride + * S count & L block length & L stride + * S count & L block length & S stride & S lower-bound + * contiguous (stride = block length) + * contiguous (stride = block length) & S lower-bound + * + * How to add a new structure for each datatype: + * 1. Add structure definition in function MTestDdtStructDefine. + * 2. Increase MTEST_DDT_NUM_SUBTESTS + * + * Datatype definition: + * Every type is initialized by the creation function stored in + * mtestDdtCreators variable, all of their create/init/check functions are + * defined in file mtest_datatype.c. + * + * How to add a new derived datatype: + * 1. Add the new datatype in enum MTEST_DERIVED_DT. + * 2. Add its create/init/check functions in file mtest_datatype.c + * 3. Add its creator function to mtestDdtCreators variable + * + * Following three test levels of datatype are defined. + * 1. Basic + * All basic datatypes + * 2. Minimum + * All basic datatypes | Vector | Indexed + * 3. Full + * All basic datatypes | Vector | Hvector | Indexed | Hindexed | + * Indexed-block | Hindexed-block | Subarray with order-C | Subarray with order-Fortran + * + * There are two ways to specify the test level of datatype. The second way has + * higher priority (means the value specified by the first way will be overwritten + * by that in the second way). + * 1. Specify global test level by setting the MPITEST_DATATYPE_TEST_LEVEL + * environment variable before execution (basic,min,full|full by default). + * 2. Initialize a special level for a datatype loop by calling the corresponding + * initialization function before that loop, otherwise the default value specified + * in the first way is used. + * Basic : MTestInitBasicDatatypes + * Minimum : MTestInitMinDatatypes + * Full : MTestInitFullDatatypes + */ + +static int datatype_index = 0; + +/* ------------------------------------------------------------------------ */ +/* Routine and internal parameters to define the range of datatype tests */ +/* ------------------------------------------------------------------------ */ + +#define MTEST_DDT_NUM_SUBTESTS 7 /* 7 kinds of derived datatype structure */ +static MTestDdtCreator mtestDdtCreators[MTEST_DDT_MAX]; + +static int MTEST_BDT_START_IDX = -1; +static int MTEST_BDT_NUM_TESTS = 0; +static int MTEST_BDT_RANGE = 0; + +static int MTEST_DDT_NUM_TYPES = 0; +static int MTEST_SEND_DDT_START_IDX = 0; +static int MTEST_SEND_DDT_NUM_TESTS = 0; +static int MTEST_SEND_DDT_RANGE = 0; + +static int MTEST_RECV_DDT_START_IDX = 0; +static int MTEST_RECV_DDT_NUM_TESTS = 0; +static int MTEST_RECV_DDT_RANGE = 0; + +enum { + MTEST_DATATYPE_TEST_LEVEL_FULL, + MTEST_DATATYPE_TEST_LEVEL_MIN, + MTEST_DATATYPE_TEST_LEVEL_BASIC +}; + +/* current datatype test level */ +static int MTEST_DATATYPE_TEST_LEVEL = MTEST_DATATYPE_TEST_LEVEL_FULL; +/* default datatype test level specified by environment variable */ +static int MTEST_DATATYPE_TEST_LEVEL_ENV = -1; +/* default datatype initialization function */ +static void (*MTestInitDefaultTestFunc) (void) = NULL; + +static void MTestInitDatatypeGen(int basic_dt_num, int derived_dt_num) +{ + MTEST_BDT_START_IDX = 0; + MTEST_BDT_NUM_TESTS = basic_dt_num; + MTEST_BDT_RANGE = MTEST_BDT_START_IDX + MTEST_BDT_NUM_TESTS; + MTEST_DDT_NUM_TYPES = derived_dt_num; + MTEST_SEND_DDT_START_IDX = MTEST_BDT_NUM_TESTS; + MTEST_SEND_DDT_NUM_TESTS = MTEST_DDT_NUM_TYPES * MTEST_DDT_NUM_SUBTESTS; + MTEST_SEND_DDT_RANGE = MTEST_SEND_DDT_START_IDX + MTEST_SEND_DDT_NUM_TESTS; + MTEST_RECV_DDT_START_IDX = MTEST_SEND_DDT_START_IDX + MTEST_SEND_DDT_NUM_TESTS; + MTEST_RECV_DDT_NUM_TESTS = MTEST_DDT_NUM_TYPES * MTEST_DDT_NUM_SUBTESTS; + MTEST_RECV_DDT_RANGE = MTEST_RECV_DDT_START_IDX + MTEST_RECV_DDT_NUM_TESTS; +} + +static int MTestIsDatatypeGenInited() +{ + return (MTEST_BDT_START_IDX < 0) ? 0 : 1; +} + +static void MTestPrintDatatypeGen() +{ + MTestPrintfMsg(1, "MTest datatype test level : %s. %d basic datatype tests, " + "%d derived datatype tests will be generated\n", + (MTEST_DATATYPE_TEST_LEVEL == MTEST_DATATYPE_TEST_LEVEL_FULL) ? "FULL" : "MIN", + MTEST_BDT_NUM_TESTS, MTEST_SEND_DDT_NUM_TESTS + MTEST_RECV_DDT_NUM_TESTS); +} + +static void MTestResetDatatypeGen() +{ + MTEST_BDT_START_IDX = -1; +} + +void MTestInitFullDatatypes(void) +{ + /* Do not allow to change datatype test level during loop. + * Otherwise indexes will be wrong. + * Test must explicitly call reset or wait for current datatype loop being + * done before changing to another test level. */ + if (!MTestIsDatatypeGenInited()) { + MTEST_DATATYPE_TEST_LEVEL = MTEST_DATATYPE_TEST_LEVEL_FULL; + MTestTypeCreatorInit((MTestDdtCreator *) mtestDdtCreators); + MTestInitDatatypeGen(MTEST_BDT_MAX, MTEST_DDT_MAX); + } + else { + printf("Warning: trying to reinitialize mtest datatype during " "datatype iteration!"); + } +} + +void MTestInitMinDatatypes(void) +{ + /* Do not allow to change datatype test level during loop. + * Otherwise indexes will be wrong. + * Test must explicitly call reset or wait for current datatype loop being + * done before changing to another test level. */ + if (!MTestIsDatatypeGenInited()) { + MTEST_DATATYPE_TEST_LEVEL = MTEST_DATATYPE_TEST_LEVEL_MIN; + MTestTypeMinCreatorInit((MTestDdtCreator *) mtestDdtCreators); + MTestInitDatatypeGen(MTEST_BDT_MAX, MTEST_MIN_DDT_MAX); + } + else { + printf("Warning: trying to reinitialize mtest datatype during " "datatype iteration!"); + } +} + +void MTestInitBasicDatatypes(void) +{ + /* Do not allow to change datatype test level during loop. + * Otherwise indexes will be wrong. + * Test must explicitly call reset or wait for current datatype loop being + * done before changing to another test level. */ + if (!MTestIsDatatypeGenInited()) { + MTEST_DATATYPE_TEST_LEVEL = MTEST_DATATYPE_TEST_LEVEL_BASIC; + MTestInitDatatypeGen(MTEST_BDT_MAX, 0); + } + else { + printf("Warning: trying to reinitialize mtest datatype during " "datatype iteration!"); + } +} + +static inline void MTestInitDatatypeEnv() +{ + char *envval = 0; + + /* Read global test level specified by user environment variable. + * Only initialize once at the first time that test calls datatype routine. */ + if (MTEST_DATATYPE_TEST_LEVEL_ENV > -1) + return; + + /* default full */ + MTEST_DATATYPE_TEST_LEVEL_ENV = MTEST_DATATYPE_TEST_LEVEL_FULL; + MTestInitDefaultTestFunc = MTestInitFullDatatypes; + + envval = getenv("MPITEST_DATATYPE_TEST_LEVEL"); + if (envval && strlen(envval)) { + if (!strncmp(envval, "min", strlen("min"))) { + MTEST_DATATYPE_TEST_LEVEL_ENV = MTEST_DATATYPE_TEST_LEVEL_MIN; + MTestInitDefaultTestFunc = MTestInitMinDatatypes; + } + else if (!strncmp(envval, "basic", strlen("basic"))) { + MTEST_DATATYPE_TEST_LEVEL_ENV = MTEST_DATATYPE_TEST_LEVEL_BASIC; + MTestInitDefaultTestFunc = MTestInitBasicDatatypes; + } + else if (strncmp(envval, "full", strlen("full"))) { + fprintf(stderr, "Unknown MPITEST_DATATYPE_TEST_LEVEL %s\n", envval); + } + } +} + +/* -------------------------------------------------------------------------------*/ +/* Routine to define various sets of blocklen/count/stride for derived datatypes. */ +/* ------------------------------------------------------------------------------ */ + +static inline int MTestDdtStructDefine(int ddt_index, MPI_Aint tot_count, MPI_Aint * count, + MPI_Aint * blen, MPI_Aint * stride, + MPI_Aint * align_tot_count, MPI_Aint * lb) +{ + int merr = 0; + int ddt_c_st; + MPI_Aint _short = 0, _align_tot_count = 0, _count = 0, _blen = 0, _stride = 0; + MPI_Aint _lb = 0; + + ddt_c_st = ddt_index % MTEST_DDT_NUM_SUBTESTS; + + /* Get short value according to user specified tot_count. + * It is used as count for large-block-length structure, or block length + * for large-count structure. */ + if (tot_count < 2) { + _short = 1; + } + else if (tot_count < 64) { + _short = 2; + } + else { + _short = 64; + } + _align_tot_count = (tot_count + _short - 1) & ~(_short - 1); + + switch (ddt_c_st) { + case 0: + /* Large block length. */ + _count = _short; + _blen = _align_tot_count / _short; + _stride = _blen * 2; + break; + case 1: + /* Large count */ + _count = _align_tot_count / _short; + _blen = _short; + _stride = _blen * 2; + break; + case 2: + /* Large block length and large stride */ + _count = _short; + _blen = _align_tot_count / _short; + _stride = _blen * 10; + break; + case 3: + /* Large count and large stride */ + _count = _align_tot_count / _short; + _blen = _short; + _stride = _blen * 10; + break; + case 4: + /* Large block length with lb */ + _count = _short; + _blen = _align_tot_count / _short; + _stride = _blen * 2; + _lb = _short / 2; /* make sure lb < blen */ + break; + case 5: + /* Contig ddt (stride = block length) without lb */ + _count = _align_tot_count / _short; + _blen = _short; + _stride = _blen; + break; + case 6: + /* Contig ddt (stride = block length) with lb */ + _count = _short; + _blen = _align_tot_count / _short; + _stride = _blen; + _lb = _short / 2; /* make sure lb < blen */ + break; + default: + /* Undefined index */ + merr = 1; + break; + } + + *align_tot_count = _align_tot_count; + *count = _count; + *blen = _blen; + *stride = _stride; + *lb = _lb; + + return merr; +} + +/* ------------------------------------------------------------------------ */ +/* Routine to generate basic datatypes */ +/* ------------------------------------------------------------------------ */ + +static inline int MTestGetBasicDatatypes(MTestDatatype * sendtype, + MTestDatatype * recvtype, MPI_Aint tot_count) +{ + int merr = 0; + int bdt_index = datatype_index - MTEST_BDT_START_IDX; + if (bdt_index >= MTEST_BDT_MAX) { + printf("Wrong index: global %d, bst %d in %s\n", datatype_index, bdt_index, __FUNCTION__); + merr++; + return merr; + } + + switch (bdt_index) { + case MTEST_BDT_INT: + merr = MTestTypeBasicCreate(MPI_INT, sendtype); + merr = MTestTypeBasicCreate(MPI_INT, recvtype); + break; + case MTEST_BDT_DOUBLE: + merr = MTestTypeBasicCreate(MPI_DOUBLE, sendtype); + merr = MTestTypeBasicCreate(MPI_DOUBLE, recvtype); + break; + case MTEST_BDT_FLOAT_INT: + merr = MTestTypeBasicCreate(MPI_FLOAT_INT, sendtype); + merr = MTestTypeBasicCreate(MPI_FLOAT_INT, recvtype); + break; + case MTEST_BDT_SHORT: + merr = MTestTypeBasicCreate(MPI_SHORT, sendtype); + merr = MTestTypeBasicCreate(MPI_SHORT, recvtype); + break; + case MTEST_BDT_LONG: + merr = MTestTypeBasicCreate(MPI_LONG, sendtype); + merr = MTestTypeBasicCreate(MPI_LONG, recvtype); + break; + case MTEST_BDT_CHAR: + merr = MTestTypeBasicCreate(MPI_CHAR, sendtype); + merr = MTestTypeBasicCreate(MPI_CHAR, recvtype); + break; + case MTEST_BDT_UINT64_T: + merr = MTestTypeBasicCreate(MPI_UINT64_T, sendtype); + merr = MTestTypeBasicCreate(MPI_UINT64_T, recvtype); + break; + case MTEST_BDT_FLOAT: + merr = MTestTypeBasicCreate(MPI_FLOAT, sendtype); + merr = MTestTypeBasicCreate(MPI_FLOAT, recvtype); + break; + case MTEST_BDT_BYTE: + merr = MTestTypeBasicCreate(MPI_BYTE, sendtype); + merr = MTestTypeBasicCreate(MPI_BYTE, recvtype); + break; + } + sendtype->count = tot_count; + recvtype->count = tot_count; + + return merr; +} + +/* ------------------------------------------------------------------------ */ +/* Routine to generate send/receive derived datatypes */ +/* ------------------------------------------------------------------------ */ + +static inline int MTestGetSendDerivedDatatypes(MTestDatatype * sendtype, + MTestDatatype * recvtype, MPI_Aint tot_count) +{ + int merr = 0; + int ddt_datatype_index, ddt_c_dt; + MPI_Aint blen, stride, count, align_tot_count, lb; + MPI_Datatype old_type = MPI_DOUBLE; + + /* Check index */ + ddt_datatype_index = datatype_index - MTEST_SEND_DDT_START_IDX; + ddt_c_dt = ddt_datatype_index / MTEST_DDT_NUM_SUBTESTS; + if (ddt_c_dt >= MTEST_DDT_MAX || !mtestDdtCreators[ddt_c_dt]) { + printf("Wrong index: global %d, send %d send-ddt %d, or undefined creator in %s\n", + datatype_index, ddt_datatype_index, ddt_c_dt, __FUNCTION__); + merr++; + return merr; + } + + /* Set datatype structure */ + merr = MTestDdtStructDefine(ddt_datatype_index, tot_count, &count, &blen, + &stride, &align_tot_count, &lb); + if (merr) { + printf("Wrong index: global %d, send %d send-ddt %d, or undefined ddt structure in %s\n", + datatype_index, ddt_datatype_index, ddt_c_dt, __FUNCTION__); + merr++; + return merr; + } + + /* Create send datatype */ + merr = mtestDdtCreators[ddt_c_dt] (count, blen, stride, lb, old_type, "send", sendtype); + if (merr) + return merr; + + sendtype->count = 1; + + /* Create receive datatype */ + merr = MTestTypeBasicCreate(old_type, recvtype); + if (merr) + return merr; + + recvtype->count = sendtype->count * align_tot_count; + + return merr; +} + +static inline int MTestGetRecvDerivedDatatypes(MTestDatatype * sendtype, + MTestDatatype * recvtype, MPI_Aint tot_count) +{ + int merr = 0; + int ddt_datatype_index, ddt_c_dt; + MPI_Aint blen, stride, count, align_tot_count, lb; + MPI_Datatype old_type = MPI_DOUBLE; + + /* Check index */ + ddt_datatype_index = datatype_index - MTEST_RECV_DDT_START_IDX; + ddt_c_dt = ddt_datatype_index / MTEST_DDT_NUM_SUBTESTS; + if (ddt_c_dt >= MTEST_DDT_MAX || !mtestDdtCreators[ddt_c_dt]) { + printf("Wrong index: global %d, recv %d recv-ddt %d, or undefined creator in %s\n", + datatype_index, ddt_datatype_index, ddt_c_dt, __FUNCTION__); + merr++; + return merr; + } + + /* Set datatype structure */ + merr = MTestDdtStructDefine(ddt_datatype_index, tot_count, &count, &blen, + &stride, &align_tot_count, &lb); + if (merr) { + printf("Wrong index: global %d, recv %d recv-ddt %d, or undefined ddt structure in %s\n", + datatype_index, ddt_datatype_index, ddt_c_dt, __FUNCTION__); + return merr; + } + + /* Create receive datatype */ + merr = mtestDdtCreators[ddt_c_dt] (count, blen, stride, lb, old_type, "recv", recvtype); + if (merr) + return merr; + + recvtype->count = 1; + + /* Create send datatype */ + merr = MTestTypeBasicCreate(old_type, sendtype); + if (merr) + return merr; + + sendtype->count = recvtype->count * align_tot_count; + + return merr; +} + +/* ------------------------------------------------------------------------ */ +/* Exposed routine to external tests */ +/* ------------------------------------------------------------------------ */ +int MTestGetDatatypes(MTestDatatype * sendtype, MTestDatatype * recvtype, MPI_Aint tot_count) +{ + int merr = 0; + + MTestGetDbgInfo(&dbgflag, &verbose); + MTestInitDatatypeEnv(); + MPI_Comm_rank(MPI_COMM_WORLD, &SMPI_VARGET_GLOBAL(wrank2)); + + /* Initialize the default test level if test does not specify. */ + if (!MTestIsDatatypeGenInited()) { + MTestInitDefaultTestFunc(); + } + + if (datatype_index == 0) { + MTestPrintDatatypeGen(); + } + + /* Start generating tests */ + if (datatype_index < MTEST_BDT_RANGE) { + merr = MTestGetBasicDatatypes(sendtype, recvtype, tot_count); + + } + else if (datatype_index < MTEST_SEND_DDT_RANGE) { + merr = MTestGetSendDerivedDatatypes(sendtype, recvtype, tot_count); + + } + else if (datatype_index < MTEST_RECV_DDT_RANGE) { + merr = MTestGetRecvDerivedDatatypes(sendtype, recvtype, tot_count); + + } + else { + /* out of range */ + datatype_index = -1; + MTestResetDatatypeGen(); + } + + /* stop if error reported */ + if (merr) { + datatype_index = -1; + } + + if (datatype_index > 0) { + /* general initialization for receive buffer. */ + recvtype->InitBuf = MTestTypeInitRecv; + } + + datatype_index++; + + if (verbose >= 2 && datatype_index > 0) { + MPI_Count ssize, rsize; + MPI_Aint slb, rlb, sextent, rextent; + const char *sendtype_nm = MTestGetDatatypeName(sendtype); + const char *recvtype_nm = MTestGetDatatypeName(recvtype); + MPI_Type_size_x(sendtype->datatype, &ssize); + MPI_Type_size_x(recvtype->datatype, &rsize); + + MPI_Type_get_extent(sendtype->datatype, &slb, &sextent); + MPI_Type_get_extent(recvtype->datatype, &rlb, &rextent); + + MTestPrintfMsg(2, "Get datatypes: send = %s(size %d ext %ld lb %ld count %d basesize %d), " + "recv = %s(size %d ext %ld lb %ld count %d basesize %d), tot_count=%d\n", + sendtype_nm, ssize, sextent, slb, sendtype->count, sendtype->basesize, + recvtype_nm, rsize, rextent, rlb, recvtype->count, recvtype->basesize, + tot_count); + fflush(stdout); + } + + return datatype_index; +} + +/* Reset the datatype index (start from the initial data type. + Note: This routine is rarely needed; MTestGetDatatypes automatically + starts over after the last available datatype is used. +*/ +void MTestResetDatatypes(void) +{ + datatype_index = 0; + MTestResetDatatypeGen(); +} + +/* Return the index of the current datatype. This is rarely needed and + is provided mostly to enable debugging of the MTest package itself */ +int MTestGetDatatypeIndex(void) +{ + return datatype_index; +} + +/* Free the storage associated with a datatype */ +void MTestFreeDatatype(MTestDatatype * mtype) +{ + int merr; + /* Invoke a datatype-specific free function to handle + * both the datatype and the send/receive buffers */ + if (mtype->FreeBuf) { + (mtype->FreeBuf) (mtype); + } + /* Free the datatype itself if it was created */ + if (!mtype->isBasic) { + merr = MPI_Type_free(&mtype->datatype); + if (merr) + MTestPrintError(merr); + } +} + +/* Check that a message was received correctly. Returns the number of + errors detected. Status may be NULL or MPI_STATUS_IGNORE */ +int MTestCheckRecv(MPI_Status * status, MTestDatatype * recvtype) +{ + int count; + int errs = 0, merr; + + if (status && status != MPI_STATUS_IGNORE) { + merr = MPI_Get_count(status, recvtype->datatype, &count); + if (merr) + MTestPrintError(merr); + + /* Check count against expected count */ + if (count != recvtype->count) { + errs++; + } + } + + /* Check received data */ + if (!errs && recvtype->CheckBuf(recvtype)) { + errs++; + } + return errs; +} + +/* This next routine uses a circular buffer of static name arrays just to + simplify the use of the routine */ +const char *MTestGetDatatypeName(MTestDatatype * dtype) +{ + static char name[4][MPI_MAX_OBJECT_NAME]; + static int sp = 0; + int rlen, merr; + + if (sp >= 4) + sp = 0; + merr = MPI_Type_get_name(dtype->datatype, name[sp], &rlen); + if (merr) + MTestPrintError(merr); + return (const char *) name[sp++]; +} diff --git a/teshsuite/smpi/mpich3-test/util/mtest_manual.c b/teshsuite/smpi/mpich3-test/util/mtest_manual.c index e0813e7671..7af77c9dbd 100644 --- a/teshsuite/smpi/mpich3-test/util/mtest_manual.c +++ b/teshsuite/smpi/mpich3-test/util/mtest_manual.c @@ -39,11 +39,11 @@ * as the error handler. We do *not* set MPI_ERRORS_RETURN because * the code that makes use of these routines may not check return * codes. - * + * */ -static void MTestRMACleanup( void ); -static void MTestResourceSummary( FILE * ); +static void MTestRMACleanup(void); +static void MTestResourceSummary(FILE *); /* Here is where we could put the includes and definitions to enable memory testing */ @@ -64,1287 +64,723 @@ SMPI_VARINIT_GLOBAL_AND_SET(usageOutput, int, 0); /* */ #define MPI_THREAD_SINGLE 0 #endif -/* +/* * Initialize and Finalize MTest */ /* - Initialize MTest, initializing MPI if necessary. + Initialize MTest, initializing MPI if necessary. Environment Variables: + MPITEST_DEBUG - If set (to any value), turns on debugging output . MPITEST_THREADLEVEL_DEFAULT - If set, use as the default "provided" - level of thread support. Applies to + level of thread support. Applies to MTest_Init but not MTest_Init_thread. - MPITEST_VERBOSE - If set to a numeric value, turns on that level of verbose output. This is used by the routine 'MTestPrintfMsg' */ -void MTest_Init_thread( int *argc, char ***argv, int required, int *provided ) +void MTest_Init_thread(int *argc, char ***argv, int required, int *provided) { int flag; char *envval = 0; - MPI_Initialized( &flag ); + MPI_Initialized(&flag); if (!flag) { - /* Permit an MPI that claims only MPI 1 but includes the - MPI_Init_thread routine (e.g., IBM MPI) */ + /* Permit an MPI that claims only MPI 1 but includes the + * MPI_Init_thread routine (e.g., IBM MPI) */ #if MPI_VERSION >= 2 || defined(HAVE_MPI_INIT_THREAD) - MPI_Init_thread( argc, argv, required, provided ); + MPI_Init_thread(argc, argv, required, provided); #else - MPI_Init( argc, argv ); - *provided = -1; + MPI_Init(argc, argv); + *provided = -1; #endif } /* Check for debugging control */ - if (getenv( "MPITEST_DEBUG" )) { - SMPI_VARGET_GLOBAL(dbgflag) = 1; - MPI_Comm_rank( MPI_COMM_WORLD, &SMPI_VARGET_GLOBAL(wrank) ); + if (getenv("MPITEST_DEBUG")) { + SMPI_VARGET_GLOBAL(dbgflag) = 1; + MPI_Comm_rank(MPI_COMM_WORLD, &SMPI_VARGET_GLOBAL(wrank)); } /* Check for verbose control */ - envval = getenv( "MPITEST_VERBOSE" ); + envval = getenv("MPITEST_VERBOSE"); if (envval) { - char *s; - long val = strtol( envval, &s, 0 ); - if (s == envval) { - /* This is the error case for strtol */ - fprintf( stderr, "Warning: %s not valid for MPITEST_VERBOSE\n", - envval ); - fflush( stderr ); - } - else { - if (val >= 0) { - SMPI_VARGET_GLOBAL(verbose) = val; - } - else { - fprintf( stderr, "Warning: %s not valid for MPITEST_VERBOSE\n", - envval ); - fflush( stderr ); - } - } + char *s; + long val = strtol(envval, &s, 0); + if (s == envval) { + /* This is the error case for strtol */ + fprintf(stderr, "Warning: %s not valid for MPITEST_VERBOSE\n", envval); + fflush(stderr); + } + else { + if (val >= 0) { + SMPI_VARGET_GLOBAL(verbose) = val; + } + else { + fprintf(stderr, "Warning: %s not valid for MPITEST_VERBOSE\n", envval); + fflush(stderr); + } + } } /* Check for option to return success/failure in the return value of main */ - envval = getenv( "MPITEST_RETURN_WITH_CODE" ); + envval = getenv("MPITEST_RETURN_WITH_CODE"); if (envval) { - if (strcmp( envval, "yes" ) == 0 || - strcmp( envval, "YES" ) == 0 || - strcmp( envval, "true" ) == 0 || - strcmp( envval, "TRUE" ) == 0) { - SMPI_VARGET_GLOBAL(returnWithVal) = 1; - } - else if (strcmp( envval, "no" ) == 0 || - strcmp( envval, "NO" ) == 0 || - strcmp( envval, "false" ) == 0 || - strcmp( envval, "FALSE" ) == 0) { - SMPI_VARGET_GLOBAL(returnWithVal) = 0; - } - else { - fprintf( stderr, - "Warning: %s not valid for MPITEST_RETURN_WITH_CODE\n", - envval ); - fflush( stderr ); - } + if (strcmp(envval, "yes") == 0 || + strcmp(envval, "YES") == 0 || + strcmp(envval, "true") == 0 || strcmp(envval, "TRUE") == 0) { + SMPI_VARGET_GLOBAL(returnWithVal) = 1; + } + else if (strcmp(envval, "no") == 0 || + strcmp(envval, "NO") == 0 || + strcmp(envval, "false") == 0 || strcmp(envval, "FALSE") == 0) { + SMPI_VARGET_GLOBAL(returnWithVal) = 0; + } + else { + fprintf(stderr, "Warning: %s not valid for MPITEST_RETURN_WITH_CODE\n", envval); + fflush(stderr); + } } - + /* Print rusage data if set */ - if (getenv( "MPITEST_RUSAGE" )) { - SMPI_VARGET_GLOBAL(usageOutput) = 1; + if (getenv("MPITEST_RUSAGE")) { + SMPI_VARGET_GLOBAL(usageOutput) = 1; } } -/* - * Initialize the tests, using an MPI-1 style init. Supports + +/* + * Initialize the tests, using an MPI-1 style init. Supports * MTEST_THREADLEVEL_DEFAULT to test with user-specified thread level */ -void MTest_Init( int *argc, char ***argv ) +void MTest_Init(int *argc, char ***argv) { int provided; #if MPI_VERSION >= 2 || defined(HAVE_MPI_INIT_THREAD) const char *str = 0; - int threadLevel; + int threadLevel; threadLevel = MPI_THREAD_SINGLE; - str = getenv( "MTEST_THREADLEVEL_DEFAULT" ); - if (!str) str = getenv( "MPITEST_THREADLEVEL_DEFAULT" ); + str = getenv("MTEST_THREADLEVEL_DEFAULT"); + if (!str) + str = getenv("MPITEST_THREADLEVEL_DEFAULT"); if (str && *str) { - if (strcmp(str,"MULTIPLE") == 0 || strcmp(str,"multiple") == 0) { - threadLevel = MPI_THREAD_MULTIPLE; - } - else if (strcmp(str,"SERIALIZED") == 0 || - strcmp(str,"serialized") == 0) { - threadLevel = MPI_THREAD_SERIALIZED; - } - else if (strcmp(str,"FUNNELED") == 0 || strcmp(str,"funneled") == 0) { - threadLevel = MPI_THREAD_FUNNELED; - } - else if (strcmp(str,"SINGLE") == 0 || strcmp(str,"single") == 0) { - threadLevel = MPI_THREAD_SINGLE; - } - else { - fprintf( stderr, "Unrecognized thread level %s\n", str ); - /* Use exit since MPI_Init/Init_thread has not been called. */ - exit(1); - } + if (strcmp(str, "MULTIPLE") == 0 || strcmp(str, "multiple") == 0) { + threadLevel = MPI_THREAD_MULTIPLE; + } + else if (strcmp(str, "SERIALIZED") == 0 || strcmp(str, "serialized") == 0) { + threadLevel = MPI_THREAD_SERIALIZED; + } + else if (strcmp(str, "FUNNELED") == 0 || strcmp(str, "funneled") == 0) { + threadLevel = MPI_THREAD_FUNNELED; + } + else if (strcmp(str, "SINGLE") == 0 || strcmp(str, "single") == 0) { + threadLevel = MPI_THREAD_SINGLE; + } + else { + fprintf(stderr, "Unrecognized thread level %s\n", str); + /* Use exit since MPI_Init/Init_thread has not been called. */ + exit(1); + } } - MTest_Init_thread( argc, argv, threadLevel, &provided ); + MTest_Init_thread(argc, argv, threadLevel, &provided); #else /* If the MPI_VERSION is 1, there is no MPI_THREAD_xxx defined */ - MTest_Init_thread( argc, argv, 0, &provided ); -#endif + MTest_Init_thread(argc, argv, 0, &provided); +#endif } /* - Finalize MTest. errs is the number of errors on the calling process; + Finalize MTest. errs is the number of errors on the calling process; this routine will write the total number of errors over all of MPI_COMM_WORLD to the process with rank zero, or " No Errors". It does *not* finalize MPI. */ -void MTest_Finalize( int errs ) +void MTest_Finalize(int errs) { int rank, toterrs, merr; - merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank ); - if (merr) MTestPrintError( merr ); + merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank); + if (merr) + MTestPrintError(merr); - merr = MPI_Reduce( &errs, &toterrs, 1, MPI_INT, MPI_SUM, - 0, MPI_COMM_WORLD ); - if (merr) MTestPrintError( merr ); + merr = MPI_Reduce(&errs, &toterrs, 1, MPI_INT, MPI_SUM, 0, MPI_COMM_WORLD); + if (merr) + MTestPrintError(merr); if (rank == 0) { - if (toterrs) { - printf( " Found %d errors\n", toterrs ); - } - else { - printf( " No Errors\n" ); - } - fflush( stdout ); + if (toterrs) { + printf(" Found %d errors\n", toterrs); + } + else { + printf(" No Errors\n"); + } + fflush(stdout); } - + if (SMPI_VARGET_GLOBAL(usageOutput)) - MTestResourceSummary( stdout ); + MTestResourceSummary(stdout); /* Clean up any persistent objects that we allocated */ MTestRMACleanup(); } + /* ------------------------------------------------------------------------ */ -/* This routine may be used instead of "return 0;" at the end of main; - it allows the program to use the return value to signal success or failure. +/* This routine may be used instead of "return 0;" at the end of main; + it allows the program to use the return value to signal success or failure. */ -int MTestReturnValue( int errors ) +int MTestReturnValue(int errors) { - if (SMPI_VARGET_GLOBAL(returnWithVal)) return errors ? 1 : 0; + if (SMPI_VARGET_GLOBAL(returnWithVal)) + return errors ? 1 : 0; return 0; } + /* ------------------------------------------------------------------------ */ /* * Miscellaneous utilities, particularly to eliminate OS dependencies * from the tests. - * MTestSleep( seconds ) + * MTestSleep(seconds) */ #ifdef HAVE_WINDOWS_H #include -void MTestSleep( int sec ) +void MTestSleep(int sec) { - Sleep( 1000 * sec ); + Sleep(1000 * sec); } #else #include -void MTestSleep( int sec ) -{ - sleep( sec ); -} -#endif - -/* - * Datatypes - * - * Eventually, this could read a description of a file. For now, we hard - * code the choices. - * - * Each kind of datatype has the following functions: - * MTestTypeXXXInit - Initialize a send buffer for that type - * MTestTypeXXXInitRecv - Initialize a receive buffer for that type - * MTestTypeXXXFree - Free any buffers associate with that type - * MTestTypeXXXCheckbuf - Check that the buffer contains the expected data - * These routines work with (nearly) any datatype that is of type XXX, - * allowing the test codes to create a variety of contiguous, vector, and - * indexed types, then test them by calling these routines. - * - * Available types (for the XXX) are - * Contig - Simple contiguous buffers - * Vector - Simple strided "vector" type - * Indexed - Indexed datatype. Only for a count of 1 instance of the - * datatype - */ -SMPI_VARINIT_GLOBAL_AND_SET(datatype_index, int, 0); - -/* ------------------------------------------------------------------------ */ -/* Datatype routines for contiguous datatypes */ -/* ------------------------------------------------------------------------ */ -/* - * Setup contiguous buffers of n copies of a datatype. - */ -static void *MTestTypeContigInit( MTestDatatype *mtype ) -{ - MPI_Aint size; - int merr; - - if (mtype->count > 0) { - signed char *p; - int i, totsize; - merr = MPI_Type_extent( mtype->datatype, &size ); - if (merr) MTestPrintError( merr ); - totsize = size * mtype->count; - if (!mtype->buf) { - mtype->buf = (void *) malloc( totsize ); - } - p = (signed char *)(mtype->buf); - if (!p) { - /* Error - out of memory */ - MTestError( "Out of memory in type buffer init" ); - } - for (i=0; ibuf) { - free( mtype->buf ); - } - mtype->buf = 0; - } - return mtype->buf; -} - -/* - * Setup contiguous buffers of n copies of a datatype. Initialize for - * reception (e.g., set initial data to detect failure) - */ -static void *MTestTypeContigInitRecv( MTestDatatype *mtype ) -{ - MPI_Aint size; - int merr; - - if (mtype->count > 0) { - signed char *p; - int i, totsize; - merr = MPI_Type_extent( mtype->datatype, &size ); - if (merr) MTestPrintError( merr ); - totsize = size * mtype->count; - if (!mtype->buf) { - mtype->buf = (void *) malloc( totsize ); - } - p = (signed char *)(mtype->buf); - if (!p) { - /* Error - out of memory */ - MTestError( "Out of memory in type buffer init" ); - } - for (i=0; ibuf) { - free( mtype->buf ); - } - mtype->buf = 0; - } - return mtype->buf; -} -static void *MTestTypeContigFree( MTestDatatype *mtype ) -{ - if (mtype->buf) { - free( mtype->buf ); - mtype->buf = 0; - } - return 0; -} -static int MTestTypeContigCheckbuf( MTestDatatype *mtype ) -{ - unsigned char *p; - unsigned char expected; - int i, totsize, err = 0, merr; - MPI_Aint size; - - p = (unsigned char *)mtype->buf; - if (p) { - merr = MPI_Type_extent( mtype->datatype, &size ); - if (merr) MTestPrintError( merr ); - totsize = size * mtype->count; - for (i=0; iprintErrors && err < 10) { - printf( "Data expected = %x but got p[%d] = %x\n", - expected, i, p[i] ); - fflush( stdout ); - } - } - } - } - return err; -} - -/* ------------------------------------------------------------------------ */ -/* Datatype routines for vector datatypes */ -/* ------------------------------------------------------------------------ */ - -static void *MTestTypeVectorInit( MTestDatatype *mtype ) -{ - MPI_Aint size; - int merr; - - if (mtype->count > 0) { - unsigned char *p; - int i, j, k, nc, totsize; - - merr = MPI_Type_extent( mtype->datatype, &size ); - if (merr) MTestPrintError( merr ); - totsize = mtype->count * size; - if (!mtype->buf) { - mtype->buf = (void *) malloc( totsize ); - } - p = (unsigned char *)(mtype->buf); - if (!p) { - /* Error - out of memory */ - MTestError( "Out of memory in type buffer init" ); - } - - /* First, set to -1 */ - for (i=0; icount; k++) { - /* For each element (block) */ - for (i=0; inelm; i++) { - /* For each value */ - for (j=0; jblksize; j++) { - p[j] = (0xff ^ (nc & 0xff)); - nc++; - } - p += mtype->stride; - } - } - } - else { - mtype->buf = 0; - } - return mtype->buf; -} - -static void *MTestTypeVectorFree( MTestDatatype *mtype ) -{ - if (mtype->buf) { - free( mtype->buf ); - mtype->buf = 0; - } - return 0; -} - -/* ------------------------------------------------------------------------ */ -/* Datatype routines for indexed block datatypes */ -/* ------------------------------------------------------------------------ */ - -/* - * Setup a buffer for one copy of an indexed datatype. - */ -static void *MTestTypeIndexedInit( MTestDatatype *mtype ) -{ - MPI_Aint totsize; - int merr; - - if (mtype->count > 1) { - MTestError( "This datatype is supported only for a single count" ); - } - if (mtype->count == 1) { - signed char *p; - int i, k, offset, j; - - /* Allocate the send/recv buffer */ - merr = MPI_Type_extent( mtype->datatype, &totsize ); - if (merr) MTestPrintError( merr ); - if (!mtype->buf) { - mtype->buf = (void *) malloc( totsize ); - } - p = (signed char *)(mtype->buf); - if (!p) { - MTestError( "Out of memory in type buffer init\n" ); - } - /* Initialize the elements */ - /* First, set to -1 */ - for (i=0; inelm; i++) { - int b; - /* Compute the offset: */ - offset = mtype->displs[i] * mtype->basesize; - /* For each element in the block */ - for (b=0; bindex[i]; b++) { - for (j=0; jbasesize; j++) { - p[offset+j] = 0xff ^ (k++ & 0xff); - } - offset += mtype->basesize; - } - } - } - else { - /* count == 0 */ - if (mtype->buf) { - free( mtype->buf ); - } - mtype->buf = 0; - } - return mtype->buf; -} - -/* - * Setup indexed buffers for 1 copy of a datatype. Initialize for - * reception (e.g., set initial data to detect failure) - */ -static void *MTestTypeIndexedInitRecv( MTestDatatype *mtype ) +void MTestSleep(int sec) { - MPI_Aint totsize; - int merr; - - if (mtype->count > 1) { - MTestError( "This datatype is supported only for a single count" ); - } - if (mtype->count == 1) { - signed char *p; - int i; - merr = MPI_Type_extent( mtype->datatype, &totsize ); - if (merr) MTestPrintError( merr ); - if (!mtype->buf) { - mtype->buf = (void *) malloc( totsize ); - } - p = (signed char *)(mtype->buf); - if (!p) { - /* Error - out of memory */ - MTestError( "Out of memory in type buffer init\n" ); - } - for (i=0; ibuf) { - free( mtype->buf ); - } - mtype->buf = 0; - } - return mtype->buf; + sleep(sec); } - -static void *MTestTypeIndexedFree( MTestDatatype *mtype ) -{ - if (mtype->buf) { - free( mtype->buf ); - free( mtype->displs ); - free( mtype->index ); - mtype->buf = 0; - mtype->displs = 0; - mtype->index = 0; - } - return 0; -} - -static int MTestTypeIndexedCheckbuf( MTestDatatype *mtype ) -{ - unsigned char *p; - unsigned char expected; - int i, err = 0, merr; - MPI_Aint totsize; - - p = (unsigned char *)mtype->buf; - if (p) { - int j, k, offset; - merr = MPI_Type_extent( mtype->datatype, &totsize ); - if (merr) MTestPrintError( merr ); - - k = 0; - for (i=0; inelm; i++) { - int b; - /* Compute the offset: */ - offset = mtype->displs[i] * mtype->basesize; - for (b=0; bindex[i]; b++) { - for (j=0; jbasesize; j++) { - expected = (0xff ^ (k & 0xff)); - if (p[offset+j] != expected) { - err++; - if (mtype->printErrors && err < 10) { - printf( "Data expected = %x but got p[%d,%d] = %x\n", - expected, i,j, p[offset+j] ); - fflush( stdout ); - } - } - k++; - } - offset += mtype->basesize; - } - } - } - return err; -} - - -/* ------------------------------------------------------------------------ */ -/* Routines to select a datatype and associated buffer create/fill/check */ -/* routines */ -/* ------------------------------------------------------------------------ */ - -/* - Create a range of datatypes with a given count elements. - This uses a selection of types, rather than an exhaustive collection. - It allocates both send and receive types so that they can have the same - type signature (collection of basic types) but different type maps (layouts - in memory) - */ -int MTestGetDatatypes( MTestDatatype *sendtype, MTestDatatype *recvtype, - int count ) -{ - int merr; - int i; - - sendtype->InitBuf = 0; - sendtype->FreeBuf = 0; - sendtype->CheckBuf = 0; - sendtype->datatype = 0; - sendtype->isBasic = 0; - sendtype->printErrors = 0; - recvtype->InitBuf = 0; - recvtype->FreeBuf = 0; - - recvtype->CheckBuf = 0; - recvtype->datatype = 0; - recvtype->isBasic = 0; - recvtype->printErrors = 0; - - sendtype->buf = 0; - recvtype->buf = 0; - - /* Set the defaults for the message lengths */ - sendtype->count = count; - recvtype->count = count; - /* Use datatype_index to choose a datatype to use. If at the end of the - list, return 0 */ - switch (SMPI_VARGET_GLOBAL(datatype_index)) { - case 0: - sendtype->datatype = MPI_INT; - sendtype->isBasic = 1; - recvtype->datatype = MPI_INT; - recvtype->isBasic = 1; - break; - case 1: - sendtype->datatype = MPI_DOUBLE; - sendtype->isBasic = 1; - recvtype->datatype = MPI_DOUBLE; - recvtype->isBasic = 1; - break; - case 2: - sendtype->datatype = MPI_FLOAT_INT; - sendtype->isBasic = 1; - recvtype->datatype = MPI_FLOAT_INT; - recvtype->isBasic = 1; - break; - case 3: - merr = MPI_Type_dup( MPI_INT, &sendtype->datatype ); - if (merr) MTestPrintError( merr ); - merr = MPI_Type_set_name( sendtype->datatype, - (char*)"dup of MPI_INT" ); - if (merr) MTestPrintError( merr ); - merr = MPI_Type_dup( MPI_INT, &recvtype->datatype ); - if (merr) MTestPrintError( merr ); - merr = MPI_Type_set_name( recvtype->datatype, - (char*)"dup of MPI_INT" ); - if (merr) MTestPrintError( merr ); - /* dup'ed types are already committed if the original type - was committed (MPI-2, section 8.8) */ - break; - case 4: - /* vector send type and contiguous receive type */ - /* These sizes are in bytes (see the VectorInit code) */ - sendtype->stride = 3 * sizeof(int); - sendtype->blksize = sizeof(int); - sendtype->nelm = recvtype->count; - - merr = MPI_Type_vector( recvtype->count, 1, 3, MPI_INT, - &sendtype->datatype ); - if (merr) MTestPrintError( merr ); - merr = MPI_Type_commit( &sendtype->datatype ); - if (merr) MTestPrintError( merr ); - merr = MPI_Type_set_name( sendtype->datatype, - (char*)"int-vector" ); - if (merr) MTestPrintError( merr ); - sendtype->count = 1; - recvtype->datatype = MPI_INT; - recvtype->isBasic = 1; - sendtype->InitBuf = MTestTypeVectorInit; - recvtype->InitBuf = MTestTypeContigInitRecv; - sendtype->FreeBuf = MTestTypeVectorFree; - recvtype->FreeBuf = MTestTypeContigFree; - sendtype->CheckBuf = 0; - recvtype->CheckBuf = MTestTypeContigCheckbuf; - break; - - case 5: - /* Indexed send using many small blocks and contig receive */ - sendtype->blksize = sizeof(int); - sendtype->nelm = recvtype->count; - sendtype->basesize = sizeof(int); - sendtype->displs = (int *)malloc( sendtype->nelm * sizeof(int) ); - sendtype->index = (int *)malloc( sendtype->nelm * sizeof(int) ); - if (!sendtype->displs || !sendtype->index) { - MTestError( "Out of memory in type init\n" ); - } - /* Make the sizes larger (4 ints) to help push the total - size to over 256k in some cases, as the MPICH code as of - 10/1/06 used large internal buffers for packing non-contiguous - messages */ - for (i=0; inelm; i++) { - sendtype->index[i] = 4; - sendtype->displs[i] = 5*i; - } - merr = MPI_Type_indexed( sendtype->nelm, - sendtype->index, sendtype->displs, - MPI_INT, &sendtype->datatype ); - if (merr) MTestPrintError( merr ); - merr = MPI_Type_commit( &sendtype->datatype ); - if (merr) MTestPrintError( merr ); - merr = MPI_Type_set_name( sendtype->datatype, - (char*)"int-indexed(4-int)" ); - if (merr) MTestPrintError( merr ); - sendtype->count = 1; - sendtype->InitBuf = MTestTypeIndexedInit; - sendtype->FreeBuf = MTestTypeIndexedFree; - sendtype->CheckBuf = 0; - - recvtype->datatype = MPI_INT; - recvtype->isBasic = 1; - recvtype->count = count * 4; - recvtype->InitBuf = MTestTypeContigInitRecv; - recvtype->FreeBuf = MTestTypeContigFree; - recvtype->CheckBuf = MTestTypeContigCheckbuf; - break; - - case 6: - /* Indexed send using 2 large blocks and contig receive */ - sendtype->blksize = sizeof(int); - sendtype->nelm = 2; - sendtype->basesize = sizeof(int); - sendtype->displs = (int *)malloc( sendtype->nelm * sizeof(int) ); - sendtype->index = (int *)malloc( sendtype->nelm * sizeof(int) ); - if (!sendtype->displs || !sendtype->index) { - MTestError( "Out of memory in type init\n" ); - } - /* index -> block size */ - sendtype->index[0] = (recvtype->count + 1) / 2; - sendtype->displs[0] = 0; - sendtype->index[1] = recvtype->count - sendtype->index[0]; - sendtype->displs[1] = sendtype->index[0] + 1; - /* There is a deliberate gap here */ - - merr = MPI_Type_indexed( sendtype->nelm, - sendtype->index, sendtype->displs, - MPI_INT, &sendtype->datatype ); - if (merr) MTestPrintError( merr ); - merr = MPI_Type_commit( &sendtype->datatype ); - if (merr) MTestPrintError( merr ); - merr = MPI_Type_set_name( sendtype->datatype, - (char*)"int-indexed(2 blocks)" ); - if (merr) MTestPrintError( merr ); - sendtype->count = 1; - sendtype->InitBuf = MTestTypeIndexedInit; - sendtype->FreeBuf = MTestTypeIndexedFree; - sendtype->CheckBuf = 0; - - recvtype->datatype = MPI_INT; - recvtype->isBasic = 1; - recvtype->count = sendtype->index[0] + sendtype->index[1]; - recvtype->InitBuf = MTestTypeContigInitRecv; - recvtype->FreeBuf = MTestTypeContigFree; - recvtype->CheckBuf = MTestTypeContigCheckbuf; - break; - - case 7: - /* Indexed receive using many small blocks and contig send */ - recvtype->blksize = sizeof(int); - recvtype->nelm = recvtype->count; - recvtype->basesize = sizeof(int); - recvtype->displs = (int *)malloc( recvtype->nelm * sizeof(int) ); - recvtype->index = (int *)malloc( recvtype->nelm * sizeof(int) ); - if (!recvtype->displs || !recvtype->index) { - MTestError( "Out of memory in type recv init\n" ); - } - /* Make the sizes larger (4 ints) to help push the total - size to over 256k in some cases, as the MPICH code as of - 10/1/06 used large internal buffers for packing non-contiguous - messages */ - /* Note that there are gaps in the indexed type */ - for (i=0; inelm; i++) { - recvtype->index[i] = 4; - recvtype->displs[i] = 5*i; - } - merr = MPI_Type_indexed( recvtype->nelm, - recvtype->index, recvtype->displs, - MPI_INT, &recvtype->datatype ); - if (merr) MTestPrintError( merr ); - merr = MPI_Type_commit( &recvtype->datatype ); - if (merr) MTestPrintError( merr ); - merr = MPI_Type_set_name( recvtype->datatype, - (char*)"recv-int-indexed(4-int)" ); - if (merr) MTestPrintError( merr ); - recvtype->count = 1; - recvtype->InitBuf = MTestTypeIndexedInitRecv; - recvtype->FreeBuf = MTestTypeIndexedFree; - recvtype->CheckBuf = MTestTypeIndexedCheckbuf; - - sendtype->datatype = MPI_INT; - sendtype->isBasic = 1; - sendtype->count = count * 4; - sendtype->InitBuf = MTestTypeContigInit; - sendtype->FreeBuf = MTestTypeContigFree; - sendtype->CheckBuf = 0; - break; - - /* Less commonly used but still simple types */ - case 8: - sendtype->datatype = MPI_SHORT; - sendtype->isBasic = 1; - recvtype->datatype = MPI_SHORT; - recvtype->isBasic = 1; - break; - case 9: - sendtype->datatype = MPI_LONG; - sendtype->isBasic = 1; - recvtype->datatype = MPI_LONG; - recvtype->isBasic = 1; - break; - case 10: - sendtype->datatype = MPI_CHAR; - sendtype->isBasic = 1; - recvtype->datatype = MPI_CHAR; - recvtype->isBasic = 1; - break; - case 11: - sendtype->datatype = MPI_UINT64_T; - sendtype->isBasic = 1; - recvtype->datatype = MPI_UINT64_T; - recvtype->isBasic = 1; - break; - case 12: - sendtype->datatype = MPI_FLOAT; - sendtype->isBasic = 1; - recvtype->datatype = MPI_FLOAT; - recvtype->isBasic = 1; - break; - -#ifndef USE_STRICT_MPI - /* MPI_BYTE may only be used with MPI_BYTE in strict MPI */ - case 13: - sendtype->datatype = MPI_INT; - sendtype->isBasic = 1; - recvtype->datatype = MPI_BYTE; - recvtype->isBasic = 1; - recvtype->count *= sizeof(int); - break; #endif - default: - SMPI_VARGET_GLOBAL(datatype_index) = -1; - } - - if (!sendtype->InitBuf) { - sendtype->InitBuf = MTestTypeContigInit; - recvtype->InitBuf = MTestTypeContigInitRecv; - sendtype->FreeBuf = MTestTypeContigFree; - recvtype->FreeBuf = MTestTypeContigFree; - sendtype->CheckBuf = MTestTypeContigCheckbuf; - recvtype->CheckBuf = MTestTypeContigCheckbuf; - } - SMPI_VARGET_GLOBAL(datatype_index)++; - - if (SMPI_VARGET_GLOBAL(dbgflag) && SMPI_VARGET_GLOBAL(datatype_index) > 0) { - int typesize; - fprintf( stderr, "%d: sendtype is %s\n", SMPI_VARGET_GLOBAL(wrank), MTestGetDatatypeName( sendtype ) ); - merr = MPI_Type_size( sendtype->datatype, &typesize ); - if (merr) MTestPrintError( merr ); - fprintf( stderr, "%d: sendtype size = %d\n", SMPI_VARGET_GLOBAL(wrank), typesize ); - fprintf( stderr, "%d: recvtype is %s\n", SMPI_VARGET_GLOBAL(wrank), MTestGetDatatypeName( recvtype ) ); - merr = MPI_Type_size( recvtype->datatype, &typesize ); - if (merr) MTestPrintError( merr ); - fprintf( stderr, "%d: recvtype size = %d\n", SMPI_VARGET_GLOBAL(wrank), typesize ); - fflush( stderr ); - - } - else if (SMPI_VARGET_GLOBAL(verbose) && SMPI_VARGET_GLOBAL(datatype_index) > 0) { - printf( "Get new datatypes: send = %s, recv = %s\n", - MTestGetDatatypeName( sendtype ), - MTestGetDatatypeName( recvtype ) ); - fflush( stdout ); - } - - return SMPI_VARGET_GLOBAL(datatype_index); -} - -/* Reset the datatype index (start from the initial data type. - Note: This routine is rarely needed; MTestGetDatatypes automatically - starts over after the last available datatype is used. -*/ -void MTestResetDatatypes( void ) -{ - SMPI_VARGET_GLOBAL(datatype_index) = 0; -} -/* Return the index of the current datatype. This is rarely needed and - is provided mostly to enable debugging of the MTest package itself */ -int MTestGetDatatypeIndex( void ) -{ - return SMPI_VARGET_GLOBAL(datatype_index); -} - -/* Free the storage associated with a datatype */ -void MTestFreeDatatype( MTestDatatype *mtype ) -{ - int merr; - /* Invoke a datatype-specific free function to handle - both the datatype and the send/receive buffers */ - if (mtype->FreeBuf) { - (mtype->FreeBuf)( mtype ); - } - /* Free the datatype itself if it was created */ - if (!mtype->isBasic) { - merr = MPI_Type_free( &mtype->datatype ); - if (merr) MTestPrintError( merr ); - } -} -/* Check that a message was received correctly. Returns the number of - errors detected. Status may be NULL or MPI_STATUS_IGNORE */ -int MTestCheckRecv( MPI_Status *status, MTestDatatype *recvtype ) +/* Other mtest subfiles read debug setting using this function. */ +void MTestGetDbgInfo(int *_dbgflag, int *_verbose) { - int count; - int errs = 0, merr; - - if (status && status != MPI_STATUS_IGNORE) { - merr = MPI_Get_count( status, recvtype->datatype, &count ); - if (merr) MTestPrintError( merr ); - - /* Check count against expected count */ - if (count != recvtype->count) { - errs ++; - } - } - - /* Check received data */ - if (!errs && recvtype->CheckBuf( recvtype )) { - errs++; - } - return errs; + *_dbgflag = SMPI_VARGET_GLOBAL(dbgflag); + *_verbose = SMPI_VARGET_GLOBAL(verbose); } -/* This next routine uses a circular buffer of static name arrays just to - simplify the use of the routine */ -const char *MTestGetDatatypeName( MTestDatatype *dtype ) -{ - typedef char name_type[4][MPI_MAX_OBJECT_NAME]; - SMPI_VARINIT_STATIC(name, name_type); - SMPI_VARINIT_STATIC_AND_SET(sp, int, 0); - int rlen, merr; - - if (SMPI_VARGET_STATIC(sp) >= 4) SMPI_VARGET_STATIC(sp) = 0; - merr = MPI_Type_get_name( dtype->datatype, SMPI_VARGET_STATIC(name)[SMPI_VARGET_STATIC(sp)], &rlen ); - if (merr) MTestPrintError( merr ); - return (const char *)SMPI_VARGET_STATIC(name)[SMPI_VARGET_STATIC(sp)++]; -} /* ----------------------------------------------------------------------- */ -/* +/* * Create communicators. Use separate routines for inter and intra * communicators (there is a routine to give both) * Note that the routines may return MPI_COMM_NULL, so code should test for * that return value as well. - * + * */ -SMPI_VARINIT_GLOBAL_AND_SET(interCommIdx, int, 0); -SMPI_VARINIT_GLOBAL_AND_SET(intraCommIdx, int, 0); -SMPI_VARINIT_GLOBAL_AND_SET(intraCommName, const char *, 0); -SMPI_VARINIT_GLOBAL_AND_SET(interCommName, const char *, 0); +static int interCommIdx = 0; +static int intraCommIdx = 0; +static const char *intraCommName = 0; +static const char *interCommName = 0; -/* +/* * Get an intracommunicator with at least min_size members. If "allowSmaller" * is true, allow the communicator to be smaller than MPI_COMM_WORLD and * for this routine to return MPI_COMM_NULL for some values. Returns 0 if * no more communicators are available. */ -int MTestGetIntracommGeneral( MPI_Comm *comm, int min_size, int allowSmaller ) +int MTestGetIntracommGeneral(MPI_Comm * comm, int min_size, int allowSmaller) { int size, rank, merr; - int done2, done=0; + int done = 0; int isBasic = 0; /* The while loop allows us to skip communicators that are too small. - MPI_COMM_NULL is always considered large enough */ + * MPI_COMM_NULL is always considered large enough */ while (!done) { - isBasic = 0; - SMPI_VARGET_GLOBAL(intraCommName) = ""; - switch (SMPI_VARGET_GLOBAL(intraCommIdx)) { - case 0: - *comm = MPI_COMM_WORLD; - isBasic = 1; - SMPI_VARGET_GLOBAL(intraCommName) = "MPI_COMM_WORLD"; - break; - case 1: - /* dup of world */ - merr = MPI_Comm_dup(MPI_COMM_WORLD, comm ); - if (merr) MTestPrintError( merr ); - SMPI_VARGET_GLOBAL(intraCommName) = "Dup of MPI_COMM_WORLD"; - break; - case 2: - /* reverse ranks */ - merr = MPI_Comm_size( MPI_COMM_WORLD, &size ); - if (merr) MTestPrintError( merr ); - merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank ); - if (merr) MTestPrintError( merr ); - merr = MPI_Comm_split( MPI_COMM_WORLD, 0, size-rank, comm ); - if (merr) MTestPrintError( merr ); - SMPI_VARGET_GLOBAL(intraCommName) = "Rank reverse of MPI_COMM_WORLD"; - break; - case 3: - /* subset of world, with reversed ranks */ - merr = MPI_Comm_size( MPI_COMM_WORLD, &size ); - if (merr) MTestPrintError( merr ); - merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank ); - if (merr) MTestPrintError( merr ); - merr = MPI_Comm_split( MPI_COMM_WORLD, ((rank < size/2) ? 1 : MPI_UNDEFINED), - size-rank, comm ); - if (merr) MTestPrintError( merr ); - SMPI_VARGET_GLOBAL(intraCommName) = "Rank reverse of half of MPI_COMM_WORLD"; - break; - case 4: - *comm = MPI_COMM_SELF; - isBasic = 1; - SMPI_VARGET_GLOBAL(intraCommName) = "MPI_COMM_SELF"; - break; - - /* These next cases are communicators that include some - but not all of the processes */ - case 5: - case 6: - case 7: - case 8: - { - int newsize; - merr = MPI_Comm_size( MPI_COMM_WORLD, &size ); - if (merr) MTestPrintError( merr ); - newsize = size - (SMPI_VARGET_GLOBAL(intraCommIdx) - 4); - - if (allowSmaller && newsize >= min_size) { - merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank ); - if (merr) MTestPrintError( merr ); - merr = MPI_Comm_split( MPI_COMM_WORLD, rank < newsize, rank, - comm ); - if (merr) MTestPrintError( merr ); - if (rank >= newsize) { - merr = MPI_Comm_free( comm ); - if (merr) MTestPrintError( merr ); - *comm = MPI_COMM_NULL; - } - else { - SMPI_VARGET_GLOBAL(intraCommName) = "Split of WORLD"; - } - } - else { - /* Act like default */ - *comm = MPI_COMM_NULL; - SMPI_VARGET_GLOBAL(intraCommIdx) = -1; - } - } - break; - - /* Other ideas: dup of self, cart comm, graph comm */ - default: - *comm = MPI_COMM_NULL; - SMPI_VARGET_GLOBAL(intraCommIdx) = -1; - break; - } - - if (*comm != MPI_COMM_NULL) { - merr = MPI_Comm_size( *comm, &size ); - if (merr) MTestPrintError( merr ); - if (size >= min_size) - done = 1; - } + isBasic = 0; + intraCommName = ""; + switch (intraCommIdx) { + case 0: + *comm = MPI_COMM_WORLD; + isBasic = 1; + intraCommName = "MPI_COMM_WORLD"; + break; + case 1: + /* dup of world */ + merr = MPI_Comm_dup(MPI_COMM_WORLD, comm); + if (merr) + MTestPrintError(merr); + intraCommName = "Dup of MPI_COMM_WORLD"; + break; + case 2: + /* reverse ranks */ + merr = MPI_Comm_size(MPI_COMM_WORLD, &size); + if (merr) + MTestPrintError(merr); + merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank); + if (merr) + MTestPrintError(merr); + merr = MPI_Comm_split(MPI_COMM_WORLD, 0, size - rank, comm); + if (merr) + MTestPrintError(merr); + intraCommName = "Rank reverse of MPI_COMM_WORLD"; + break; + case 3: + /* subset of world, with reversed ranks */ + merr = MPI_Comm_size(MPI_COMM_WORLD, &size); + if (merr) + MTestPrintError(merr); + merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank); + if (merr) + MTestPrintError(merr); + merr = MPI_Comm_split(MPI_COMM_WORLD, ((rank < size / 2) ? 1 : MPI_UNDEFINED), + size - rank, comm); + if (merr) + MTestPrintError(merr); + intraCommName = "Rank reverse of half of MPI_COMM_WORLD"; + break; + case 4: + *comm = MPI_COMM_SELF; + isBasic = 1; + intraCommName = "MPI_COMM_SELF"; + break; + case 5: + { +#if MTEST_HAVE_MIN_MPI_VERSION(3,0) + /* Dup of the world using MPI_Intercomm_merge */ + int rleader, isLeft; + MPI_Comm local_comm, inter_comm; + MPI_Comm_size(MPI_COMM_WORLD, &size); + MPI_Comm_rank(MPI_COMM_WORLD, &rank); + if (size > 1) { + merr = MPI_Comm_split(MPI_COMM_WORLD, (rank < size / 2), rank, &local_comm); + if (merr) + MTestPrintError(merr); + if (rank == 0) { + rleader = size / 2; + } + else if (rank == size / 2) { + rleader = 0; + } + else { + rleader = -1; + } + isLeft = rank < size / 2; + merr = + MPI_Intercomm_create(local_comm, 0, MPI_COMM_WORLD, rleader, 99, + &inter_comm); + if (merr) + MTestPrintError(merr); + merr = MPI_Intercomm_merge(inter_comm, isLeft, comm); + if (merr) + MTestPrintError(merr); + MPI_Comm_free(&inter_comm); + MPI_Comm_free(&local_comm); + intraCommName = "Dup of WORLD created by MPI_Intercomm_merge"; + } + else { + *comm = MPI_COMM_NULL; + } + } + break; + case 6: + { + /* Even of the world using MPI_Comm_create_group */ + int i; + MPI_Group world_group, even_group; + int *excl = NULL; + + MPI_Comm_size(MPI_COMM_WORLD, &size); + MPI_Comm_rank(MPI_COMM_WORLD, &rank); + if (allowSmaller && (size + 1) / 2 >= min_size) { + /* exclude the odd ranks */ + excl = malloc((size / 2) * sizeof(int)); + for (i = 0; i < size / 2; i++) + excl[i] = (2 * i) + 1; + + MPI_Comm_group(MPI_COMM_WORLD, &world_group); + MPI_Group_excl(world_group, size / 2, excl, &even_group); + MPI_Group_free(&world_group); + free(excl); + + if (rank % 2 == 0) { + /* Even processes create a comm. for themselves */ + MPI_Comm_create_group(MPI_COMM_WORLD, even_group, 0, comm); + intraCommName = "Even of WORLD created by MPI_Comm_create_group"; + } + else { + *comm = MPI_COMM_NULL; + } + + MPI_Group_free(&even_group); + } + else { + *comm = MPI_COMM_NULL; + } +#else + *comm = MPI_COMM_NULL; +#endif + } + break; + case 7: + { + /* High half of the world using MPI_Comm_create */ + int ranges[1][3]; + MPI_Group world_group, high_group; + MPI_Comm_size(MPI_COMM_WORLD, &size); + MPI_Comm_rank(MPI_COMM_WORLD, &rank); + ranges[0][0] = size / 2; + ranges[0][1] = size - 1; + ranges[0][2] = 1; + + if (allowSmaller && (size + 1) / 2 >= min_size) { + MPI_Comm_group(MPI_COMM_WORLD, &world_group); + merr = MPI_Group_range_incl(world_group, 1, ranges, &high_group); + if (merr) + MTestPrintError(merr); + merr = MPI_Comm_create(MPI_COMM_WORLD, high_group, comm); + if (merr) + MTestPrintError(merr); + MPI_Group_free(&world_group); + MPI_Group_free(&high_group); + intraCommName = "High half of WORLD created by MPI_Comm_create"; + } + else { + *comm = MPI_COMM_NULL; + } + } + break; + /* These next cases are communicators that include some + * but not all of the processes */ + case 8: + case 9: + case 10: + case 11: + { + int newsize; + merr = MPI_Comm_size(MPI_COMM_WORLD, &size); + if (merr) + MTestPrintError(merr); + newsize = size - (intraCommIdx - 7); + + if (allowSmaller && newsize >= min_size) { + merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank); + if (merr) + MTestPrintError(merr); + merr = MPI_Comm_split(MPI_COMM_WORLD, rank < newsize, rank, comm); + if (merr) + MTestPrintError(merr); + if (rank >= newsize) { + merr = MPI_Comm_free(comm); + if (merr) + MTestPrintError(merr); + *comm = MPI_COMM_NULL; + } + else { + intraCommName = "Split of WORLD"; + } + } + else { + /* Act like default */ + *comm = MPI_COMM_NULL; + intraCommIdx = -1; + } + } + break; + + /* Other ideas: dup of self, cart comm, graph comm */ + default: + *comm = MPI_COMM_NULL; + intraCommIdx = -1; + break; + } + + if (*comm != MPI_COMM_NULL) { + merr = MPI_Comm_size(*comm, &size); + if (merr) + MTestPrintError(merr); + if (size >= min_size) + done = 1; + } else { - SMPI_VARGET_GLOBAL(intraCommName) = "MPI_COMM_NULL"; + intraCommName = "MPI_COMM_NULL"; isBasic = 1; done = 1; } -done2=done; + /* we are only done if all processes are done */ - MPI_Allreduce(&done2, &done, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD); + MPI_Allreduce(MPI_IN_PLACE, &done, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD); /* Advance the comm index whether we are done or not, otherwise we could * spin forever trying to allocate a too-small communicator over and * over again. */ - SMPI_VARGET_GLOBAL(intraCommIdx)++; + intraCommIdx++; if (!done && !isBasic && *comm != MPI_COMM_NULL) { /* avoid leaking communicators */ merr = MPI_Comm_free(comm); - if (merr) MTestPrintError(merr); + if (merr) + MTestPrintError(merr); } } - return SMPI_VARGET_GLOBAL(intraCommIdx); + return intraCommIdx; } -/* +/* * Get an intracommunicator with at least min_size members. */ -int MTestGetIntracomm( MPI_Comm *comm, int min_size ) +int MTestGetIntracomm(MPI_Comm * comm, int min_size) { - return MTestGetIntracommGeneral( comm, min_size, 0 ); + return MTestGetIntracommGeneral(comm, min_size, 0); } /* Return the name of an intra communicator */ -const char *MTestGetIntracommName( void ) +const char *MTestGetIntracommName(void) { - return SMPI_VARGET_GLOBAL(intraCommName); + return intraCommName; } -/* - * Return an intercomm; set isLeftGroup to 1 if the calling process is +/* + * Return an intercomm; set isLeftGroup to 1 if the calling process is * a member of the "left" group. */ -int MTestGetIntercomm( MPI_Comm *comm, int *isLeftGroup, int min_size ) +int MTestGetIntercomm(MPI_Comm * comm, int *isLeftGroup, int min_size) { int size, rank, remsize, merr; - int done=0; - MPI_Comm mcomm = MPI_COMM_NULL; + int done = 0; + MPI_Comm mcomm = MPI_COMM_NULL; MPI_Comm mcomm2 = MPI_COMM_NULL; int rleader; /* The while loop allows us to skip communicators that are too small. - MPI_COMM_NULL is always considered large enough. The size is - the sum of the sizes of the local and remote groups */ + * MPI_COMM_NULL is always considered large enough. The size is + * the sum of the sizes of the local and remote groups */ while (!done) { *comm = MPI_COMM_NULL; *isLeftGroup = 0; - SMPI_VARGET_GLOBAL(interCommName) = "MPI_COMM_NULL"; - - switch (SMPI_VARGET_GLOBAL(interCommIdx)) { - case 0: - /* Split comm world in half */ - merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank ); - if (merr) MTestPrintError( merr ); - merr = MPI_Comm_size( MPI_COMM_WORLD, &size ); - if (merr) MTestPrintError( merr ); - if (size > 1) { - merr = MPI_Comm_split( MPI_COMM_WORLD, (rank < size/2), rank, - &mcomm ); - if (merr) MTestPrintError( merr ); - if (rank == 0) { - rleader = size/2; - } - else if (rank == size/2) { - rleader = 0; - } - else { - /* Remote leader is signficant only for the processes - designated local leaders */ - rleader = -1; - } - *isLeftGroup = rank < size/2; - merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader, - 12345, comm ); - if (merr) MTestPrintError( merr ); - SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD"; - } - else - *comm = MPI_COMM_NULL; - break; - case 1: - /* Split comm world in to 1 and the rest */ - merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank ); - if (merr) MTestPrintError( merr ); - merr = MPI_Comm_size( MPI_COMM_WORLD, &size ); - if (merr) MTestPrintError( merr ); - if (size > 1) { - merr = MPI_Comm_split( MPI_COMM_WORLD, rank == 0, rank, - &mcomm ); - if (merr) MTestPrintError( merr ); - if (rank == 0) { - rleader = 1; - } - else if (rank == 1) { - rleader = 0; - } - else { - /* Remote leader is signficant only for the processes - designated local leaders */ - rleader = -1; - } - *isLeftGroup = rank == 0; - merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, - rleader, 12346, comm ); - if (merr) MTestPrintError( merr ); - SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD into 1, rest"; - } - else - *comm = MPI_COMM_NULL; - break; - - case 2: - /* Split comm world in to 2 and the rest */ - merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank ); - if (merr) MTestPrintError( merr ); - merr = MPI_Comm_size( MPI_COMM_WORLD, &size ); - if (merr) MTestPrintError( merr ); - if (size > 3) { - merr = MPI_Comm_split( MPI_COMM_WORLD, rank < 2, rank, - &mcomm ); - if (merr) MTestPrintError( merr ); - if (rank == 0) { - rleader = 2; - } - else if (rank == 2) { - rleader = 0; - } - else { - /* Remote leader is signficant only for the processes - designated local leaders */ - rleader = -1; - } - *isLeftGroup = rank < 2; - merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, - rleader, 12347, comm ); - if (merr) MTestPrintError( merr ); - SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD into 2, rest"; - } - else - *comm = MPI_COMM_NULL; - break; - - case 3: - /* Split comm world in half, then dup */ - merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank ); - if (merr) MTestPrintError( merr ); - merr = MPI_Comm_size( MPI_COMM_WORLD, &size ); - if (merr) MTestPrintError( merr ); - if (size > 1) { - merr = MPI_Comm_split( MPI_COMM_WORLD, (rank < size/2), rank, - &mcomm ); - if (merr) MTestPrintError( merr ); - if (rank == 0) { - rleader = size/2; - } - else if (rank == size/2) { - rleader = 0; - } - else { - /* Remote leader is signficant only for the processes - designated local leaders */ - rleader = -1; - } - *isLeftGroup = rank < size/2; - merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader, - 12345, comm ); - if (merr) MTestPrintError( merr ); + interCommName = "MPI_COMM_NULL"; + + switch (interCommIdx) { + case 0: + /* Split comm world in half */ + merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank); + if (merr) + MTestPrintError(merr); + merr = MPI_Comm_size(MPI_COMM_WORLD, &size); + if (merr) + MTestPrintError(merr); + if (size > 1) { + merr = MPI_Comm_split(MPI_COMM_WORLD, (rank < size / 2), rank, &mcomm); + if (merr) + MTestPrintError(merr); + if (rank == 0) { + rleader = size / 2; + } + else if (rank == size / 2) { + rleader = 0; + } + else { + /* Remote leader is signficant only for the processes + * designated local leaders */ + rleader = -1; + } + *isLeftGroup = rank < size / 2; + merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12345, comm); + if (merr) + MTestPrintError(merr); + interCommName = "Intercomm by splitting MPI_COMM_WORLD"; + } + else + *comm = MPI_COMM_NULL; + break; + case 1: + /* Split comm world in to 1 and the rest */ + merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank); + if (merr) + MTestPrintError(merr); + merr = MPI_Comm_size(MPI_COMM_WORLD, &size); + if (merr) + MTestPrintError(merr); + if (size > 1) { + merr = MPI_Comm_split(MPI_COMM_WORLD, rank == 0, rank, &mcomm); + if (merr) + MTestPrintError(merr); + if (rank == 0) { + rleader = 1; + } + else if (rank == 1) { + rleader = 0; + } + else { + /* Remote leader is signficant only for the processes + * designated local leaders */ + rleader = -1; + } + *isLeftGroup = rank == 0; + merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12346, comm); + if (merr) + MTestPrintError(merr); + interCommName = "Intercomm by splitting MPI_COMM_WORLD into 1, rest"; + } + else + *comm = MPI_COMM_NULL; + break; + + case 2: + /* Split comm world in to 2 and the rest */ + merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank); + if (merr) + MTestPrintError(merr); + merr = MPI_Comm_size(MPI_COMM_WORLD, &size); + if (merr) + MTestPrintError(merr); + if (size > 3) { + merr = MPI_Comm_split(MPI_COMM_WORLD, rank < 2, rank, &mcomm); + if (merr) + MTestPrintError(merr); + if (rank == 0) { + rleader = 2; + } + else if (rank == 2) { + rleader = 0; + } + else { + /* Remote leader is signficant only for the processes + * designated local leaders */ + rleader = -1; + } + *isLeftGroup = rank < 2; + merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12347, comm); + if (merr) + MTestPrintError(merr); + interCommName = "Intercomm by splitting MPI_COMM_WORLD into 2, rest"; + } + else + *comm = MPI_COMM_NULL; + break; + + case 3: + /* Split comm world in half, then dup */ + merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank); + if (merr) + MTestPrintError(merr); + merr = MPI_Comm_size(MPI_COMM_WORLD, &size); + if (merr) + MTestPrintError(merr); + if (size > 1) { + merr = MPI_Comm_split(MPI_COMM_WORLD, (rank < size / 2), rank, &mcomm); + if (merr) + MTestPrintError(merr); + if (rank == 0) { + rleader = size / 2; + } + else if (rank == size / 2) { + rleader = 0; + } + else { + /* Remote leader is signficant only for the processes + * designated local leaders */ + rleader = -1; + } + *isLeftGroup = rank < size / 2; + merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12345, comm); + if (merr) + MTestPrintError(merr); /* avoid leaking after assignment below */ - merr = MPI_Comm_free( &mcomm ); - if (merr) MTestPrintError( merr ); - - /* now dup, some bugs only occur for dup's of intercomms */ - mcomm = *comm; - merr = MPI_Comm_dup(mcomm, comm); - if (merr) MTestPrintError( merr ); - SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD then dup'ing"; - } - else - *comm = MPI_COMM_NULL; - break; - - case 4: - /* Split comm world in half, form intercomm, then split that intercomm */ - merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank ); - if (merr) MTestPrintError( merr ); - merr = MPI_Comm_size( MPI_COMM_WORLD, &size ); - if (merr) MTestPrintError( merr ); - if (size > 1) { - merr = MPI_Comm_split( MPI_COMM_WORLD, (rank < size/2), rank, - &mcomm ); - if (merr) MTestPrintError( merr ); - if (rank == 0) { - rleader = size/2; - } - else if (rank == size/2) { - rleader = 0; - } - else { - /* Remote leader is signficant only for the processes - designated local leaders */ - rleader = -1; - } - *isLeftGroup = rank < size/2; - merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader, - 12345, comm ); - if (merr) MTestPrintError( merr ); + merr = MPI_Comm_free(&mcomm); + if (merr) + MTestPrintError(merr); + + /* now dup, some bugs only occur for dup's of intercomms */ + mcomm = *comm; + merr = MPI_Comm_dup(mcomm, comm); + if (merr) + MTestPrintError(merr); + interCommName = "Intercomm by splitting MPI_COMM_WORLD then dup'ing"; + } + else + *comm = MPI_COMM_NULL; + break; + + case 4: + /* Split comm world in half, form intercomm, then split that intercomm */ + merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank); + if (merr) + MTestPrintError(merr); + merr = MPI_Comm_size(MPI_COMM_WORLD, &size); + if (merr) + MTestPrintError(merr); + if (size > 1) { + merr = MPI_Comm_split(MPI_COMM_WORLD, (rank < size / 2), rank, &mcomm); + if (merr) + MTestPrintError(merr); + if (rank == 0) { + rleader = size / 2; + } + else if (rank == size / 2) { + rleader = 0; + } + else { + /* Remote leader is signficant only for the processes + * designated local leaders */ + rleader = -1; + } + *isLeftGroup = rank < size / 2; + merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12345, comm); + if (merr) + MTestPrintError(merr); /* avoid leaking after assignment below */ - merr = MPI_Comm_free( &mcomm ); - if (merr) MTestPrintError( merr ); - - /* now split, some bugs only occur for splits of intercomms */ - mcomm = *comm; - rank = MPI_Comm_rank(mcomm, &rank); - if (merr) MTestPrintError( merr ); - /* this split is effectively a dup but tests the split code paths */ - merr = MPI_Comm_split(mcomm, 0, rank, comm); - if (merr) MTestPrintError( merr ); - SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD then then splitting again"; - } - else - *comm = MPI_COMM_NULL; - break; - - case 5: + merr = MPI_Comm_free(&mcomm); + if (merr) + MTestPrintError(merr); + + /* now split, some bugs only occur for splits of intercomms */ + mcomm = *comm; + merr = MPI_Comm_rank(mcomm, &rank); + if (merr) + MTestPrintError(merr); + /* this split is effectively a dup but tests the split code paths */ + merr = MPI_Comm_split(mcomm, 0, rank, comm); + if (merr) + MTestPrintError(merr); + interCommName = "Intercomm by splitting MPI_COMM_WORLD then then splitting again"; + } + else + *comm = MPI_COMM_NULL; + break; + + case 5: /* split comm world in half discarding rank 0 on the "left" * communicator, then form them into an intercommunicator */ - merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank ); - if (merr) MTestPrintError( merr ); - merr = MPI_Comm_size( MPI_COMM_WORLD, &size ); - if (merr) MTestPrintError( merr ); - if (size >= 4) { - int color = (rank < size/2 ? 0 : 1); + merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank); + if (merr) + MTestPrintError(merr); + merr = MPI_Comm_size(MPI_COMM_WORLD, &size); + if (merr) + MTestPrintError(merr); + if (size >= 4) { + int color = (rank < size / 2 ? 0 : 1); if (rank == 0) color = MPI_UNDEFINED; - merr = MPI_Comm_split( MPI_COMM_WORLD, color, rank, &mcomm ); - if (merr) MTestPrintError( merr ); - - if (rank == 1) { - rleader = size/2; - } - else if (rank == (size/2)) { - rleader = 1; - } - else { - /* Remote leader is signficant only for the processes - designated local leaders */ - rleader = -1; - } - *isLeftGroup = rank < size/2; - if (rank != 0) { /* 0's mcomm is MPI_COMM_NULL */ - merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader, 12345, comm ); - if (merr) MTestPrintError( merr ); + merr = MPI_Comm_split(MPI_COMM_WORLD, color, rank, &mcomm); + if (merr) + MTestPrintError(merr); + + if (rank == 1) { + rleader = size / 2; + } + else if (rank == (size / 2)) { + rleader = 1; + } + else { + /* Remote leader is signficant only for the processes + * designated local leaders */ + rleader = -1; } - SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD (discarding rank 0 in the left group) then MPI_Intercomm_create'ing"; + *isLeftGroup = rank < size / 2; + if (rank != 0) { /* 0's mcomm is MPI_COMM_NULL */ + merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12345, comm); + if (merr) + MTestPrintError(merr); + } + interCommName = + "Intercomm by splitting MPI_COMM_WORLD (discarding rank 0 in the left group) then MPI_Intercomm_create'ing"; } else { *comm = MPI_COMM_NULL; @@ -1355,71 +791,84 @@ int MTestGetIntercomm( MPI_Comm *comm, int *isLeftGroup, int min_size ) /* Split comm world in half then form them into an * intercommunicator. Then discard rank 0 from each group of the * intercomm via MPI_Comm_create. */ - merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank ); - if (merr) MTestPrintError( merr ); - merr = MPI_Comm_size( MPI_COMM_WORLD, &size ); - if (merr) MTestPrintError( merr ); - if (size >= 4) { + merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank); + if (merr) + MTestPrintError(merr); + merr = MPI_Comm_size(MPI_COMM_WORLD, &size); + if (merr) + MTestPrintError(merr); + if (size >= 4) { MPI_Group oldgroup, newgroup; int ranks[1]; - int color = (rank < size/2 ? 0 : 1); - - merr = MPI_Comm_split( MPI_COMM_WORLD, color, rank, &mcomm ); - if (merr) MTestPrintError( merr ); - - if (rank == 0) { - rleader = size/2; - } - else if (rank == (size/2)) { - rleader = 0; - } - else { - /* Remote leader is signficant only for the processes - designated local leaders */ - rleader = -1; - } - *isLeftGroup = rank < size/2; - merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader, 12345, &mcomm2 ); - if (merr) MTestPrintError( merr ); + int color = (rank < size / 2 ? 0 : 1); + + merr = MPI_Comm_split(MPI_COMM_WORLD, color, rank, &mcomm); + if (merr) + MTestPrintError(merr); + + if (rank == 0) { + rleader = size / 2; + } + else if (rank == (size / 2)) { + rleader = 0; + } + else { + /* Remote leader is signficant only for the processes + * designated local leaders */ + rleader = -1; + } + *isLeftGroup = rank < size / 2; + merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12345, &mcomm2); + if (merr) + MTestPrintError(merr); /* We have an intercomm between the two halves of comm world. Now create * a new intercomm that removes rank 0 on each side. */ merr = MPI_Comm_group(mcomm2, &oldgroup); - if (merr) MTestPrintError( merr ); + if (merr) + MTestPrintError(merr); ranks[0] = 0; merr = MPI_Group_excl(oldgroup, 1, ranks, &newgroup); - if (merr) MTestPrintError( merr ); + if (merr) + MTestPrintError(merr); merr = MPI_Comm_create(mcomm2, newgroup, comm); - if (merr) MTestPrintError( merr ); + if (merr) + MTestPrintError(merr); merr = MPI_Group_free(&oldgroup); - if (merr) MTestPrintError( merr ); + if (merr) + MTestPrintError(merr); merr = MPI_Group_free(&newgroup); - if (merr) MTestPrintError( merr ); + if (merr) + MTestPrintError(merr); - SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD then discarding 0 ranks with MPI_Comm_create"; + interCommName = + "Intercomm by splitting MPI_COMM_WORLD then discarding 0 ranks with MPI_Comm_create"; } else { *comm = MPI_COMM_NULL; } break; - default: - *comm = MPI_COMM_NULL; - SMPI_VARGET_GLOBAL(interCommIdx) = -1; - break; - } - - if (*comm != MPI_COMM_NULL) { - merr = MPI_Comm_size( *comm, &size ); - if (merr) MTestPrintError( merr ); - merr = MPI_Comm_remote_size( *comm, &remsize ); - if (merr) MTestPrintError( merr ); - if (size + remsize >= min_size) done = 1; - } - else { - SMPI_VARGET_GLOBAL(interCommName) = "MPI_COMM_NULL"; - done = 1; + default: + *comm = MPI_COMM_NULL; + interCommIdx = -1; + break; + } + + if (*comm != MPI_COMM_NULL) { + merr = MPI_Comm_size(*comm, &size); + if (merr) + MTestPrintError(merr); + merr = MPI_Comm_remote_size(*comm, &remsize); + if (merr) + MTestPrintError(merr); + if (size + remsize >= min_size) + done = 1; + } + else { + interCommName = "MPI_COMM_NULL"; + done = 1; } /* we are only done if all processes are done */ @@ -1428,52 +877,172 @@ int MTestGetIntercomm( MPI_Comm *comm, int *isLeftGroup, int min_size ) /* Advance the comm index whether we are done or not, otherwise we could * spin forever trying to allocate a too-small communicator over and * over again. */ - SMPI_VARGET_GLOBAL(interCommIdx)++; + interCommIdx++; if (!done && *comm != MPI_COMM_NULL) { /* avoid leaking communicators */ merr = MPI_Comm_free(comm); - if (merr) MTestPrintError(merr); + if (merr) + MTestPrintError(merr); } /* cleanup for common temp objects */ if (mcomm != MPI_COMM_NULL) { merr = MPI_Comm_free(&mcomm); - if (merr) MTestPrintError( merr ); + if (merr) + MTestPrintError(merr); } if (mcomm2 != MPI_COMM_NULL) { merr = MPI_Comm_free(&mcomm2); - if (merr) MTestPrintError( merr ); + if (merr) + MTestPrintError(merr); } } - return SMPI_VARGET_GLOBAL(interCommIdx); + return interCommIdx; } + +int MTestTestIntercomm(MPI_Comm comm) +{ + int local_size, remote_size, rank, **bufs, *bufmem, rbuf[2], j; + int errs = 0, wrank, nsize; + char commname[MPI_MAX_OBJECT_NAME + 1]; + MPI_Request *reqs; + + MPI_Comm_rank(MPI_COMM_WORLD, &wrank); + MPI_Comm_size(comm, &local_size); + MPI_Comm_remote_size(comm, &remote_size); + MPI_Comm_rank(comm, &rank); + MPI_Comm_get_name(comm, commname, &nsize); + + MTestPrintfMsg(1, "Testing communication on intercomm '%s', remote_size=%d\n", + commname, remote_size); + + reqs = (MPI_Request *) malloc(remote_size * sizeof(MPI_Request)); + if (!reqs) { + printf("[%d] Unable to allocated %d requests for testing intercomm %s\n", + wrank, remote_size, commname); + errs++; + return errs; + } + bufs = (int **) malloc(remote_size * sizeof(int *)); + if (!bufs) { + printf("[%d] Unable to allocated %d int pointers for testing intercomm %s\n", + wrank, remote_size, commname); + errs++; + return errs; + } + bufmem = (int *) malloc(remote_size * 2 * sizeof(int)); + if (!bufmem) { + printf("[%d] Unable to allocated %d int data for testing intercomm %s\n", + wrank, 2 * remote_size, commname); + errs++; + return errs; + } + + /* Each process sends a message containing its own rank and the + * rank of the destination with a nonblocking send. Because we're using + * nonblocking sends, we need to use different buffers for each isend */ + /* NOTE: the send buffer access restriction was relaxed in MPI-2.2, although + * it doesn't really hurt to keep separate buffers for our purposes */ + for (j = 0; j < remote_size; j++) { + bufs[j] = &bufmem[2 * j]; + bufs[j][0] = rank; + bufs[j][1] = j; + MPI_Isend(bufs[j], 2, MPI_INT, j, 0, comm, &reqs[j]); + } + MTestPrintfMsg(2, "isends posted, about to recv\n"); + + for (j = 0; j < remote_size; j++) { + MPI_Recv(rbuf, 2, MPI_INT, j, 0, comm, MPI_STATUS_IGNORE); + if (rbuf[0] != j) { + printf("[%d] Expected rank %d but saw %d in %s\n", wrank, j, rbuf[0], commname); + errs++; + } + if (rbuf[1] != rank) { + printf("[%d] Expected target rank %d but saw %d from %d in %s\n", + wrank, rank, rbuf[1], j, commname); + errs++; + } + } + if (errs) + fflush(stdout); + + MTestPrintfMsg(2, "my recvs completed, about to waitall\n"); + MPI_Waitall(remote_size, reqs, MPI_STATUSES_IGNORE); + + free(reqs); + free(bufs); + free(bufmem); + + return errs; +} + +int MTestTestIntracomm(MPI_Comm comm) +{ + int i, errs = 0; + int size; + int in[16], out[16], sol[16]; + + MPI_Comm_size(comm, &size); + + /* Set input, output and sol-values */ + for (i = 0; i < 16; i++) { + in[i] = i; + out[i] = 0; + sol[i] = i * size; + } + MPI_Allreduce(in, out, 16, MPI_INT, MPI_SUM, comm); + + /* Test results */ + for (i = 0; i < 16; i++) { + if (sol[i] != out[i]) + errs++; + } + + return errs; +} + +int MTestTestComm(MPI_Comm comm) +{ + int is_inter; + + if (comm == MPI_COMM_NULL) + return 0; + + MPI_Comm_test_inter(comm, &is_inter); + + if (is_inter) + return MTestTestIntercomm(comm); + else + return MTestTestIntracomm(comm); +} + /* Return the name of an intercommunicator */ -const char *MTestGetIntercommName( void ) +const char *MTestGetIntercommName(void) { - return SMPI_VARGET_GLOBAL(interCommName); + return interCommName; } -/* Get a communicator of a given minimum size. Both intra and inter +/* Get a communicator of a given minimum size. Both intra and inter communicators are provided */ -int MTestGetComm( MPI_Comm *comm, int min_size ) +int MTestGetComm(MPI_Comm * comm, int min_size) { - int idx=0; - SMPI_VARINIT_STATIC_AND_SET(getinter, int, 0); - - if (!SMPI_VARGET_STATIC(getinter)) { - idx = MTestGetIntracomm( comm, min_size ); - if (idx == 0) { - SMPI_VARGET_STATIC(getinter) = 1; - } + int idx = 0; + static int getinter = 0; + + if (!getinter) { + idx = MTestGetIntracomm(comm, min_size); + if (idx == 0) { + getinter = 1; + } } - if (SMPI_VARGET_STATIC(getinter)) { - int isLeft; - idx = MTestGetIntercomm( comm, &isLeft, min_size ); - if (idx == 0) { - SMPI_VARGET_STATIC(getinter) = 0; - } + if (getinter) { + int isLeft; + idx = MTestGetIntercomm(comm, &isLeft, min_size); + if (idx == 0) { + getinter = 0; + } } return idx; @@ -1481,235 +1050,312 @@ int MTestGetComm( MPI_Comm *comm, int min_size ) /* Free a communicator. It may be called with a predefined communicator or MPI_COMM_NULL */ -void MTestFreeComm( MPI_Comm *comm ) +void MTestFreeComm(MPI_Comm * comm) { int merr; - if (*comm != MPI_COMM_WORLD && - *comm != MPI_COMM_SELF && - *comm != MPI_COMM_NULL) { - merr = MPI_Comm_free( comm ); - if (merr) MTestPrintError( merr ); + if (*comm != MPI_COMM_WORLD && *comm != MPI_COMM_SELF && *comm != MPI_COMM_NULL) { + merr = MPI_Comm_free(comm); + if (merr) + MTestPrintError(merr); } } /* ------------------------------------------------------------------------ */ -void MTestPrintError( int errcode ) +void MTestPrintError(int errcode) { int errclass, slen; char string[MPI_MAX_ERROR_STRING]; - - MPI_Error_class( errcode, &errclass ); - MPI_Error_string( errcode, string, &slen ); - printf( "Error class %d (%s)\n", errclass, string ); - fflush( stdout ); + + MPI_Error_class(errcode, &errclass); + MPI_Error_string(errcode, string, &slen); + printf("Error class %d (%s)\n", errclass, string); + fflush(stdout); } -void MTestPrintErrorMsg( const char msg[], int errcode ) + +void MTestPrintErrorMsg(const char msg[], int errcode) { int errclass, slen; char string[MPI_MAX_ERROR_STRING]; - - MPI_Error_class( errcode, &errclass ); - MPI_Error_string( errcode, string, &slen ); - printf( "%s: Error class %d (%s)\n", msg, errclass, string ); - fflush( stdout ); + + MPI_Error_class(errcode, &errclass); + MPI_Error_string(errcode, string, &slen); + printf("%s: Error class %d (%s)\n", msg, errclass, string); + fflush(stdout); } + /* ------------------------------------------------------------------------ */ -/* +/* If verbose output is selected and the level is at least that of the - value of the verbose flag, then perform printf( format, ... ); + value of the verbose flag, then perform printf(format, ...); */ -void MTestPrintfMsg( int level, const char format[], ... ) +void MTestPrintfMsg(int level, const char format[], ...) { va_list list; - if (SMPI_VARGET_GLOBAL(verbose) && level >= SMPI_VARGET_GLOBAL(verbose)) { - va_start(list,format); - vprintf( format, list ); - va_end(list); - fflush(stdout); + if (SMPI_VARGET_GLOBAL(verbose) && level <= SMPI_VARGET_GLOBAL(verbose)) { + va_start(list, format); + vprintf(format, list); + va_end(list); + fflush(stdout); } } + /* Fatal error. Report and exit */ -void MTestError( const char *msg ) +void MTestError(const char *msg) { - fprintf( stderr, "%s\n", msg ); - fflush( stderr ); - MPI_Abort( MPI_COMM_WORLD, 1 ); - exit(1); + fprintf(stderr, "%s\n", msg); + fflush(stderr); + MPI_Abort(MPI_COMM_WORLD, 1); } + /* ------------------------------------------------------------------------ */ -static void MTestResourceSummary( FILE *fp ) +static void MTestResourceSummary(FILE * fp) { #ifdef HAVE_GETRUSAGE struct rusage ru; - SMPI_VARINIT_STATIC_AND_SET(pfThreshold, int, -2); + static int pfThreshold = -2; int doOutput = 1; - if (getrusage( RUSAGE_SELF, &ru ) == 0) { - /* There is an option to generate output only when a resource - exceeds a threshold. To date, only page faults supported. */ - if (SMPI_VARGET_STATIC(pfThreshold) == -2) { - char *p = getenv("MPITEST_RUSAGE_PF"); - SMPI_VARGET_STATIC(pfThreshold) = -1; - if (p) { - SMPI_VARGET_STATIC(pfThreshold) = strtol( p, 0, 0 ); - } - } - if (SMPI_VARGET_STATIC(pfThreshold) > 0) { - doOutput = ru.ru_minflt > SMPI_VARGET_STATIC(pfThreshold); - } - if (doOutput) { - /* Cast values to long in case some system has defined them - as another integer type */ - fprintf( fp, "RUSAGE: max resident set = %ldKB\n", - (long)ru.ru_maxrss ); - fprintf( fp, "RUSAGE: page faults = %ld : %ld\n", - (long)ru.ru_minflt, (long)ru.ru_majflt ); - /* Not every Unix provides useful information for the xxrss fields */ - fprintf( fp, "RUSAGE: memory in text/data/stack = %ld : %ld : %ld\n", - (long)ru.ru_ixrss, (long)ru.ru_idrss, (long)ru.ru_isrss ); - fprintf( fp, "RUSAGE: I/O in and out = %ld : %ld\n", - (long)ru.ru_inblock, (long)ru.ru_oublock ); - fprintf( fp, "RUSAGE: context switch = %ld : %ld\n", - (long)ru.ru_nvcsw, (long)ru.ru_nivcsw ); - } + if (getrusage(RUSAGE_SELF, &ru) == 0) { + /* There is an option to generate output only when a resource + * exceeds a threshold. To date, only page faults supported. */ + if (pfThreshold == -2) { + char *p = getenv("MPITEST_RUSAGE_PF"); + pfThreshold = -1; + if (p) { + pfThreshold = strtol(p, 0, 0); + } + } + if (pfThreshold > 0) { + doOutput = ru.ru_minflt > pfThreshold; + } + if (doOutput) { + /* Cast values to long in case some system has defined them + * as another integer type */ + fprintf(fp, "RUSAGE: max resident set = %ldKB\n", (long) ru.ru_maxrss); + fprintf(fp, "RUSAGE: page faults = %ld : %ld\n", + (long) ru.ru_minflt, (long) ru.ru_majflt); + /* Not every Unix provides useful information for the xxrss fields */ + fprintf(fp, "RUSAGE: memory in text/data/stack = %ld : %ld : %ld\n", + (long) ru.ru_ixrss, (long) ru.ru_idrss, (long) ru.ru_isrss); + fprintf(fp, "RUSAGE: I/O in and out = %ld : %ld\n", + (long) ru.ru_inblock, (long) ru.ru_oublock); + fprintf(fp, "RUSAGE: context switch = %ld : %ld\n", + (long) ru.ru_nvcsw, (long) ru.ru_nivcsw); + } } else { - fprintf( fp, "RUSAGE: return error %d\n", errno ); + fprintf(fp, "RUSAGE: return error %d\n", errno); } #endif } + /* ------------------------------------------------------------------------ */ #ifdef HAVE_MPI_WIN_CREATE /* * Create MPI Windows */ -SMPI_VARINIT_GLOBAL_AND_SET(win_index, int, 0); -SMPI_VARINIT_GLOBAL(winName, const char *); +static int win_index = 0; +static const char *winName; /* Use an attribute to remember the type of memory allocation (static, malloc, or MPI_Alloc_mem) */ -SMPI_VARINIT_GLOBAL_AND_SET(mem_keyval, int, MPI_KEYVAL_INVALID); -int MTestGetWin( MPI_Win *win, int mustBePassive ) +static int mem_keyval = MPI_KEYVAL_INVALID; +int MTestGetWin(MPI_Win * win, int mustBePassive) { - typedef char actbuf_type[1024]; - SMPI_VARINIT_STATIC(actbuf, actbuf_type); - SMPI_VARINIT_STATIC(pasbuf, char *); - char *buf; - int n, rank, merr; - MPI_Info info; - - if (SMPI_VARGET_GLOBAL(mem_keyval) == MPI_KEYVAL_INVALID) { - /* Create the keyval */ - merr = MPI_Win_create_keyval( MPI_WIN_NULL_COPY_FN, - MPI_WIN_NULL_DELETE_FN, - &SMPI_VARGET_GLOBAL(mem_keyval), 0 ); - if (merr) MTestPrintError( merr ); + static char actbuf[1024]; + static char *pasbuf; + char *buf; + int n, rank, merr; + MPI_Info info; + + if (mem_keyval == MPI_KEYVAL_INVALID) { + /* Create the keyval */ + merr = MPI_Win_create_keyval(MPI_WIN_NULL_COPY_FN, MPI_WIN_NULL_DELETE_FN, &mem_keyval, 0); + if (merr) + MTestPrintError(merr); } - switch (SMPI_VARGET_GLOBAL(win_index)) { + switch (win_index) { case 0: - /* Active target window */ - merr = MPI_Win_create( SMPI_VARGET_STATIC(actbuf), 1024, 1, MPI_INFO_NULL, MPI_COMM_WORLD, - win ); - if (merr) MTestPrintError( merr ); - SMPI_VARGET_GLOBAL(winName) = "active-window"; - merr = MPI_Win_set_attr( *win, SMPI_VARGET_GLOBAL(mem_keyval), (void *)0 ); - if (merr) MTestPrintError( merr ); - break; + /* Active target window */ + merr = MPI_Win_create(actbuf, 1024, 1, MPI_INFO_NULL, MPI_COMM_WORLD, win); + if (merr) + MTestPrintError(merr); + winName = "active-window"; + merr = MPI_Win_set_attr(*win, mem_keyval, (void *) 0); + if (merr) + MTestPrintError(merr); + break; case 1: - /* Passive target window */ - merr = MPI_Alloc_mem( 1024, MPI_INFO_NULL, &SMPI_VARGET_STATIC(pasbuf) ); - if (merr) MTestPrintError( merr ); - merr = MPI_Win_create( SMPI_VARGET_STATIC(pasbuf), 1024, 1, MPI_INFO_NULL, MPI_COMM_WORLD, - win ); - if (merr) MTestPrintError( merr ); - SMPI_VARGET_GLOBAL(winName) = "passive-window"; - merr = MPI_Win_set_attr( *win, SMPI_VARGET_GLOBAL(mem_keyval), (void *)2 ); - if (merr) MTestPrintError( merr ); - break; + /* Passive target window */ + merr = MPI_Alloc_mem(1024, MPI_INFO_NULL, &pasbuf); + if (merr) + MTestPrintError(merr); + merr = MPI_Win_create(pasbuf, 1024, 1, MPI_INFO_NULL, MPI_COMM_WORLD, win); + if (merr) + MTestPrintError(merr); + winName = "passive-window"; + merr = MPI_Win_set_attr(*win, mem_keyval, (void *) 2); + if (merr) + MTestPrintError(merr); + break; case 2: - /* Active target; all windows different sizes */ - merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank ); - if (merr) MTestPrintError( merr ); - n = rank * 64; - if (n) - buf = (char *)malloc( n ); - else - buf = 0; - merr = MPI_Win_create( buf, n, 1, MPI_INFO_NULL, MPI_COMM_WORLD, - win ); - if (merr) MTestPrintError( merr ); - SMPI_VARGET_GLOBAL(winName) = "active-all-different-win"; - merr = MPI_Win_set_attr( *win, SMPI_VARGET_GLOBAL(mem_keyval), (void *)1 ); - if (merr) MTestPrintError( merr ); - break; + /* Active target; all windows different sizes */ + merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank); + if (merr) + MTestPrintError(merr); + n = rank * 64; + if (n) + buf = (char *) malloc(n); + else + buf = 0; + merr = MPI_Win_create(buf, n, 1, MPI_INFO_NULL, MPI_COMM_WORLD, win); + if (merr) + MTestPrintError(merr); + winName = "active-all-different-win"; + merr = MPI_Win_set_attr(*win, mem_keyval, (void *) 1); + if (merr) + MTestPrintError(merr); + break; case 3: - /* Active target, no locks set */ - merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank ); - if (merr) MTestPrintError( merr ); - n = rank * 64; - if (n) - buf = (char *)malloc( n ); - else - buf = 0; - merr = MPI_Info_create( &info ); - if (merr) MTestPrintError( merr ); - merr = MPI_Info_set( info, (char*)"nolocks", (char*)"true" ); - if (merr) MTestPrintError( merr ); - merr = MPI_Win_create( buf, n, 1, info, MPI_COMM_WORLD, win ); - if (merr) MTestPrintError( merr ); - merr = MPI_Info_free( &info ); - if (merr) MTestPrintError( merr ); - SMPI_VARGET_GLOBAL(winName) = "active-nolocks-all-different-win"; - merr = MPI_Win_set_attr( *win, SMPI_VARGET_GLOBAL(mem_keyval), (void *)1 ); - if (merr) MTestPrintError( merr ); - break; + /* Active target, no locks set */ + merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank); + if (merr) + MTestPrintError(merr); + n = rank * 64; + if (n) + buf = (char *) malloc(n); + else + buf = 0; + merr = MPI_Info_create(&info); + if (merr) + MTestPrintError(merr); + merr = MPI_Info_set(info, (char *) "nolocks", (char *) "true"); + if (merr) + MTestPrintError(merr); + merr = MPI_Win_create(buf, n, 1, info, MPI_COMM_WORLD, win); + if (merr) + MTestPrintError(merr); + merr = MPI_Info_free(&info); + if (merr) + MTestPrintError(merr); + winName = "active-nolocks-all-different-win"; + merr = MPI_Win_set_attr(*win, mem_keyval, (void *) 1); + if (merr) + MTestPrintError(merr); + break; default: - SMPI_VARGET_GLOBAL(win_index) = -1; + win_index = -1; } - SMPI_VARGET_GLOBAL(win_index)++; - return SMPI_VARGET_GLOBAL(win_index); + win_index++; + return win_index; } + /* Return a pointer to the name associated with a window object */ -const char *MTestGetWinName( void ) +const char *MTestGetWinName(void) { - return SMPI_VARGET_GLOBAL(winName); + return winName; } + /* Free the storage associated with a window object */ -void MTestFreeWin( MPI_Win *win ) +void MTestFreeWin(MPI_Win * win) { void *addr; - int flag, merr; + int flag, merr; - merr = MPI_Win_get_attr( *win, MPI_WIN_BASE, &addr, &flag ); - if (merr) MTestPrintError( merr ); + merr = MPI_Win_get_attr(*win, MPI_WIN_BASE, &addr, &flag); + if (merr) + MTestPrintError(merr); if (!flag) { - MTestError( "Could not get WIN_BASE from window" ); + MTestError("Could not get WIN_BASE from window"); } if (addr) { - void *val; - merr = MPI_Win_get_attr( *win, SMPI_VARGET_GLOBAL(mem_keyval), &val, &flag ); - if (merr) MTestPrintError( merr ); - if (flag) { - if (val == (void *)1) { - free( addr ); - } - else if (val == (void *)2) { - merr = MPI_Free_mem( addr ); - if (merr) MTestPrintError( merr ); - } - /* if val == (void *)0, then static data that must not be freed */ - } + void *val; + merr = MPI_Win_get_attr(*win, mem_keyval, &val, &flag); + if (merr) + MTestPrintError(merr); + if (flag) { + if (val == (void *) 1) { + free(addr); + } + else if (val == (void *) 2) { + merr = MPI_Free_mem(addr); + if (merr) + MTestPrintError(merr); + } + /* if val == (void *)0, then static data that must not be freed */ + } } merr = MPI_Win_free(win); - if (merr) MTestPrintError( merr ); + if (merr) + MTestPrintError(merr); } -static void MTestRMACleanup( void ) + +static void MTestRMACleanup(void) { - if (SMPI_VARGET_GLOBAL(mem_keyval) != MPI_KEYVAL_INVALID) { - MPI_Win_free_keyval( &SMPI_VARGET_GLOBAL(mem_keyval) ); + if (mem_keyval != MPI_KEYVAL_INVALID) { + MPI_Win_free_keyval(&mem_keyval); } } -#else -static void MTestRMACleanup( void ) {} +#else +static void MTestRMACleanup(void) +{ +} #endif + +/* ------------------------------------------------------------------------ */ +/* This function determines if it is possible to spawn addition MPI + * processes using MPI_COMM_SPAWN and MPI_COMM_SPAWN_MULTIPLE. + * + * It sets the can_spawn value to one of the following: + * 1 = yes, additional processes can be spawned + * 0 = no, MPI_UNIVERSE_SIZE <= the size of MPI_COMM_WORLD + * -1 = it is unknown whether or not processes can be spawned + * due to errors in the necessary query functions + * + */ +int MTestSpawnPossible(int *can_spawn) +{ + int errs = 0; + + void *v = NULL; + int flag = -1; + int vval = -1; + int rc; + + rc = MPI_Comm_get_attr(MPI_COMM_WORLD, MPI_UNIVERSE_SIZE, &v, &flag); + if (rc != MPI_SUCCESS) { + /* MPI_UNIVERSE_SIZE keyval missing from MPI_COMM_WORLD attributes */ + *can_spawn = -1; + errs++; + } + else { + /* MPI_UNIVERSE_SIZE need not be set */ + if (flag) { + + int size = -1; + rc = MPI_Comm_size(MPI_COMM_WORLD, &size); + if (rc != MPI_SUCCESS) { + /* MPI_Comm_size failed for MPI_COMM_WORLD */ + *can_spawn = -1; + errs++; + } + + vval = *(int *) v; + if (vval <= size) { + /* no additional processes can be spawned */ + *can_spawn = 0; + } + else { + *can_spawn = 1; + } + } + else { + /* No attribute associated with key MPI_UNIVERSE_SIZE of MPI_COMM_WORLD */ + *can_spawn = -1; + } + } + return errs; +} + +/* ------------------------------------------------------------------------ */ -- 2.20.1