teshsuite/smpi/mpich3-test/util/mtest_manual.c

   1 /* -*- Mode: C; c-basic-offset:4 ; indent-tabs-mode:nil ; -*- */
   2 /*
   3  *
   4  *  (C) 2001 by Argonne National Laboratory.
   5  *      See COPYRIGHT in top-level directory.
   6  */
   7 #include "mpi.h"
   8 #include "mpitestconf.h"
   9 #include "mpitest.h"
  10 #if defined(HAVE_STDIO_H) || defined(STDC_HEADERS)
  11 #include <stdio.h>
  12 #endif
  13 #if defined(HAVE_STDLIB_H) || defined(STDC_HEADERS)
  14 #include <stdlib.h>
  15 #endif
  16 #if defined(HAVE_STRING_H) || defined(STDC_HEADERS)
  17 #include <string.h>
  18 #endif
  19 #ifdef HAVE_STDARG_H
  20 #include <stdarg.h>
  21 #endif
  22 /* The following two includes permit the collection of resource usage
  23    data in the tests
  24  */
  25 #ifdef HAVE_SYS_TIME_H
  26 #include <sys/time.h>
  27 #endif
  28 #ifdef HAVE_SYS_RESOURCE_H
  29 #include <sys/resource.h>
  30 #endif
  31 #include <errno.h>
  32
  33
  34 /*
  35  * Utility routines for writing MPI tests.
  36  *
  37  * We check the return codes on all MPI routines (other than INIT)
  38  * to allow the program that uses these routines to select MPI_ERRORS_RETURN
  39  * as the error handler.  We do *not* set MPI_ERRORS_RETURN because
  40  * the code that makes use of these routines may not check return
  41  * codes.
  42  *
  43  */
  44
  45 static void MTestRMACleanup(void);
  46 static void MTestResourceSummary(FILE *);
  47
  48 /* Here is where we could put the includes and definitions to enable
  49    memory testing */
  50
  51 SMPI_VARINIT_GLOBAL_AND_SET(dbgflag, int, 0); /* Flag used for debugging */
  52 SMPI_VARINIT_GLOBAL_AND_SET(wrank, int, -1);  /* World rank */
  53 SMPI_VARINIT_GLOBAL_AND_SET(verbose, int, 0); /* Message level (0 is none) */
  54 SMPI_VARINIT_GLOBAL_AND_SET(returnWithVal, int, 0); /* Allow programs to return
  55                                    with a non-zero if there was an error (may
  56                                    cause problems with some runtime systems) */
  57 SMPI_VARINIT_GLOBAL_AND_SET(usageOutput, int, 0); /* */
  58
  59 /* Provide backward portability to MPI 1 */
  60 #ifndef MPI_VERSION
  61 #define MPI_VERSION 1
  62 #endif
  63 #if MPI_VERSION < 2
  64 #define MPI_THREAD_SINGLE 0
  65 #endif
  66
  67 /*
  68  * Initialize and Finalize MTest
  69  */
  70
  71 /*
  72    Initialize MTest, initializing MPI if necessary.
  73
  74  Environment Variables:
  75 + MPITEST_DEBUG - If set (to any value), turns on debugging output
  76 . MPITEST_THREADLEVEL_DEFAULT - If set, use as the default "provided"
  77                                 level of thread support.  Applies to
  78                                 MTest_Init but not MTest_Init_thread.
  79 - MPITEST_VERBOSE - If set to a numeric value, turns on that level of
  80   verbose output.  This is used by the routine 'MTestPrintfMsg'
  81
  82 */
  83 void MTest_Init_thread(int *argc, char ***argv, int required, int *provided)
  84 {
  85     int flag;
  86     char *envval = 0;
  87
  88     MPI_Initialized(&flag);
  89     if (!flag) {
  90         /* Permit an MPI that claims only MPI 1 but includes the
  91          * MPI_Init_thread routine (e.g., IBM MPI) */
  92 #if MPI_VERSION >= 2 || defined(HAVE_MPI_INIT_THREAD)
  93         MPI_Init_thread(argc, argv, required, provided);
  94 #else
  95         MPI_Init(argc, argv);
  96         *provided = -1;
  97 #endif
  98     }
  99     /* Check for debugging control */
 100     if (getenv("MPITEST_DEBUG")) {
 101         SMPI_VARGET_GLOBAL(dbgflag) = 1;
 102         MPI_Comm_rank(MPI_COMM_WORLD, &SMPI_VARGET_GLOBAL(wrank));
 103     }
 104
 105     /* Check for verbose control */
 106     envval = getenv("MPITEST_VERBOSE");
 107     if (envval) {
 108         char *s;
 109         long val = strtol(envval, &s, 0);
 110         if (s == envval) {
 111             /* This is the error case for strtol */
 112             fprintf(stderr, "Warning: %s not valid for MPITEST_VERBOSE\n", envval);
 113             fflush(stderr);
 114         }
 115         else {
 116             if (val >= 0) {
 117                 SMPI_VARGET_GLOBAL(verbose) = val;
 118             }
 119             else {
 120                 fprintf(stderr, "Warning: %s not valid for MPITEST_VERBOSE\n", envval);
 121                 fflush(stderr);
 122             }
 123         }
 124     }
 125     /* Check for option to return success/failure in the return value of main */
 126     envval = getenv("MPITEST_RETURN_WITH_CODE");
 127     if (envval) {
 128         if (strcmp(envval, "yes") == 0 ||
 129             strcmp(envval, "YES") == 0 ||
 130             strcmp(envval, "true") == 0 || strcmp(envval, "TRUE") == 0) {
 131             SMPI_VARGET_GLOBAL(returnWithVal) = 1;
 132         }
 133         else if (strcmp(envval, "no") == 0 ||
 134                  strcmp(envval, "NO") == 0 ||
 135                  strcmp(envval, "false") == 0 || strcmp(envval, "FALSE") == 0) {
 136             SMPI_VARGET_GLOBAL(returnWithVal) = 0;
 137         }
 138         else {
 139             fprintf(stderr, "Warning: %s not valid for MPITEST_RETURN_WITH_CODE\n", envval);
 140             fflush(stderr);
 141         }
 142     }
 143
 144     /* Print rusage data if set */
 145     if (getenv("MPITEST_RUSAGE")) {
 146         SMPI_VARGET_GLOBAL(usageOutput) = 1;
 147     }
 148 }
 149
 150 /*
 151  * Initialize the tests, using an MPI-1 style init.  Supports
 152  * MTEST_THREADLEVEL_DEFAULT to test with user-specified thread level
 153  */
 154 void MTest_Init(int *argc, char ***argv)
 155 {
 156     int provided;
 157 #if MPI_VERSION >= 2 || defined(HAVE_MPI_INIT_THREAD)
 158     const char *str = 0;
 159     int threadLevel;
 160
 161     threadLevel = MPI_THREAD_SINGLE;
 162     str = getenv("MTEST_THREADLEVEL_DEFAULT");
 163     if (!str)
 164         str = getenv("MPITEST_THREADLEVEL_DEFAULT");
 165     if (str && *str) {
 166         if (strcmp(str, "MULTIPLE") == 0 || strcmp(str, "multiple") == 0) {
 167             threadLevel = MPI_THREAD_MULTIPLE;
 168         }
 169         else if (strcmp(str, "SERIALIZED") == 0 || strcmp(str, "serialized") == 0) {
 170             threadLevel = MPI_THREAD_SERIALIZED;
 171         }
 172         else if (strcmp(str, "FUNNELED") == 0 || strcmp(str, "funneled") == 0) {
 173             threadLevel = MPI_THREAD_FUNNELED;
 174         }
 175         else if (strcmp(str, "SINGLE") == 0 || strcmp(str, "single") == 0) {
 176             threadLevel = MPI_THREAD_SINGLE;
 177         }
 178         else {
 179             fprintf(stderr, "Unrecognized thread level %s\n", str);
 180             /* Use exit since MPI_Init/Init_thread has not been called. */
 181             exit(1);
 182         }
 183     }
 184     MTest_Init_thread(argc, argv, threadLevel, &provided);
 185 #else
 186     /* If the MPI_VERSION is 1, there is no MPI_THREAD_xxx defined */
 187     MTest_Init_thread(argc, argv, 0, &provided);
 188 #endif
 189 }
 190
 191 /*
 192   Finalize MTest.  errs is the number of errors on the calling process;
 193   this routine will write the total number of errors over all of MPI_COMM_WORLD
 194   to the process with rank zero, or " No Errors".
 195   It does *not* finalize MPI.
 196  */
 197 void MTest_Finalize(int errs)
 198 {
 199     int rank, toterrs, merr;
 200
 201     merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
 202     if (merr)
 203         MTestPrintError(merr);
 204
 205     merr = MPI_Reduce(&errs, &toterrs, 1, MPI_INT, MPI_SUM, 0, MPI_COMM_WORLD);
 206     if (merr)
 207         MTestPrintError(merr);
 208     if (rank == 0) {
 209         if (toterrs) {
 210             printf(" Found %d errors\n", toterrs);
 211         }
 212         else {
 213             printf(" No Errors\n");
 214         }
 215         fflush(stdout);
 216     }
 217
 218     if (SMPI_VARGET_GLOBAL(usageOutput))
 219         MTestResourceSummary(stdout);
 220
 221
 222     /* Clean up any persistent objects that we allocated */
 223     MTestRMACleanup();
 224 }
 225
 226 /* ------------------------------------------------------------------------ */
 227 /* This routine may be used instead of "return 0;" at the end of main;
 228    it allows the program to use the return value to signal success or failure.
 229  */
 230 int MTestReturnValue(int errors)
 231 {
 232     if (SMPI_VARGET_GLOBAL(returnWithVal))
 233         return errors ? 1 : 0;
 234     return 0;
 235 }
 236
 237 /* ------------------------------------------------------------------------ */
 238
 239 /*
 240  * Miscellaneous utilities, particularly to eliminate OS dependencies
 241  * from the tests.
 242  * MTestSleep(seconds)
 243  */
 244 #ifdef HAVE_WINDOWS_H
 245 #include <windows.h>
 246 void MTestSleep(int sec)
 247 {
 248     Sleep(1000 * sec);
 249 }
 250 #else
 251 #include <unistd.h>
 252 void MTestSleep(int sec)
 253 {
 254     sleep(sec);
 255 }
 256 #endif
 257
 258 /* Other mtest subfiles read debug setting using this function. */
 259 void MTestGetDbgInfo(int *_dbgflag, int *_verbose)
 260 {
 261     *_dbgflag = SMPI_VARGET_GLOBAL(dbgflag);
 262     *_verbose = SMPI_VARGET_GLOBAL(verbose);
 263 }
 264
 265 /* ----------------------------------------------------------------------- */
 266
 267 /*
 268  * Create communicators.  Use separate routines for inter and intra
 269  * communicators (there is a routine to give both)
 270  * Note that the routines may return MPI_COMM_NULL, so code should test for
 271  * that return value as well.
 272  *
 273  */
 274 SMPI_VARINIT_GLOBAL_AND_SET(interCommIdx, int, 0);
 275 SMPI_VARINIT_GLOBAL_AND_SET(intraCommIdx, int, 0);
 276 SMPI_VARINIT_GLOBAL_AND_SET(intraCommName, const char *, 0);
 277 SMPI_VARINIT_GLOBAL_AND_SET(interCommName, const char *, 0);
 278
 279 /*
 280  * Get an intracommunicator with at least min_size members.  If "allowSmaller"
 281  * is true, allow the communicator to be smaller than MPI_COMM_WORLD and
 282  * for this routine to return MPI_COMM_NULL for some values.  Returns 0 if
 283  * no more communicators are available.
 284  */
 285 int MTestGetIntracommGeneral(MPI_Comm * comm, int min_size, int allowSmaller)
 286 {
 287     int size, rank, merr;
 288     int done = 0;
 289     int isBasic = 0;
 290
 291     /* The while loop allows us to skip communicators that are too small.
 292      * MPI_COMM_NULL is always considered large enough */
 293     while (!done) {
 294         isBasic = 0;
 295         SMPI_VARGET_GLOBAL(intraCommName) = "";
 296         switch (SMPI_VARGET_GLOBAL(intraCommIdx)) {
 297         case 0:
 298             *comm = MPI_COMM_WORLD;
 299             isBasic = 1;
 300             SMPI_VARGET_GLOBAL(intraCommName) = "MPI_COMM_WORLD";
 301             break;
 302         case 1:
 303             /* dup of world */
 304             merr = MPI_Comm_dup(MPI_COMM_WORLD, comm);
 305             if (merr)
 306                 MTestPrintError(merr);
 307             SMPI_VARGET_GLOBAL(intraCommName) = "Dup of MPI_COMM_WORLD";
 308             break;
 309         case 2:
 310             /* reverse ranks */
 311             merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
 312             if (merr)
 313                 MTestPrintError(merr);
 314             merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
 315             if (merr)
 316                 MTestPrintError(merr);
 317             merr = MPI_Comm_split(MPI_COMM_WORLD, 0, size - rank, comm);
 318             if (merr)
 319                 MTestPrintError(merr);
 320             SMPI_VARGET_GLOBAL(intraCommName) = "Rank reverse of MPI_COMM_WORLD";
 321             break;
 322         case 3:
 323             /* subset of world, with reversed ranks */
 324             merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
 325             if (merr)
 326                 MTestPrintError(merr);
 327             merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
 328             if (merr)
 329                 MTestPrintError(merr);
 330             merr = MPI_Comm_split(MPI_COMM_WORLD, ((rank < size / 2) ? 1 : MPI_UNDEFINED),
 331                                   size - rank, comm);
 332             if (merr)
 333                 MTestPrintError(merr);
 334             SMPI_VARGET_GLOBAL(intraCommName) = "Rank reverse of half of MPI_COMM_WORLD";
 335             break;
 336         case 4:
 337             *comm = MPI_COMM_SELF;
 338             isBasic = 1;
 339             SMPI_VARGET_GLOBAL(intraCommName) = "MPI_COMM_SELF";
 340             break;
 341         case 5:
 342             {
 343 #if MTEST_HAVE_MIN_MPI_VERSION(3,0)
 344                 /* Dup of the world using MPI_Intercomm_merge */
 345                 int rleader, isLeft;
 346                 MPI_Comm local_comm, inter_comm;
 347                 MPI_Comm_size(MPI_COMM_WORLD, &size);
 348                 MPI_Comm_rank(MPI_COMM_WORLD, &rank);
 349                 if (size > 1) {
 350                     merr = MPI_Comm_split(MPI_COMM_WORLD, (rank < size / 2), rank, &local_comm);
 351                     if (merr)
 352                         MTestPrintError(merr);
 353                     if (rank == 0) {
 354                         rleader = size / 2;
 355                     }
 356                     else if (rank == size / 2) {
 357                         rleader = 0;
 358                     }
 359                     else {
 360                         rleader = -1;
 361                     }
 362                     isLeft = rank < size / 2;
 363                     merr =
 364                         MPI_Intercomm_create(local_comm, 0, MPI_COMM_WORLD, rleader, 99,
 365                                              &inter_comm);
 366                     if (merr)
 367                         MTestPrintError(merr);
 368                     merr = MPI_Intercomm_merge(inter_comm, isLeft, comm);
 369                     if (merr)
 370                         MTestPrintError(merr);
 371                     MPI_Comm_free(&inter_comm);
 372                     MPI_Comm_free(&local_comm);
 373                     SMPI_VARGET_GLOBAL(intraCommName) = "Dup of WORLD created by MPI_Intercomm_merge";
 374                 }
 375                 else {
 376                     *comm = MPI_COMM_NULL;
 377                 }
 378             }
 379             break;
 380         case 6:
 381             {
 382                 /* Even of the world using MPI_Comm_create_group */
 383                 int i;
 384                 MPI_Group world_group, even_group;
 385                 int *excl = NULL;
 386
 387                 MPI_Comm_size(MPI_COMM_WORLD, &size);
 388                 MPI_Comm_rank(MPI_COMM_WORLD, &rank);
 389                 if (allowSmaller && (size + 1) / 2 >= min_size) {
 390                     /* exclude the odd ranks */
 391                     excl = malloc((size / 2) * sizeof(int));
 392                     for (i = 0; i < size / 2; i++)
 393                         excl[i] = (2 * i) + 1;
 394
 395                     MPI_Comm_group(MPI_COMM_WORLD, &world_group);
 396                     MPI_Group_excl(world_group, size / 2, excl, &even_group);
 397                     MPI_Group_free(&world_group);
 398                     free(excl);
 399
 400                     if (rank % 2 == 0) {
 401                         /* Even processes create a comm. for themselves */
 402                         MPI_Comm_create_group(MPI_COMM_WORLD, even_group, 0, comm);
 403                         SMPI_VARGET_GLOBAL(intraCommName) = "Even of WORLD created by MPI_Comm_create_group";
 404                     }
 405                     else {
 406                         *comm = MPI_COMM_NULL;
 407                     }
 408
 409                     MPI_Group_free(&even_group);
 410                 }
 411                 else {
 412                     *comm = MPI_COMM_NULL;
 413                 }
 414 #else
 415                 *comm = MPI_COMM_NULL;
 416 #endif
 417             }
 418             break;
 419         case 7:
 420             {
 421                 /* High half of the world using MPI_Comm_create */
 422                 int ranges[1][3];
 423                 MPI_Group world_group, high_group;
 424                 MPI_Comm_size(MPI_COMM_WORLD, &size);
 425                 MPI_Comm_rank(MPI_COMM_WORLD, &rank);
 426                 ranges[0][0] = size / 2;
 427                 ranges[0][1] = size - 1;
 428                 ranges[0][2] = 1;
 429
 430                 if (allowSmaller && (size + 1) / 2 >= min_size) {
 431                     MPI_Comm_group(MPI_COMM_WORLD, &world_group);
 432                     merr = MPI_Group_range_incl(world_group, 1, ranges, &high_group);
 433                     if (merr)
 434                         MTestPrintError(merr);
 435                     merr = MPI_Comm_create(MPI_COMM_WORLD, high_group, comm);
 436                     if (merr)
 437                         MTestPrintError(merr);
 438                     MPI_Group_free(&world_group);
 439                     MPI_Group_free(&high_group);
 440                     SMPI_VARGET_GLOBAL(intraCommName) = "High half of WORLD created by MPI_Comm_create";
 441                 }
 442                 else {
 443                     *comm = MPI_COMM_NULL;
 444                 }
 445             }
 446             break;
 447             /* These next cases are communicators that include some
 448              * but not all of the processes */
 449         case 8:
 450         case 9:
 451         case 10:
 452         case 11:
 453             {
 454                 int newsize;
 455                 merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
 456                 if (merr)
 457                     MTestPrintError(merr);
 458                 newsize = size - (SMPI_VARGET_GLOBAL(intraCommIdx) - 7);
 459
 460                 if (allowSmaller && newsize >= min_size) {
 461                     merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
 462                     if (merr)
 463                         MTestPrintError(merr);
 464                     merr = MPI_Comm_split(MPI_COMM_WORLD, rank < newsize, rank, comm);
 465                     if (merr)
 466                         MTestPrintError(merr);
 467                     if (rank >= newsize) {
 468                         merr = MPI_Comm_free(comm);
 469                         if (merr)
 470                             MTestPrintError(merr);
 471                         *comm = MPI_COMM_NULL;
 472                     }
 473                     else {
 474                         SMPI_VARGET_GLOBAL(intraCommName) = "Split of WORLD";
 475                     }
 476                 }
 477                 else {
 478                     /* Act like default */
 479                     *comm = MPI_COMM_NULL;
 480                     SMPI_VARGET_GLOBAL(intraCommIdx) = -1;
 481                 }
 482             }
 483             break;
 484
 485             /* Other ideas: dup of self, cart comm, graph comm */
 486         default:
 487             *comm = MPI_COMM_NULL;
 488             SMPI_VARGET_GLOBAL(intraCommIdx) = -1;
 489             break;
 490         }
 491
 492         if (*comm != MPI_COMM_NULL) {
 493             merr = MPI_Comm_size(*comm, &size);
 494             if (merr)
 495                 MTestPrintError(merr);
 496             if (size >= min_size)
 497                 done = 1;
 498         }
 499         else {
 500             SMPI_VARGET_GLOBAL(intraCommName) = "MPI_COMM_NULL";
 501             isBasic = 1;
 502             done = 1;
 503         }
 504
 505         /* we are only done if all processes are done */
 506         MPI_Allreduce(MPI_IN_PLACE, &done, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD);
 507
 508         /* Advance the comm index whether we are done or not, otherwise we could
 509          * spin forever trying to allocate a too-small communicator over and
 510          * over again. */
 511         SMPI_VARGET_GLOBAL(intraCommIdx)++;
 512
 513         if (!done && !isBasic && *comm != MPI_COMM_NULL) {
 514             /* avoid leaking communicators */
 515             merr = MPI_Comm_free(comm);
 516             if (merr)
 517                 MTestPrintError(merr);
 518         }
 519     }
 520
 521     return SMPI_VARGET_GLOBAL(intraCommIdx);
 522 }
 523
 524 /*
 525  * Get an intracommunicator with at least min_size members.
 526  */
 527 int MTestGetIntracomm(MPI_Comm * comm, int min_size)
 528 {
 529     return MTestGetIntracommGeneral(comm, min_size, 0);
 530 }
 531
 532 /* Return the name of an intra communicator */
 533 const char *MTestGetIntracommName(void)
 534 {
 535     return SMPI_VARGET_GLOBAL(intraCommName);
 536 }
 537
 538 /*
 539  * Return an intercomm; set isLeftGroup to 1 if the calling process is
 540  * a member of the "left" group.
 541  */
 542 int MTestGetIntercomm(MPI_Comm * comm, int *isLeftGroup, int min_size)
 543 {
 544     int size, rank, remsize, merr;
 545     int done = 0;
 546     MPI_Comm mcomm = MPI_COMM_NULL;
 547     MPI_Comm mcomm2 = MPI_COMM_NULL;
 548     int rleader;
 549
 550     /* The while loop allows us to skip communicators that are too small.
 551      * MPI_COMM_NULL is always considered large enough.  The size is
 552      * the sum of the sizes of the local and remote groups */
 553     while (!done) {
 554         *comm = MPI_COMM_NULL;
 555         *isLeftGroup = 0;
 556         SMPI_VARGET_GLOBAL(interCommName) = "MPI_COMM_NULL";
 557
 558         switch (SMPI_VARGET_GLOBAL(interCommIdx)) {
 559         case 0:
 560             /* Split comm world in half */
 561             merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
 562             if (merr)
 563                 MTestPrintError(merr);
 564             merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
 565             if (merr)
 566                 MTestPrintError(merr);
 567             if (size > 1) {
 568                 merr = MPI_Comm_split(MPI_COMM_WORLD, (rank < size / 2), rank, &mcomm);
 569                 if (merr)
 570                     MTestPrintError(merr);
 571                 if (rank == 0) {
 572                     rleader = size / 2;
 573                 }
 574                 else if (rank == size / 2) {
 575                     rleader = 0;
 576                 }
 577                 else {
 578                     /* Remote leader is signficant only for the processes
 579                      * designated local leaders */
 580                     rleader = -1;
 581                 }
 582                 *isLeftGroup = rank < size / 2;
 583                 merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12345, comm);
 584                 if (merr)
 585                     MTestPrintError(merr);
 586                 SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD";
 587             }
 588             else
 589                 *comm = MPI_COMM_NULL;
 590             break;
 591         case 1:
 592             /* Split comm world in to 1 and the rest */
 593             merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
 594             if (merr)
 595                 MTestPrintError(merr);
 596             merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
 597             if (merr)
 598                 MTestPrintError(merr);
 599             if (size > 1) {
 600                 merr = MPI_Comm_split(MPI_COMM_WORLD, rank == 0, rank, &mcomm);
 601                 if (merr)
 602                     MTestPrintError(merr);
 603                 if (rank == 0) {
 604                     rleader = 1;
 605                 }
 606                 else if (rank == 1) {
 607                     rleader = 0;
 608                 }
 609                 else {
 610                     /* Remote leader is signficant only for the processes
 611                      * designated local leaders */
 612                     rleader = -1;
 613                 }
 614                 *isLeftGroup = rank == 0;
 615                 merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12346, comm);
 616                 if (merr)
 617                     MTestPrintError(merr);
 618                 SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD into 1, rest";
 619             }
 620             else
 621                 *comm = MPI_COMM_NULL;
 622             break;
 623
 624         case 2:
 625             /* Split comm world in to 2 and the rest */
 626             merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
 627             if (merr)
 628                 MTestPrintError(merr);
 629             merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
 630             if (merr)
 631                 MTestPrintError(merr);
 632             if (size > 3) {
 633                 merr = MPI_Comm_split(MPI_COMM_WORLD, rank < 2, rank, &mcomm);
 634                 if (merr)
 635                     MTestPrintError(merr);
 636                 if (rank == 0) {
 637                     rleader = 2;
 638                 }
 639                 else if (rank == 2) {
 640                     rleader = 0;
 641                 }
 642                 else {
 643                     /* Remote leader is signficant only for the processes
 644                      * designated local leaders */
 645                     rleader = -1;
 646                 }
 647                 *isLeftGroup = rank < 2;
 648                 merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12347, comm);
 649                 if (merr)
 650                     MTestPrintError(merr);
 651                 SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD into 2, rest";
 652             }
 653             else
 654                 *comm = MPI_COMM_NULL;
 655             break;
 656
 657         case 3:
 658             /* Split comm world in half, then dup */
 659             merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
 660             if (merr)
 661                 MTestPrintError(merr);
 662             merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
 663             if (merr)
 664                 MTestPrintError(merr);
 665             if (size > 1) {
 666                 merr = MPI_Comm_split(MPI_COMM_WORLD, (rank < size / 2), rank, &mcomm);
 667                 if (merr)
 668                     MTestPrintError(merr);
 669                 if (rank == 0) {
 670                     rleader = size / 2;
 671                 }
 672                 else if (rank == size / 2) {
 673                     rleader = 0;
 674                 }
 675                 else {
 676                     /* Remote leader is signficant only for the processes
 677                      * designated local leaders */
 678                     rleader = -1;
 679                 }
 680                 *isLeftGroup = rank < size / 2;
 681                 merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12345, comm);
 682                 if (merr)
 683                     MTestPrintError(merr);
 684                 /* avoid leaking after assignment below */
 685                 merr = MPI_Comm_free(&mcomm);
 686                 if (merr)
 687                     MTestPrintError(merr);
 688
 689                 /* now dup, some bugs only occur for dup's of intercomms */
 690                 mcomm = *comm;
 691                 merr = MPI_Comm_dup(mcomm, comm);
 692                 if (merr)
 693                     MTestPrintError(merr);
 694                 SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD then dup'ing";
 695             }
 696             else
 697                 *comm = MPI_COMM_NULL;
 698             break;
 699
 700         case 4:
 701             /* Split comm world in half, form intercomm, then split that intercomm */
 702             merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
 703             if (merr)
 704                 MTestPrintError(merr);
 705             merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
 706             if (merr)
 707                 MTestPrintError(merr);
 708             if (size > 1) {
 709                 merr = MPI_Comm_split(MPI_COMM_WORLD, (rank < size / 2), rank, &mcomm);
 710                 if (merr)
 711                     MTestPrintError(merr);
 712                 if (rank == 0) {
 713                     rleader = size / 2;
 714                 }
 715                 else if (rank == size / 2) {
 716                     rleader = 0;
 717                 }
 718                 else {
 719                     /* Remote leader is signficant only for the processes
 720                      * designated local leaders */
 721                     rleader = -1;
 722                 }
 723                 *isLeftGroup = rank < size / 2;
 724                 merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12345, comm);
 725                 if (merr)
 726                     MTestPrintError(merr);
 727                 /* avoid leaking after assignment below */
 728                 merr = MPI_Comm_free(&mcomm);
 729                 if (merr)
 730                     MTestPrintError(merr);
 731
 732                 /* now split, some bugs only occur for splits of intercomms */
 733                 mcomm = *comm;
 734                 merr = MPI_Comm_rank(mcomm, &rank);
 735                 if (merr)
 736                     MTestPrintError(merr);
 737                 /* this split is effectively a dup but tests the split code paths */
 738                 merr = MPI_Comm_split(mcomm, 0, rank, comm);
 739                 if (merr)
 740                     MTestPrintError(merr);
 741                 SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD then then splitting again";
 742             }
 743             else
 744                 *comm = MPI_COMM_NULL;
 745             break;
 746
 747         case 5:
 748             /* split comm world in half discarding rank 0 on the "left"
 749              * communicator, then form them into an intercommunicator */
 750             merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
 751             if (merr)
 752                 MTestPrintError(merr);
 753             merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
 754             if (merr)
 755                 MTestPrintError(merr);
 756             if (size >= 4) {
 757                 int color = (rank < size / 2 ? 0 : 1);
 758                 if (rank == 0)
 759                     color = MPI_UNDEFINED;
 760
 761                 merr = MPI_Comm_split(MPI_COMM_WORLD, color, rank, &mcomm);
 762                 if (merr)
 763                     MTestPrintError(merr);
 764
 765                 if (rank == 1) {
 766                     rleader = size / 2;
 767                 }
 768                 else if (rank == (size / 2)) {
 769                     rleader = 1;
 770                 }
 771                 else {
 772                     /* Remote leader is signficant only for the processes
 773                      * designated local leaders */
 774                     rleader = -1;
 775                 }
 776                 *isLeftGroup = rank < size / 2;
 777                 if (rank != 0) {        /* 0's mcomm is MPI_COMM_NULL */
 778                     merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12345, comm);
 779                     if (merr)
 780                         MTestPrintError(merr);
 781                 }
 782                 SMPI_VARGET_GLOBAL(interCommName) =
 783                     "Intercomm by splitting MPI_COMM_WORLD (discarding rank 0 in the left group) then MPI_Intercomm_create'ing";
 784             }
 785             else {
 786                 *comm = MPI_COMM_NULL;
 787             }
 788             break;
 789
 790         case 6:
 791             /* Split comm world in half then form them into an
 792              * intercommunicator.  Then discard rank 0 from each group of the
 793              * intercomm via MPI_Comm_create. */
 794             merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
 795             if (merr)
 796                 MTestPrintError(merr);
 797             merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
 798             if (merr)
 799                 MTestPrintError(merr);
 800             if (size >= 4) {
 801                 MPI_Group oldgroup, newgroup;
 802                 int ranks[1];
 803                 int color = (rank < size / 2 ? 0 : 1);
 804
 805                 merr = MPI_Comm_split(MPI_COMM_WORLD, color, rank, &mcomm);
 806                 if (merr)
 807                     MTestPrintError(merr);
 808
 809                 if (rank == 0) {
 810                     rleader = size / 2;
 811                 }
 812                 else if (rank == (size / 2)) {
 813                     rleader = 0;
 814                 }
 815                 else {
 816                     /* Remote leader is signficant only for the processes
 817                      * designated local leaders */
 818                     rleader = -1;
 819                 }
 820                 *isLeftGroup = rank < size / 2;
 821                 merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12345, &mcomm2);
 822                 if (merr)
 823                     MTestPrintError(merr);
 824
 825                 /* We have an intercomm between the two halves of comm world. Now create
 826                  * a new intercomm that removes rank 0 on each side. */
 827                 merr = MPI_Comm_group(mcomm2, &oldgroup);
 828                 if (merr)
 829                     MTestPrintError(merr);
 830                 ranks[0] = 0;
 831                 merr = MPI_Group_excl(oldgroup, 1, ranks, &newgroup);
 832                 if (merr)
 833                     MTestPrintError(merr);
 834                 merr = MPI_Comm_create(mcomm2, newgroup, comm);
 835                 if (merr)
 836                     MTestPrintError(merr);
 837
 838                 merr = MPI_Group_free(&oldgroup);
 839                 if (merr)
 840                     MTestPrintError(merr);
 841                 merr = MPI_Group_free(&newgroup);
 842                 if (merr)
 843                     MTestPrintError(merr);
 844
 845                 SMPI_VARGET_GLOBAL(interCommName) =
 846                     "Intercomm by splitting MPI_COMM_WORLD then discarding 0 ranks with MPI_Comm_create";
 847             }
 848             else {
 849                 *comm = MPI_COMM_NULL;
 850             }
 851             break;
 852
 853         default:
 854             *comm = MPI_COMM_NULL;
 855             SMPI_VARGET_GLOBAL(interCommIdx) = -1;
 856             break;
 857         }
 858
 859         if (*comm != MPI_COMM_NULL) {
 860             merr = MPI_Comm_size(*comm, &size);
 861             if (merr)
 862                 MTestPrintError(merr);
 863             merr = MPI_Comm_remote_size(*comm, &remsize);
 864             if (merr)
 865                 MTestPrintError(merr);
 866             if (size + remsize >= min_size)
 867                 done = 1;
 868         }
 869         else {
 870             SMPI_VARGET_GLOBAL(interCommName) = "MPI_COMM_NULL";
 871             done = 1;
 872         }
 873
 874         /* we are only done if all processes are done */
 875         MPI_Allreduce(MPI_IN_PLACE, &done, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD);
 876
 877         /* Advance the comm index whether we are done or not, otherwise we could
 878          * spin forever trying to allocate a too-small communicator over and
 879          * over again. */
 880         SMPI_VARGET_GLOBAL(interCommIdx)++;
 881
 882         if (!done && *comm != MPI_COMM_NULL) {
 883             /* avoid leaking communicators */
 884             merr = MPI_Comm_free(comm);
 885             if (merr)
 886                 MTestPrintError(merr);
 887         }
 888
 889         /* cleanup for common temp objects */
 890         if (mcomm != MPI_COMM_NULL) {
 891             merr = MPI_Comm_free(&mcomm);
 892             if (merr)
 893                 MTestPrintError(merr);
 894         }
 895         if (mcomm2 != MPI_COMM_NULL) {
 896             merr = MPI_Comm_free(&mcomm2);
 897             if (merr)
 898                 MTestPrintError(merr);
 899         }
 900     }
 901
 902     return SMPI_VARGET_GLOBAL(interCommIdx);
 903 }
 904
 905 int MTestTestIntercomm(MPI_Comm comm)
 906 {
 907     int local_size, remote_size, rank, **bufs, *bufmem, rbuf[2], j;
 908     int errs = 0, wrank_loc, nsize;
 909     char commname[MPI_MAX_OBJECT_NAME + 1];
 910     MPI_Request *reqs;
 911
 912     MPI_Comm_rank(MPI_COMM_WORLD, &wrank_loc);
 913     MPI_Comm_size(comm, &local_size);
 914     MPI_Comm_remote_size(comm, &remote_size);
 915     MPI_Comm_rank(comm, &rank);
 916     MPI_Comm_get_name(comm, commname, &nsize);
 917
 918     MTestPrintfMsg(1, "Testing communication on intercomm '%s', remote_size=%d\n",
 919                    commname, remote_size);
 920
 921     reqs = (MPI_Request *) malloc(remote_size * sizeof(MPI_Request));
 922     if (!reqs) {
 923         printf("[%d] Unable to allocated %d requests for testing intercomm %s\n",
 924                wrank_loc, remote_size, commname);
 925         errs++;
 926         return errs;
 927     }
 928     bufs = (int **) malloc(remote_size * sizeof(int *));
 929     if (!bufs) {
 930         printf("[%d] Unable to allocated %d int pointers for testing intercomm %s\n",
 931                wrank_loc, remote_size, commname);
 932         errs++;
 933         return errs;
 934     }
 935     bufmem = (int *) malloc(remote_size * 2 * sizeof(int));
 936     if (!bufmem) {
 937         printf("[%d] Unable to allocated %d int data for testing intercomm %s\n",
 938                wrank_loc, 2 * remote_size, commname);
 939         errs++;
 940         return errs;
 941     }
 942
 943     /* Each process sends a message containing its own rank and the
 944      * rank of the destination with a nonblocking send.  Because we're using
 945      * nonblocking sends, we need to use different buffers for each isend */
 946     /* NOTE: the send buffer access restriction was relaxed in MPI-2.2, although
 947      * it doesn't really hurt to keep separate buffers for our purposes */
 948     for (j = 0; j < remote_size; j++) {
 949         bufs[j] = &bufmem[2 * j];
 950         bufs[j][0] = rank;
 951         bufs[j][1] = j;
 952         MPI_Isend(bufs[j], 2, MPI_INT, j, 0, comm, &reqs[j]);
 953     }
 954     MTestPrintfMsg(2, "isends posted, about to recv\n");
 955
 956     for (j = 0; j < remote_size; j++) {
 957         MPI_Recv(rbuf, 2, MPI_INT, j, 0, comm, MPI_STATUS_IGNORE);
 958         if (rbuf[0] != j) {
 959             printf("[%d] Expected rank %d but saw %d in %s\n", wrank_loc, j, rbuf[0], commname);
 960             errs++;
 961         }
 962         if (rbuf[1] != rank) {
 963             printf("[%d] Expected target rank %d but saw %d from %d in %s\n",
 964                    wrank_loc, rank, rbuf[1], j, commname);
 965             errs++;
 966         }
 967     }
 968     if (errs)
 969         fflush(stdout);
 970
 971     MTestPrintfMsg(2, "my recvs completed, about to waitall\n");
 972     MPI_Waitall(remote_size, reqs, MPI_STATUSES_IGNORE);
 973
 974     free(reqs);
 975     free(bufs);
 976     free(bufmem);
 977
 978     return errs;
 979 }
 980
 981 int MTestTestIntracomm(MPI_Comm comm)
 982 {
 983     int i, errs = 0;
 984     int size;
 985     int in[16], out[16], sol[16];
 986
 987     MPI_Comm_size(comm, &size);
 988
 989     /* Set input, output and sol-values */
 990     for (i = 0; i < 16; i++) {
 991         in[i] = i;
 992         out[i] = 0;
 993         sol[i] = i * size;
 994     }
 995     MPI_Allreduce(in, out, 16, MPI_INT, MPI_SUM, comm);
 996
 997     /* Test results */
 998     for (i = 0; i < 16; i++) {
 999         if (sol[i] != out[i])
1000             errs++;
1001     }
1002
1003     return errs;
1004 }
1005
1006 int MTestTestComm(MPI_Comm comm)
1007 {
1008     int is_inter;
1009
1010     if (comm == MPI_COMM_NULL)
1011         return 0;
1012
1013     MPI_Comm_test_inter(comm, &is_inter);
1014
1015     if (is_inter)
1016         return MTestTestIntercomm(comm);
1017     else
1018         return MTestTestIntracomm(comm);
1019 }
1020
1021 /* Return the name of an intercommunicator */
1022 const char *MTestGetIntercommName(void)
1023 {
1024     return SMPI_VARGET_GLOBAL(interCommName);
1025 }
1026
1027 /* Get a communicator of a given minimum size.  Both intra and inter
1028    communicators are provided */
1029 int MTestGetComm(MPI_Comm * comm, int min_size)
1030 {
1031     int idx = 0;
1032     static int getinter = 0;
1033
1034     if (!getinter) {
1035         idx = MTestGetIntracomm(comm, min_size);
1036         if (idx == 0) {
1037             getinter = 1;
1038         }
1039     }
1040     if (getinter) {
1041         int isLeft;
1042         idx = MTestGetIntercomm(comm, &isLeft, min_size);
1043         if (idx == 0) {
1044             getinter = 0;
1045         }
1046     }
1047
1048     return idx;
1049 }
1050
1051 /* Free a communicator.  It may be called with a predefined communicator
1052  or MPI_COMM_NULL */
1053 void MTestFreeComm(MPI_Comm * comm)
1054 {
1055     int merr;
1056     if (*comm != MPI_COMM_WORLD && *comm != MPI_COMM_SELF && *comm != MPI_COMM_NULL) {
1057         merr = MPI_Comm_free(comm);
1058         if (merr)
1059             MTestPrintError(merr);
1060     }
1061 }
1062
1063 /* ------------------------------------------------------------------------ */
1064 void MTestPrintError(int errcode)
1065 {
1066     int errclass, slen;
1067     char string[MPI_MAX_ERROR_STRING];
1068
1069     MPI_Error_class(errcode, &errclass);
1070     MPI_Error_string(errcode, string, &slen);
1071     printf("Error class %d (%s)\n", errclass, string);
1072     fflush(stdout);
1073 }
1074
1075 void MTestPrintErrorMsg(const char msg[], int errcode)
1076 {
1077     int errclass, slen;
1078     char string[MPI_MAX_ERROR_STRING];
1079
1080     MPI_Error_class(errcode, &errclass);
1081     MPI_Error_string(errcode, string, &slen);
1082     printf("%s: Error class %d (%s)\n", msg, errclass, string);
1083     fflush(stdout);
1084 }
1085
1086 /* ------------------------------------------------------------------------ */
1087 /*
1088  If verbose output is selected and the level is at least that of the
1089  value of the verbose flag, then perform printf(format, ...);
1090  */
1091 void MTestPrintfMsg(int level, const char format[], ...)
1092 {
1093     va_list list;
1094
1095     if (SMPI_VARGET_GLOBAL(verbose) && level <= SMPI_VARGET_GLOBAL(verbose)) {
1096         va_start(list, format);
1097         vprintf(format, list);
1098         va_end(list);
1099         fflush(stdout);
1100     }
1101 }
1102
1103 /* Fatal error.  Report and exit */
1104 void MTestError(const char *msg)
1105 {
1106     fprintf(stderr, "%s\n", msg);
1107     fflush(stderr);
1108     MPI_Abort(MPI_COMM_WORLD, 1);
1109 }
1110
1111 /* ------------------------------------------------------------------------ */
1112 static void MTestResourceSummary(FILE * fp)
1113 {
1114 #ifdef HAVE_GETRUSAGE
1115     struct rusage ru;
1116     static int pfThreshold = -2;
1117     int doOutput = 1;
1118     if (getrusage(RUSAGE_SELF, &ru) == 0) {
1119         /* There is an option to generate output only when a resource
1120          * exceeds a threshold.  To date, only page faults supported. */
1121         if (pfThreshold == -2) {
1122             char *p = getenv("MPITEST_RUSAGE_PF");
1123             pfThreshold = -1;
1124             if (p) {
1125                 pfThreshold = strtol(p, 0, 0);
1126             }
1127         }
1128         if (pfThreshold > 0) {
1129             doOutput = ru.ru_minflt > pfThreshold;
1130         }
1131         if (doOutput) {
1132             /* Cast values to long in case some system has defined them
1133              * as another integer type */
1134             fprintf(fp, "RUSAGE: max resident set = %ldKB\n", (long) ru.ru_maxrss);
1135             fprintf(fp, "RUSAGE: page faults = %ld : %ld\n",
1136                     (long) ru.ru_minflt, (long) ru.ru_majflt);
1137             /* Not every Unix provides useful information for the xxrss fields */
1138             fprintf(fp, "RUSAGE: memory in text/data/stack = %ld : %ld : %ld\n",
1139                     (long) ru.ru_ixrss, (long) ru.ru_idrss, (long) ru.ru_isrss);
1140             fprintf(fp, "RUSAGE: I/O in and out = %ld : %ld\n",
1141                     (long) ru.ru_inblock, (long) ru.ru_oublock);
1142             fprintf(fp, "RUSAGE: context switch = %ld : %ld\n",
1143                     (long) ru.ru_nvcsw, (long) ru.ru_nivcsw);
1144         }
1145     }
1146     else {
1147         fprintf(fp, "RUSAGE: return error %d\n", errno);
1148     }
1149 #endif
1150 }
1151
1152 /* ------------------------------------------------------------------------ */
1153 #ifdef HAVE_MPI_WIN_CREATE
1154 /*
1155  * Create MPI Windows
1156  */
1157 SMPI_VARINIT_GLOBAL_AND_SET(win_index, int, 0);
1158 SMPI_VARINIT_GLOBAL(winName, const char *);
1159 /* Use an attribute to remember the type of memory allocation (static,
1160    malloc, or MPI_Alloc_mem) */
1161 SMPI_VARINIT_GLOBAL_AND_SET(mem_keyval, int, MPI_KEYVAL_INVALID);
1162 int MTestGetWin(MPI_Win * win, int mustBePassive)
1163 {
1164     static char actbuf[1024];
1165     static char *pasbuf;
1166     char *buf;
1167     int n, rank, merr;
1168     MPI_Info info;
1169
1170     if (SMPI_VARGET_GLOBAL(mem_keyval) == MPI_KEYVAL_INVALID) {
1171         /* Create the keyval */
1172         merr = MPI_Win_create_keyval(MPI_WIN_NULL_COPY_FN, MPI_WIN_NULL_DELETE_FN, &SMPI_VARGET_GLOBAL(mem_keyval), 0);
1173         if (merr)
1174             MTestPrintError(merr);
1175
1176     }
1177
1178     switch (SMPI_VARGET_GLOBAL(win_index)) {
1179     case 0:
1180         /* Active target window */
1181         merr = MPI_Win_create(actbuf, 1024, 1, MPI_INFO_NULL, MPI_COMM_WORLD, win);
1182         if (merr)
1183             MTestPrintError(merr);
1184         SMPI_VARGET_GLOBAL(winName) = "active-window";
1185         merr = MPI_Win_set_attr(*win, SMPI_VARGET_GLOBAL(mem_keyval), (void *) 0);
1186         if (merr)
1187             MTestPrintError(merr);
1188         break;
1189     case 1:
1190         /* Passive target window */
1191         merr = MPI_Alloc_mem(1024, MPI_INFO_NULL, &pasbuf);
1192         if (merr)
1193             MTestPrintError(merr);
1194         merr = MPI_Win_create(pasbuf, 1024, 1, MPI_INFO_NULL, MPI_COMM_WORLD, win);
1195         if (merr)
1196             MTestPrintError(merr);
1197         SMPI_VARGET_GLOBAL(winName) = "passive-window";
1198         merr = MPI_Win_set_attr(*win, SMPI_VARGET_GLOBAL(mem_keyval), (void *) 2);
1199         if (merr)
1200             MTestPrintError(merr);
1201         break;
1202     case 2:
1203         /* Active target; all windows different sizes */
1204         merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
1205         if (merr)
1206             MTestPrintError(merr);
1207         n = rank * 64;
1208         if (n)
1209             buf = (char *) malloc(n);
1210         else
1211             buf = 0;
1212         merr = MPI_Win_create(buf, n, 1, MPI_INFO_NULL, MPI_COMM_WORLD, win);
1213         if (merr)
1214             MTestPrintError(merr);
1215         SMPI_VARGET_GLOBAL(winName) = "active-all-different-win";
1216         merr = MPI_Win_set_attr(*win, SMPI_VARGET_GLOBAL(mem_keyval), (void *) 1);
1217         if (merr)
1218             MTestPrintError(merr);
1219         break;
1220     case 3:
1221         /* Active target, no locks set */
1222         merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
1223         if (merr)
1224             MTestPrintError(merr);
1225         n = rank * 64;
1226         if (n)
1227             buf = (char *) malloc(n);
1228         else
1229             buf = 0;
1230         merr = MPI_Info_create(&info);
1231         if (merr)
1232             MTestPrintError(merr);
1233         merr = MPI_Info_set(info, (char *) "nolocks", (char *) "true");
1234         if (merr)
1235             MTestPrintError(merr);
1236         merr = MPI_Win_create(buf, n, 1, info, MPI_COMM_WORLD, win);
1237         if (merr)
1238             MTestPrintError(merr);
1239         merr = MPI_Info_free(&info);
1240         if (merr)
1241             MTestPrintError(merr);
1242         SMPI_VARGET_GLOBAL(winName) = "active-nolocks-all-different-win";
1243         merr = MPI_Win_set_attr(*win, SMPI_VARGET_GLOBAL(mem_keyval), (void *) 1);
1244         if (merr)
1245             MTestPrintError(merr);
1246         break;
1247     default:
1248         SMPI_VARGET_GLOBAL(win_index) = -1;
1249     }
1250     SMPI_VARGET_GLOBAL(win_index)++;
1251     return SMPI_VARGET_GLOBAL(win_index);
1252 }
1253
1254 /* Return a pointer to the name associated with a window object */
1255 const char *MTestGetWinName(void)
1256 {
1257     return SMPI_VARGET_GLOBAL(winName);
1258 }
1259
1260 /* Free the storage associated with a window object */
1261 void MTestFreeWin(MPI_Win * win)
1262 {
1263     void *addr;
1264     int flag, merr;
1265
1266     merr = MPI_Win_get_attr(*win, MPI_WIN_BASE, &addr, &flag);
1267     if (merr)
1268         MTestPrintError(merr);
1269     if (!flag) {
1270         MTestError("Could not get WIN_BASE from window");
1271     }
1272     if (addr) {
1273         void *val;
1274         merr = MPI_Win_get_attr(*win, SMPI_VARGET_GLOBAL(mem_keyval), &val, &flag);
1275         if (merr)
1276             MTestPrintError(merr);
1277         if (flag) {
1278             if (val == (void *) 1) {
1279                 free(addr);
1280             }
1281             else if (val == (void *) 2) {
1282                 merr = MPI_Free_mem(addr);
1283                 if (merr)
1284                     MTestPrintError(merr);
1285             }
1286             /* if val == (void *)0, then static data that must not be freed */
1287         }
1288     }
1289     merr = MPI_Win_free(win);
1290     if (merr)
1291         MTestPrintError(merr);
1292 }
1293
1294 static void MTestRMACleanup(void)
1295 {
1296     if (SMPI_VARGET_GLOBAL(mem_keyval) != MPI_KEYVAL_INVALID) {
1297         MPI_Win_free_keyval(&SMPI_VARGET_GLOBAL(mem_keyval));
1298     }
1299 }
1300 #else
1301 static void MTestRMACleanup(void)
1302 {
1303 }
1304 #endif
1305
1306 /* ------------------------------------------------------------------------ */
1307 /* This function determines if it is possible to spawn addition MPI
1308  * processes using MPI_COMM_SPAWN and MPI_COMM_SPAWN_MULTIPLE.
1309  *
1310  * It sets the can_spawn value to one of the following:
1311  * 1  = yes, additional processes can be spawned
1312  * 0  = no, MPI_UNIVERSE_SIZE <= the size of MPI_COMM_WORLD
1313  * -1 = it is unknown whether or not processes can be spawned
1314  *      due to errors in the necessary query functions
1315  *
1316  */
1317 int MTestSpawnPossible(int *can_spawn)
1318 {
1319     int errs = 0;
1320
1321     void *v = NULL;
1322     int flag = -1;
1323     int vval = -1;
1324     int rc;
1325
1326     rc = MPI_Comm_get_attr(MPI_COMM_WORLD, MPI_UNIVERSE_SIZE, &v, &flag);
1327     if (rc != MPI_SUCCESS) {
1328         /* MPI_UNIVERSE_SIZE keyval missing from MPI_COMM_WORLD attributes */
1329         *can_spawn = -1;
1330         errs++;
1331     }
1332     else {
1333         /* MPI_UNIVERSE_SIZE need not be set */
1334         if (flag) {
1335
1336             int size = -1;
1337             rc = MPI_Comm_size(MPI_COMM_WORLD, &size);
1338             if (rc != MPI_SUCCESS) {
1339                 /* MPI_Comm_size failed for MPI_COMM_WORLD */
1340                 *can_spawn = -1;
1341                 errs++;
1342             }
1343
1344             vval = *(int *) v;
1345             if (vval <= size) {
1346                 /* no additional processes can be spawned */
1347                 *can_spawn = 0;
1348             }
1349             else {
1350                 *can_spawn = 1;
1351             }
1352         }
1353         else {
1354             /* No attribute associated with key MPI_UNIVERSE_SIZE of MPI_COMM_WORLD */
1355             *can_spawn = -1;
1356         }
1357     }
1358     return errs;
1359 }
1360
1361 /* ------------------------------------------------------------------------ */