--- /dev/null
+/* -*- Mode: C; c-basic-offset:4 ; indent-tabs-mode:nil ; -*- */
+/*
+ * (C) 2001 by Argonne National Laboratory.
+ * See COPYRIGHT in top-level directory.
+ */
+/* Warning - this test will fail for MPI_PROD & maybe MPI_SUM
+ * if more than 10 MPI processes are used. Loss of precision
+ * will occur as the number of processors is increased.
+ */
+
+#include "mpi.h"
+#include "mpitest.h"
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#ifdef HAVE_STDINT_H
+#include <stdint.h>
+#endif
+
+
+SMPI_VARINIT_GLOBAL(count, int);
+SMPI_VARINIT_GLOBAL(size, int);
+SMPI_VARINIT_GLOBAL(rank, int);
+SMPI_VARINIT_GLOBAL(cerrcnt, int);
+
+
+struct int_test {
+ int a;
+ int b;
+};
+struct long_test {
+ long a;
+ int b;
+};
+struct short_test {
+ short a;
+ int b;
+};
+struct float_test {
+ float a;
+ int b;
+};
+struct double_test {
+ double a;
+ int b;
+};
+
+#define mpi_op2str(op) \
+ ((op == MPI_SUM) ? "MPI_SUM" : \
+ (op == MPI_PROD) ? "MPI_PROD" : \
+ (op == MPI_MAX) ? "MPI_MAX" : \
+ (op == MPI_MIN) ? "MPI_MIN" : \
+ (op == MPI_LOR) ? "MPI_LOR" : \
+ (op == MPI_LXOR) ? "MPI_LXOR" : \
+ (op == MPI_LAND) ? "MPI_LAND" : \
+ (op == MPI_BOR) ? "MPI_BOR" : \
+ (op == MPI_BAND) ? "MPI_BAND" : \
+ (op == MPI_BXOR) ? "MPI_BXOR" : \
+ (op == MPI_MAXLOC) ? "MPI_MAXLOC" : \
+ (op == MPI_MINLOC) ? "MPI_MINLOC" : \
+ "MPI_NO_OP")
+
+/* calloc to avoid spurious valgrind warnings when "type" has padding bytes */
+#define DECL_MALLOC_IN_OUT_SOL(type) \
+ type *in, *out, *sol; \
+ in = (type *) calloc(SMPI_VARGET_GLOBAL(count), sizeof(type)); \
+ out = (type *) calloc(SMPI_VARGET_GLOBAL(count), sizeof(type)); \
+ sol = (type *) calloc(SMPI_VARGET_GLOBAL(count), sizeof(type));
+
+#define SET_INDEX_CONST(arr, val) \
+ { \
+ int i; \
+ for (i = 0; i < SMPI_VARGET_GLOBAL(count); i++) \
+ arr[i] = val; \
+ }
+
+#define SET_INDEX_SUM(arr, val) \
+ { \
+ int i; \
+ for (i = 0; i < SMPI_VARGET_GLOBAL(count); i++) \
+ arr[i] = i + val; \
+ }
+
+#define SET_INDEX_FACTOR(arr, val) \
+ { \
+ int i; \
+ for (i = 0; i < SMPI_VARGET_GLOBAL(count); i++) \
+ arr[i] = i * (val); \
+ }
+
+#define SET_INDEX_POWER(arr, val) \
+ { \
+ int i, j; \
+ for (i = 0; i < SMPI_VARGET_GLOBAL(count); i++) { \
+ (arr)[i] = 1; \
+ for (j = 0; j < (val); j++) \
+ arr[i] *= i; \
+ } \
+ }
+
+#define ERROR_CHECK_AND_FREE(lerrcnt, mpi_type, mpi_op) \
+ do { \
+ char name[MPI_MAX_OBJECT_NAME] = {0}; \
+ int len = 0; \
+ if (lerrcnt) { \
+ MPI_Type_get_name(mpi_type, name, &len); \
+ fprintf(stderr, "(%d) Error for type %s and op %s\n", \
+ SMPI_VARGET_GLOBAL(rank), name, mpi_op2str(mpi_op)); \
+ } \
+ free(in); free(out); free(sol); \
+ } while (0)
+
+/* The logic on the error check on MPI_Allreduce assumes that all
+ MPI_Allreduce routines return a failure if any do - this is sufficient
+ for MPI implementations that reject some of the valid op/datatype pairs
+ (and motivated this addition, as some versions of the IBM MPI
+ failed in just this way).
+*/
+#define ALLREDUCE_AND_FREE(mpi_type, mpi_op, in, out, sol) \
+ { \
+ int i, rc, lerrcnt = 0; \
+ rc = MPI_Allreduce(in, out, SMPI_VARGET_GLOBAL(count), mpi_type, mpi_op, MPI_COMM_WORLD); \
+ if (rc) { lerrcnt++; SMPI_VARGET_GLOBAL(cerrcnt)++; MTestPrintError(rc); } \
+ else { \
+ for (i = 0; i < SMPI_VARGET_GLOBAL(count); i++) { \
+ if (out[i] != sol[i]) { \
+ SMPI_VARGET_GLOBAL(cerrcnt)++; \
+ lerrcnt++; \
+ } \
+ } \
+ } \
+ ERROR_CHECK_AND_FREE(lerrcnt, mpi_type, mpi_op); \
+ }
+
+#define STRUCT_ALLREDUCE_AND_FREE(mpi_type, mpi_op, in, out, sol) \
+ { \
+ int i, rc, lerrcnt = 0; \
+ rc = MPI_Allreduce(in, out, SMPI_VARGET_GLOBAL(count), mpi_type, mpi_op, MPI_COMM_WORLD); \
+ if (rc) { lerrcnt++; SMPI_VARGET_GLOBAL(cerrcnt)++; MTestPrintError(rc); } \
+ else { \
+ for (i = 0; i < SMPI_VARGET_GLOBAL(count); i++) { \
+ if ((out[i].a != sol[i].a) || (out[i].b != sol[i].b)) { \
+ SMPI_VARGET_GLOBAL(cerrcnt)++; \
+ lerrcnt++; \
+ } \
+ } \
+ } \
+ ERROR_CHECK_AND_FREE(lerrcnt, mpi_type, mpi_op); \
+ }
+
+#define SET_INDEX_STRUCT_CONST(arr, val, el) \
+ { \
+ int i; \
+ for (i = 0; i < SMPI_VARGET_GLOBAL(count); i++) \
+ arr[i].el = val; \
+ }
+
+#define SET_INDEX_STRUCT_SUM(arr, val, el) \
+ { \
+ int i; \
+ for (i = 0; i < SMPI_VARGET_GLOBAL(count); i++) \
+ arr[i].el = i + (val); \
+ }
+
+#define sum_test1(type, mpi_type) \
+ { \
+ DECL_MALLOC_IN_OUT_SOL(type); \
+ SET_INDEX_SUM(in, 0); \
+ SET_INDEX_FACTOR(sol, SMPI_VARGET_GLOBAL(size)); \
+ SET_INDEX_CONST(out, 0); \
+ ALLREDUCE_AND_FREE(mpi_type, MPI_SUM, in, out, sol); \
+ }
+
+#define prod_test1(type, mpi_type) \
+ { \
+ DECL_MALLOC_IN_OUT_SOL(type); \
+ SET_INDEX_SUM(in, 0); \
+ SET_INDEX_POWER(sol, SMPI_VARGET_GLOBAL(size)); \
+ SET_INDEX_CONST(out, 0); \
+ ALLREDUCE_AND_FREE(mpi_type, MPI_PROD, in, out, sol); \
+ }
+
+#define max_test1(type, mpi_type) \
+ { \
+ DECL_MALLOC_IN_OUT_SOL(type); \
+ SET_INDEX_SUM(in, SMPI_VARGET_GLOBAL(rank)); \
+ SET_INDEX_SUM(sol, SMPI_VARGET_GLOBAL(size) - 1); \
+ SET_INDEX_CONST(out, 0); \
+ ALLREDUCE_AND_FREE(mpi_type, MPI_MAX, in, out, sol); \
+ }
+
+#define min_test1(type, mpi_type) \
+ { \
+ DECL_MALLOC_IN_OUT_SOL(type); \
+ SET_INDEX_SUM(in, SMPI_VARGET_GLOBAL(rank)); \
+ SET_INDEX_SUM(sol, 0); \
+ SET_INDEX_CONST(out, 0); \
+ ALLREDUCE_AND_FREE(mpi_type, MPI_MIN, in, out, sol); \
+ }
+
+#define const_test(type, mpi_type, mpi_op, val1, val2, val3) \
+ { \
+ DECL_MALLOC_IN_OUT_SOL(type); \
+ SET_INDEX_CONST(in, (val1)); \
+ SET_INDEX_CONST(sol, (val2)); \
+ SET_INDEX_CONST(out, (val3)); \
+ ALLREDUCE_AND_FREE(mpi_type, mpi_op, in, out, sol); \
+ }
+
+#define lor_test1(type, mpi_type) \
+ const_test(type, mpi_type, MPI_LOR, (SMPI_VARGET_GLOBAL(rank) & 0x1), (SMPI_VARGET_GLOBAL(size) > 1), 0)
+#define lor_test2(type, mpi_type) \
+ const_test(type, mpi_type, MPI_LOR, 0, 0, 0)
+#define lxor_test1(type, mpi_type) \
+ const_test(type, mpi_type, MPI_LXOR, (SMPI_VARGET_GLOBAL(rank) == 1), (SMPI_VARGET_GLOBAL(size) > 1), 0)
+#define lxor_test2(type, mpi_type) \
+ const_test(type, mpi_type, MPI_LXOR, 0, 0, 0)
+#define lxor_test3(type, mpi_type) \
+ const_test(type, mpi_type, MPI_LXOR, 1, (SMPI_VARGET_GLOBAL(size) & 0x1), 0)
+#define land_test1(type, mpi_type) \
+ const_test(type, mpi_type, MPI_LAND, (SMPI_VARGET_GLOBAL(rank) & 0x1), 0, 0)
+#define land_test2(type, mpi_type) \
+ const_test(type, mpi_type, MPI_LAND, 1, 1, 0)
+#define bor_test1(type, mpi_type) \
+ const_test(type, mpi_type, MPI_BOR, (SMPI_VARGET_GLOBAL(rank) & 0x3), ((SMPI_VARGET_GLOBAL(size) < 3) ? SMPI_VARGET_GLOBAL(size) - 1 : 0x3), 0)
+#define bxor_test1(type, mpi_type) \
+ const_test(type, mpi_type, MPI_BXOR, (SMPI_VARGET_GLOBAL(rank) == 1) * 0xf0, (SMPI_VARGET_GLOBAL(size) > 1) * 0xf0, 0)
+#define bxor_test2(type, mpi_type) \
+ const_test(type, mpi_type, MPI_BXOR, 0, 0, 0)
+#define bxor_test3(type, mpi_type) \
+ const_test(type, mpi_type, MPI_BXOR, ~0, (SMPI_VARGET_GLOBAL(size) &0x1) ? ~0 : 0, 0)
+
+#define band_test1(type, mpi_type) \
+ { \
+ DECL_MALLOC_IN_OUT_SOL(type); \
+ if (SMPI_VARGET_GLOBAL(rank) == SMPI_VARGET_GLOBAL(size)-1) { \
+ SET_INDEX_SUM(in, 0); \
+ } \
+ else { \
+ SET_INDEX_CONST(in, ~0); \
+ } \
+ SET_INDEX_SUM(sol, 0); \
+ SET_INDEX_CONST(out, 0); \
+ ALLREDUCE_AND_FREE(mpi_type, MPI_BAND, in, out, sol); \
+ }
+
+#define band_test2(type, mpi_type) \
+ { \
+ DECL_MALLOC_IN_OUT_SOL(type); \
+ if (SMPI_VARGET_GLOBAL(rank) == SMPI_VARGET_GLOBAL(size)-1) { \
+ SET_INDEX_SUM(in, 0); \
+ } \
+ else { \
+ SET_INDEX_CONST(in, 0); \
+ } \
+ SET_INDEX_CONST(sol, 0); \
+ SET_INDEX_CONST(out, 0); \
+ ALLREDUCE_AND_FREE(mpi_type, MPI_BAND, in, out, sol); \
+ }
+
+#define maxloc_test(type, mpi_type) \
+ { \
+ DECL_MALLOC_IN_OUT_SOL(type); \
+ SET_INDEX_STRUCT_SUM(in, SMPI_VARGET_GLOBAL(rank), a); \
+ SET_INDEX_STRUCT_CONST(in, SMPI_VARGET_GLOBAL(rank), b); \
+ SET_INDEX_STRUCT_SUM(sol, SMPI_VARGET_GLOBAL(size) - 1, a); \
+ SET_INDEX_STRUCT_CONST(sol, SMPI_VARGET_GLOBAL(size) - 1, b); \
+ SET_INDEX_STRUCT_CONST(out, 0, a); \
+ SET_INDEX_STRUCT_CONST(out, -1, b); \
+ STRUCT_ALLREDUCE_AND_FREE(mpi_type, MPI_MAXLOC, in, out, sol); \
+ }
+
+#define minloc_test(type, mpi_type) \
+ { \
+ DECL_MALLOC_IN_OUT_SOL(type); \
+ SET_INDEX_STRUCT_SUM(in, SMPI_VARGET_GLOBAL(rank), a); \
+ SET_INDEX_STRUCT_CONST(in, SMPI_VARGET_GLOBAL(rank), b); \
+ SET_INDEX_STRUCT_SUM(sol, 0, a); \
+ SET_INDEX_STRUCT_CONST(sol, 0, b); \
+ SET_INDEX_STRUCT_CONST(out, 0, a); \
+ SET_INDEX_STRUCT_CONST(out, -1, b); \
+ STRUCT_ALLREDUCE_AND_FREE(mpi_type, MPI_MINLOC, in, out, sol); \
+ }
+
+#if MTEST_HAVE_MIN_MPI_VERSION(2,2)
+#define test_types_set_mpi_2_2_integer(op,post) do { \
+ op##_test##post(int8_t, MPI_INT8_T); \
+ op##_test##post(int16_t, MPI_INT16_T); \
+ op##_test##post(int32_t, MPI_INT32_T); \
+ op##_test##post(int64_t, MPI_INT64_T); \
+ op##_test##post(uint8_t, MPI_UINT8_T); \
+ op##_test##post(uint16_t, MPI_UINT16_T); \
+ op##_test##post(uint32_t, MPI_UINT32_T); \
+ op##_test##post(uint64_t, MPI_UINT64_T); \
+ op##_test##post(MPI_Aint, MPI_AINT); \
+ op##_test##post(MPI_Offset, MPI_OFFSET); \
+ } while (0)
+#else
+#define test_types_set_mpi_2_2_integer(op,post) do { } while (0)
+#endif
+
+#if MTEST_HAVE_MIN_MPI_VERSION(3,0)
+#define test_types_set_mpi_3_0_integer(op,post) do { \
+ op##_test##post(MPI_Count, MPI_COUNT); \
+ } while (0)
+#else
+#define test_types_set_mpi_3_0_integer(op,post) do { } while (0)
+#endif
+
+#define test_types_set1(op, post) \
+ { \
+ op##_test##post(int, MPI_INT); \
+ op##_test##post(long, MPI_LONG); \
+ op##_test##post(short, MPI_SHORT); \
+ op##_test##post(unsigned short, MPI_UNSIGNED_SHORT); \
+ op##_test##post(unsigned, MPI_UNSIGNED); \
+ op##_test##post(unsigned long, MPI_UNSIGNED_LONG); \
+ op##_test##post(unsigned char, MPI_UNSIGNED_CHAR); \
+ test_types_set_mpi_2_2_integer(op,post); \
+ test_types_set_mpi_3_0_integer(op,post); \
+ }
+
+#define test_types_set2(op, post) \
+ { \
+ test_types_set1(op, post); \
+ op##_test##post(float, MPI_FLOAT); \
+ op##_test##post(double, MPI_DOUBLE); \
+ }
+
+#define test_types_set3(op, post) \
+ { \
+ op##_test##post(unsigned char, MPI_BYTE); \
+ }
+
+/* Make sure that we test complex and double complex, even if long
+ double complex is not available */
+#if defined(USE_LONG_DOUBLE_COMPLEX)
+
+#if MTEST_HAVE_MIN_MPI_VERSION(2,2) && defined(HAVE_FLOAT__COMPLEX) \
+ && defined(HAVE_DOUBLE__COMPLEX) \
+ && defined(HAVE_LONG_DOUBLE__COMPLEX)
+#define test_types_set4(op, post) \
+ do { \
+ op##_test##post(float _Complex, MPI_C_FLOAT_COMPLEX); \
+ op##_test##post(double _Complex, MPI_C_DOUBLE_COMPLEX); \
+ if (MPI_C_LONG_DOUBLE_COMPLEX != MPI_DATATYPE_NULL) { \
+ op##_test##post(long double _Complex, MPI_C_LONG_DOUBLE_COMPLEX); \
+ } \
+ } while (0)
+
+#else
+#define test_types_set4(op, post) do { } while (0)
+#endif
+#else
+
+#if MTEST_HAVE_MIN_MPI_VERSION(2,2) && defined(HAVE_FLOAT__COMPLEX) \
+ && defined(HAVE_DOUBLE__COMPLEX)
+#define test_types_set4(op, post) \
+ do { \
+ op##_test##post(float _Complex, MPI_C_FLOAT_COMPLEX); \
+ op##_test##post(double _Complex, MPI_C_DOUBLE_COMPLEX); \
+ } while (0)
+
+#else
+#define test_types_set4(op, post) do { } while (0)
+#endif
+
+#endif /* defined(USE_LONG_DOUBLE_COMPLEX) */
+
+#if MTEST_HAVE_MIN_MPI_VERSION(2,2) && defined(HAVE__BOOL)
+#define test_types_set5(op, post) \
+ do { \
+ op##_test##post(_Bool, MPI_C_BOOL); \
+ } while (0)
+
+#else
+#define test_types_set5(op, post) do { } while (0)
+#endif
+
+int main(int argc, char **argv)
+{
+ MTest_Init(&argc, &argv);
+
+ MPI_Comm_size(MPI_COMM_WORLD, &SMPI_VARGET_GLOBAL(size));
+ MPI_Comm_rank(MPI_COMM_WORLD, &SMPI_VARGET_GLOBAL(rank));
+
+ if (SMPI_VARGET_GLOBAL(size) < 2) {
+ fprintf(stderr, "At least 2 processes required\n");
+ MPI_Abort(MPI_COMM_WORLD, 1);
+ }
+
+ /* Set errors return so that we can provide better information
+ * should a routine reject one of the operand/datatype pairs */
+ MPI_Errhandler_set(MPI_COMM_WORLD, MPI_ERRORS_RETURN);
+
+ SMPI_VARGET_GLOBAL(count) = 10;
+ /* Allow an argument to override the count.
+ * Note that the product tests may fail if the count is very large.
+ */
+ if (argc >= 2) {
+ SMPI_VARGET_GLOBAL(count) = atoi(argv[1]);
+ if (SMPI_VARGET_GLOBAL(count) <= 0) {
+ fprintf(stderr, "Invalid count argument %s\n", argv[1]);
+ MPI_Abort(MPI_COMM_WORLD, 1);
+ }
+ }
+
+ test_types_set2(sum, 1);
+ test_types_set2(prod, 1);
+ test_types_set2(max, 1);
+ test_types_set2(min, 1);
+
+ test_types_set1(lor, 1);
+ test_types_set1(lor, 2);
+
+ test_types_set1(lxor, 1);
+ test_types_set1(lxor, 2);
+ test_types_set1(lxor, 3);
+
+ test_types_set1(land, 1);
+ test_types_set1(land, 2);
+
+ test_types_set1(bor, 1);
+ test_types_set1(band, 1);
+ test_types_set1(band, 2);
+
+ test_types_set1(bxor, 1);
+ test_types_set1(bxor, 2);
+ test_types_set1(bxor, 3);
+
+ test_types_set3(bor, 1);
+ test_types_set3(band, 1);
+ test_types_set3(band, 2);
+
+ test_types_set3(bxor, 1);
+ test_types_set3(bxor, 2);
+ test_types_set3(bxor, 3);
+
+ test_types_set4(sum, 1);
+ test_types_set4(prod, 1);
+
+ test_types_set5(lor, 1);
+ test_types_set5(lor, 2);
+ test_types_set5(lxor, 1);
+ test_types_set5(lxor, 2);
+ test_types_set5(lxor, 3);
+ test_types_set5(land, 1);
+ test_types_set5(land, 2);
+
+ maxloc_test(struct int_test, MPI_2INT);
+ maxloc_test(struct long_test, MPI_LONG_INT);
+ maxloc_test(struct short_test, MPI_SHORT_INT);
+ maxloc_test(struct float_test, MPI_FLOAT_INT);
+ maxloc_test(struct double_test, MPI_DOUBLE_INT);
+
+ minloc_test(struct int_test, MPI_2INT);
+ minloc_test(struct long_test, MPI_LONG_INT);
+ minloc_test(struct short_test, MPI_SHORT_INT);
+ minloc_test(struct float_test, MPI_FLOAT_INT);
+ minloc_test(struct double_test, MPI_DOUBLE_INT);
+
+ MPI_Errhandler_set(MPI_COMM_WORLD, MPI_ERRORS_ARE_FATAL);
+ MTest_Finalize(SMPI_VARGET_GLOBAL(cerrcnt));
+ MPI_Finalize();
+ return 0;
+}
