teshsuite/smpi/mpich3-test/util/mtest.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 static int dbgflag = 0;         /* Flag used for debugging */
  52 static int wrank = -1;          /* World rank */
  53 static int verbose = 0;         /* Message level (0 is none) */
  54 static int returnWithVal = 0;   /* Allow programs to return with a non-zero
  55                                    if there was an error (may cause problems
  56                                    with some runtime systems) */
  57 static int usageOutput = 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         dbgflag = 1;
 102         MPI_Comm_rank( MPI_COMM_WORLD, &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",
 113                      envval );
 114             fflush( stderr );
 115         }
 116         else {
 117             if (val >= 0) {
 118                 verbose = val;
 119             }
 120             else {
 121                 fprintf( stderr, "Warning: %s not valid for MPITEST_VERBOSE\n",
 122                          envval );
 123                 fflush( stderr );
 124             }
 125         }
 126     }
 127     /* Check for option to return success/failure in the return value of main */
 128     envval = getenv( "MPITEST_RETURN_WITH_CODE" );
 129     if (envval) {
 130         if (strcmp( envval, "yes" ) == 0 ||
 131             strcmp( envval, "YES" ) == 0 ||
 132             strcmp( envval, "true" ) == 0 ||
 133             strcmp( envval, "TRUE" ) == 0) {
 134             returnWithVal = 1;
 135         }
 136         else if (strcmp( envval, "no" ) == 0 ||
 137             strcmp( envval, "NO" ) == 0 ||
 138             strcmp( envval, "false" ) == 0 ||
 139             strcmp( envval, "FALSE" ) == 0) {
 140             returnWithVal = 0;
 141         }
 142         else {
 143             fprintf( stderr,
 144                      "Warning: %s not valid for MPITEST_RETURN_WITH_CODE\n",
 145                      envval );
 146             fflush( stderr );
 147         }
 148     }
 149
 150     /* Print rusage data if set */
 151     if (getenv( "MPITEST_RUSAGE" )) {
 152         usageOutput = 1;
 153     }
 154 }
 155 /*
 156  * Initialize the tests, using an MPI-1 style init.  Supports
 157  * MTEST_THREADLEVEL_DEFAULT to test with user-specified thread level
 158  */
 159 void MTest_Init( int *argc, char ***argv )
 160 {
 161     int provided;
 162 #if MPI_VERSION >= 2 || defined(HAVE_MPI_INIT_THREAD)
 163     const char *str = 0;
 164     int        threadLevel;
 165
 166     threadLevel = MPI_THREAD_SINGLE;
 167     str = getenv( "MTEST_THREADLEVEL_DEFAULT" );
 168     if (!str) str = getenv( "MPITEST_THREADLEVEL_DEFAULT" );
 169     if (str && *str) {
 170         if (strcmp(str,"MULTIPLE") == 0 || strcmp(str,"multiple") == 0) {
 171             threadLevel = MPI_THREAD_MULTIPLE;
 172         }
 173         else if (strcmp(str,"SERIALIZED") == 0 ||
 174                  strcmp(str,"serialized") == 0) {
 175             threadLevel = MPI_THREAD_SERIALIZED;
 176         }
 177         else if (strcmp(str,"FUNNELED") == 0 || strcmp(str,"funneled") == 0) {
 178             threadLevel = MPI_THREAD_FUNNELED;
 179         }
 180         else if (strcmp(str,"SINGLE") == 0 || strcmp(str,"single") == 0) {
 181             threadLevel = MPI_THREAD_SINGLE;
 182         }
 183         else {
 184             fprintf( stderr, "Unrecognized thread level %s\n", str );
 185             /* Use exit since MPI_Init/Init_thread has not been called. */
 186             exit(1);
 187         }
 188     }
 189     MTest_Init_thread( argc, argv, threadLevel, &provided );
 190 #else
 191     /* If the MPI_VERSION is 1, there is no MPI_THREAD_xxx defined */
 192     MTest_Init_thread( argc, argv, 0, &provided );
 193 #endif
 194 }
 195
 196 /*
 197   Finalize MTest.  errs is the number of errors on the calling process;
 198   this routine will write the total number of errors over all of MPI_COMM_WORLD
 199   to the process with rank zero, or " No Errors".
 200   It does *not* finalize MPI.
 201  */
 202 void MTest_Finalize( int errs )
 203 {
 204     int rank, toterrs, merr;
 205
 206     merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
 207     if (merr) MTestPrintError( merr );
 208
 209     merr = MPI_Reduce( &errs, &toterrs, 1, MPI_INT, MPI_SUM,
 210                       0, MPI_COMM_WORLD );
 211     if (merr) MTestPrintError( merr );
 212     if (rank == 0) {
 213         if (toterrs) {
 214             printf( " Found %d errors\n", toterrs );
 215         }
 216         else {
 217             printf( " No Errors\n" );
 218         }
 219         fflush( stdout );
 220     }
 221
 222     if (usageOutput)
 223         MTestResourceSummary( stdout );
 224
 225
 226     /* Clean up any persistent objects that we allocated */
 227     MTestRMACleanup();
 228 }
 229 /* ------------------------------------------------------------------------ */
 230 /* This routine may be used instead of "return 0;" at the end of main;
 231    it allows the program to use the return value to signal success or failure.
 232  */
 233 int MTestReturnValue( int errors )
 234 {
 235     if (returnWithVal) return errors ? 1 : 0;
 236     return 0;
 237 }
 238 /* ------------------------------------------------------------------------ */
 239
 240 /*
 241  * Miscellaneous utilities, particularly to eliminate OS dependencies
 242  * from the tests.
 243  * MTestSleep( seconds )
 244  */
 245 #ifdef _WIN32
 246 #include <windows.h>
 247 void MTestSleep( int sec )
 248 {
 249     Sleep( 1000 * sec );
 250 }
 251 #else
 252 #include <unistd.h>
 253 void MTestSleep( int sec )
 254 {
 255     sleep( sec );
 256 }
 257 #endif
 258
 259 /*
 260  * Datatypes
 261  *
 262  * Eventually, this could read a description of a file.  For now, we hard
 263  * code the choices.
 264  *
 265  * Each kind of datatype has the following functions:
 266  *    MTestTypeXXXInit     - Initialize a send buffer for that type
 267  *    MTestTypeXXXInitRecv - Initialize a receive buffer for that type
 268  *    MTestTypeXXXFree     - Free any buffers associate with that type
 269  *    MTestTypeXXXCheckbuf - Check that the buffer contains the expected data
 270  * These routines work with (nearly) any datatype that is of type XXX,
 271  * allowing the test codes to create a variety of contiguous, vector, and
 272  * indexed types, then test them by calling these routines.
 273  *
 274  * Available types (for the XXX) are
 275  *    Contig   - Simple contiguous buffers
 276  *    Vector   - Simple strided "vector" type
 277  *    Indexed  - Indexed datatype.  Only for a count of 1 instance of the
 278  *               datatype
 279  */
 280 static int datatype_index = 0;
 281
 282 /* ------------------------------------------------------------------------ */
 283 /* Datatype routines for contiguous datatypes                               */
 284 /* ------------------------------------------------------------------------ */
 285 /*
 286  * Setup contiguous buffers of n copies of a datatype.
 287  */
 288 static void *MTestTypeContigInit( MTestDatatype *mtype )
 289 {
 290     MPI_Aint size;
 291     int merr;
 292
 293     if (mtype->count > 0) {
 294         signed char *p;
 295         int  i, totsize;
 296         merr = MPI_Type_extent( mtype->datatype, &size );
 297         if (merr) MTestPrintError( merr );
 298         totsize = size * mtype->count;
 299         if (!mtype->buf) {
 300             mtype->buf = (void *) malloc( totsize );
 301         }
 302         p = (signed char *)(mtype->buf);
 303         if (!p) {
 304             /* Error - out of memory */
 305             MTestError( "Out of memory in type buffer init" );
 306         }
 307         for (i=0; i<totsize; i++) {
 308             p[i] = 0xff ^ (i & 0xff);
 309         }
 310     }
 311     else {
 312         if (mtype->buf) {
 313             free( mtype->buf );
 314         }
 315         mtype->buf = 0;
 316     }
 317     return mtype->buf;
 318 }
 319
 320 /*
 321  * Setup contiguous buffers of n copies of a datatype.  Initialize for
 322  * reception (e.g., set initial data to detect failure)
 323  */
 324 static void *MTestTypeContigInitRecv( MTestDatatype *mtype )
 325 {
 326     MPI_Aint size;
 327     int      merr;
 328
 329     if (mtype->count > 0) {
 330         signed char *p;
 331         int  i, totsize;
 332         merr = MPI_Type_extent( mtype->datatype, &size );
 333         if (merr) MTestPrintError( merr );
 334         totsize = size * mtype->count;
 335         if (!mtype->buf) {
 336             mtype->buf = (void *) malloc( totsize );
 337         }
 338         p = (signed char *)(mtype->buf);
 339         if (!p) {
 340             /* Error - out of memory */
 341             MTestError( "Out of memory in type buffer init" );
 342         }
 343         for (i=0; i<totsize; i++) {
 344             p[i] = 0xff;
 345         }
 346     }
 347     else {
 348         if (mtype->buf) {
 349             free( mtype->buf );
 350         }
 351         mtype->buf = 0;
 352     }
 353     return mtype->buf;
 354 }
 355 static void *MTestTypeContigFree( MTestDatatype *mtype )
 356 {
 357     if (mtype->buf) {
 358         free( mtype->buf );
 359         mtype->buf = 0;
 360     }
 361     return 0;
 362 }
 363 static int MTestTypeContigCheckbuf( MTestDatatype *mtype )
 364 {
 365     unsigned char *p;
 366     unsigned char expected;
 367     int  i, totsize, err = 0, merr;
 368     MPI_Aint size;
 369
 370     p = (unsigned char *)mtype->buf;
 371     if (p) {
 372         merr = MPI_Type_extent( mtype->datatype, &size );
 373         if (merr) MTestPrintError( merr );
 374         totsize = size * mtype->count;
 375         for (i=0; i<totsize; i++) {
 376             expected = (0xff ^ (i & 0xff));
 377             if (p[i] != expected) {
 378                 err++;
 379                 if (mtype->printErrors && err < 10) {
 380                     printf( "Data expected = %x but got p[%d] = %x\n",
 381                             expected, i, p[i] );
 382                     fflush( stdout );
 383                 }
 384             }
 385         }
 386     }
 387     return err;
 388 }
 389
 390 /* ------------------------------------------------------------------------ */
 391 /* Datatype routines for vector datatypes                                   */
 392 /* ------------------------------------------------------------------------ */
 393
 394 static void *MTestTypeVectorInit( MTestDatatype *mtype )
 395 {
 396     MPI_Aint size;
 397     int      merr;
 398
 399     if (mtype->count > 0) {
 400         unsigned char *p;
 401         int  i, j, k, nc, totsize;
 402
 403         merr = MPI_Type_extent( mtype->datatype, &size );
 404         if (merr) MTestPrintError( merr );
 405         totsize    = mtype->count * size;
 406         if (!mtype->buf) {
 407             mtype->buf = (void *) malloc( totsize );
 408         }
 409         p          = (unsigned char *)(mtype->buf);
 410         if (!p) {
 411             /* Error - out of memory */
 412             MTestError( "Out of memory in type buffer init" );
 413         }
 414
 415         /* First, set to -1 */
 416         for (i=0; i<totsize; i++) p[i] = 0xff;
 417
 418         /* Now, set the actual elements to the successive values.
 419            To do this, we need to run 3 loops */
 420         nc = 0;
 421         /* count is usually one for a vector type */
 422         for (k=0; k<mtype->count; k++) {
 423             /* For each element (block) */
 424             for (i=0; i<mtype->nelm; i++) {
 425                 /* For each value */
 426                 for (j=0; j<mtype->blksize; j++) {
 427                     p[j] = (0xff ^ (nc & 0xff));
 428                     nc++;
 429                 }
 430                 p += mtype->stride;
 431             }
 432         }
 433     }
 434     else {
 435         mtype->buf = 0;
 436     }
 437     return mtype->buf;
 438 }
 439
 440 static void *MTestTypeVectorFree( MTestDatatype *mtype )
 441 {
 442     if (mtype->buf) {
 443         free( mtype->buf );
 444         mtype->buf = 0;
 445     }
 446     return 0;
 447 }
 448
 449 /* ------------------------------------------------------------------------ */
 450 /* Datatype routines for indexed block datatypes                            */
 451 /* ------------------------------------------------------------------------ */
 452
 453 /*
 454  * Setup a buffer for one copy of an indexed datatype.
 455  */
 456 static void *MTestTypeIndexedInit( MTestDatatype *mtype )
 457 {
 458     MPI_Aint totsize;
 459     int      merr;
 460
 461     if (mtype->count > 1) {
 462         MTestError( "This datatype is supported only for a single count" );
 463     }
 464     if (mtype->count == 1) {
 465         signed char *p;
 466         int  i, k, offset, j;
 467
 468         /* Allocate the send/recv buffer */
 469         merr = MPI_Type_extent( mtype->datatype, &totsize );
 470         if (merr) MTestPrintError( merr );
 471         if (!mtype->buf) {
 472             mtype->buf = (void *) malloc( totsize );
 473         }
 474         p = (signed char *)(mtype->buf);
 475         if (!p) {
 476             MTestError( "Out of memory in type buffer init\n" );
 477         }
 478         /* Initialize the elements */
 479         /* First, set to -1 */
 480         for (i=0; i<totsize; i++) p[i] = 0xff;
 481
 482         /* Now, set the actual elements to the successive values.
 483            We require that the base type is a contiguous type */
 484         k = 0;
 485         for (i=0; i<mtype->nelm; i++) {
 486             int b;
 487             /* Compute the offset: */
 488             offset = mtype->displs[i] * mtype->basesize;
 489             /* For each element in the block */
 490             for (b=0; b<mtype->index[i]; b++) {
 491                 for (j=0; j<mtype->basesize; j++) {
 492                     p[offset+j] = 0xff ^ (k++ & 0xff);
 493                 }
 494                 offset += mtype->basesize;
 495             }
 496         }
 497     }
 498     else {
 499         /* count == 0 */
 500         if (mtype->buf) {
 501             free( mtype->buf );
 502         }
 503         mtype->buf = 0;
 504     }
 505     return mtype->buf;
 506 }
 507
 508 /*
 509  * Setup indexed buffers for 1 copy of a datatype.  Initialize for
 510  * reception (e.g., set initial data to detect failure)
 511  */
 512 static void *MTestTypeIndexedInitRecv( MTestDatatype *mtype )
 513 {
 514     MPI_Aint totsize;
 515     int      merr;
 516
 517     if (mtype->count > 1) {
 518         MTestError( "This datatype is supported only for a single count" );
 519     }
 520     if (mtype->count == 1) {
 521         signed char *p;
 522         int  i;
 523         merr = MPI_Type_extent( mtype->datatype, &totsize );
 524         if (merr) MTestPrintError( merr );
 525         if (!mtype->buf) {
 526             mtype->buf = (void *) malloc( totsize );
 527         }
 528         p = (signed char *)(mtype->buf);
 529         if (!p) {
 530             /* Error - out of memory */
 531             MTestError( "Out of memory in type buffer init\n" );
 532         }
 533         for (i=0; i<totsize; i++) {
 534             p[i] = 0xff;
 535         }
 536     }
 537     else {
 538         /* count == 0 */
 539         if (mtype->buf) {
 540             free( mtype->buf );
 541         }
 542         mtype->buf = 0;
 543     }
 544     return mtype->buf;
 545 }
 546
 547 static void *MTestTypeIndexedFree( MTestDatatype *mtype )
 548 {
 549     if (mtype->buf)
 550       free( mtype->buf );
 551         free( mtype->displs );
 552         free( mtype->index );
 553         mtype->buf    = 0;
 554         mtype->displs = 0;
 555         mtype->index  = 0;
 556     return 0;
 557 }
 558
 559 static int MTestTypeIndexedCheckbuf( MTestDatatype *mtype )
 560 {
 561     unsigned char *p;
 562     unsigned char expected;
 563     int  i, err = 0, merr;
 564     MPI_Aint totsize;
 565
 566     p = (unsigned char *)mtype->buf;
 567     if (p) {
 568         int j, k, offset;
 569         merr = MPI_Type_extent( mtype->datatype, &totsize );
 570         if (merr) MTestPrintError( merr );
 571
 572         k = 0;
 573         for (i=0; i<mtype->nelm; i++) {
 574             int b;
 575             /* Compute the offset: */
 576             offset = mtype->displs[i] * mtype->basesize;
 577             for (b=0; b<mtype->index[i]; b++) {
 578                 for (j=0; j<mtype->basesize; j++) {
 579                     expected = (0xff ^ (k & 0xff));
 580                     if (p[offset+j] != expected) {
 581                         err++;
 582                         if (mtype->printErrors && err < 10) {
 583                             printf( "Data expected = %x but got p[%d,%d] = %x\n",
 584                                     expected, i,j, p[offset+j] );
 585                             fflush( stdout );
 586                         }
 587                     }
 588                     k++;
 589                 }
 590                 offset += mtype->basesize;
 591             }
 592         }
 593     }
 594     return err;
 595 }
 596
 597
 598 /* ------------------------------------------------------------------------ */
 599 /* Routines to select a datatype and associated buffer create/fill/check    */
 600 /* routines                                                                 */
 601 /* ------------------------------------------------------------------------ */
 602
 603 /*
 604    Create a range of datatypes with a given count elements.
 605    This uses a selection of types, rather than an exhaustive collection.
 606    It allocates both send and receive types so that they can have the same
 607    type signature (collection of basic types) but different type maps (layouts
 608    in memory)
 609  */
 610 int MTestGetDatatypes( MTestDatatype *sendtype, MTestDatatype *recvtype,
 611                        int count )
 612 {
 613     int merr;
 614     int i;
 615
 616     sendtype->InitBuf     = 0;
 617     sendtype->FreeBuf     = 0;
 618     sendtype->CheckBuf    = 0;
 619     sendtype->datatype    = 0;
 620     sendtype->isBasic     = 0;
 621     sendtype->printErrors = 0;
 622     recvtype->InitBuf     = 0;
 623     recvtype->FreeBuf     = 0;
 624
 625     recvtype->CheckBuf    = 0;
 626     recvtype->datatype    = 0;
 627     recvtype->isBasic     = 0;
 628     recvtype->printErrors = 0;
 629
 630     sendtype->buf         = 0;
 631     recvtype->buf         = 0;
 632
 633     /* Set the defaults for the message lengths */
 634     sendtype->count       = count;
 635     recvtype->count       = count;
 636     /* Use datatype_index to choose a datatype to use.  If at the end of the
 637        list, return 0 */
 638     switch (datatype_index) {
 639     case 0:
 640         sendtype->datatype = MPI_INT;
 641         sendtype->isBasic  = 1;
 642         recvtype->datatype = MPI_INT;
 643         recvtype->isBasic  = 1;
 644         break;
 645     case 1:
 646         sendtype->datatype = MPI_DOUBLE;
 647         sendtype->isBasic  = 1;
 648         recvtype->datatype = MPI_DOUBLE;
 649         recvtype->isBasic  = 1;
 650         break;
 651     case 2:
 652         sendtype->datatype = MPI_FLOAT_INT;
 653         sendtype->isBasic  = 1;
 654         recvtype->datatype = MPI_FLOAT_INT;
 655         recvtype->isBasic  = 1;
 656         break;
 657     case 3:
 658         merr = MPI_Type_dup( MPI_INT, &sendtype->datatype );
 659         if (merr) MTestPrintError( merr );
 660         merr = MPI_Type_set_name( sendtype->datatype,
 661                                   (char*)"dup of MPI_INT" );
 662         if (merr) MTestPrintError( merr );
 663         merr = MPI_Type_dup( MPI_INT, &recvtype->datatype );
 664         if (merr) MTestPrintError( merr );
 665         merr = MPI_Type_set_name( recvtype->datatype,
 666                                   (char*)"dup of MPI_INT" );
 667         if (merr) MTestPrintError( merr );
 668         /* dup'ed types are already committed if the original type
 669            was committed (MPI-2, section 8.8) */
 670         break;
 671     case 4:
 672         /* vector send type and contiguous receive type */
 673         /* These sizes are in bytes (see the VectorInit code) */
 674         sendtype->stride   = 3 * sizeof(int);
 675         sendtype->blksize  = sizeof(int);
 676         sendtype->nelm     = recvtype->count;
 677
 678         merr = MPI_Type_vector( recvtype->count, 1, 3, MPI_INT,
 679                                 &sendtype->datatype );
 680         if (merr) MTestPrintError( merr );
 681         merr = MPI_Type_commit( &sendtype->datatype );
 682         if (merr) MTestPrintError( merr );
 683         merr = MPI_Type_set_name( sendtype->datatype,
 684                                   (char*)"int-vector" );
 685         if (merr) MTestPrintError( merr );
 686         sendtype->count    = 1;
 687         recvtype->datatype = MPI_INT;
 688         recvtype->isBasic  = 1;
 689         sendtype->InitBuf  = MTestTypeVectorInit;
 690         recvtype->InitBuf  = MTestTypeContigInitRecv;
 691         sendtype->FreeBuf  = MTestTypeVectorFree;
 692         recvtype->FreeBuf  = MTestTypeContigFree;
 693         sendtype->CheckBuf = 0;
 694         recvtype->CheckBuf = MTestTypeContigCheckbuf;
 695         break;
 696
 697     case 5:
 698         /* Indexed send using many small blocks and contig receive */
 699         sendtype->blksize  = sizeof(int);
 700         sendtype->nelm     = recvtype->count;
 701         sendtype->basesize = sizeof(int);
 702         sendtype->displs   = (int *)malloc( sendtype->nelm * sizeof(int) );
 703         sendtype->index    = (int *)malloc( sendtype->nelm * sizeof(int) );
 704         if (!sendtype->displs || !sendtype->index) {
 705             MTestError( "Out of memory in type init\n" );
 706         }
 707         /* Make the sizes larger (4 ints) to help push the total
 708            size to over 256k in some cases, as the MPICH code as of
 709            10/1/06 used large internal buffers for packing non-contiguous
 710            messages */
 711         for (i=0; i<sendtype->nelm; i++) {
 712             sendtype->index[i]   = 4;
 713             sendtype->displs[i]  = 5*i;
 714         }
 715         merr = MPI_Type_indexed( sendtype->nelm,
 716                                  sendtype->index, sendtype->displs,
 717                                  MPI_INT, &sendtype->datatype );
 718         if (merr) MTestPrintError( merr );
 719         merr = MPI_Type_commit( &sendtype->datatype );
 720         if (merr) MTestPrintError( merr );
 721         merr = MPI_Type_set_name( sendtype->datatype,
 722                                   (char*)"int-indexed(4-int)" );
 723         if (merr) MTestPrintError( merr );
 724         sendtype->count    = 1;
 725         sendtype->InitBuf  = MTestTypeIndexedInit;
 726         sendtype->FreeBuf  = MTestTypeIndexedFree;
 727         sendtype->CheckBuf = 0;
 728
 729         recvtype->datatype = MPI_INT;
 730         recvtype->isBasic  = 1;
 731         recvtype->count    = count * 4;
 732         recvtype->InitBuf  = MTestTypeContigInitRecv;
 733         recvtype->FreeBuf  = MTestTypeContigFree;
 734         recvtype->CheckBuf = MTestTypeContigCheckbuf;
 735         break;
 736
 737     case 6:
 738         /* Indexed send using 2 large blocks and contig receive */
 739         sendtype->blksize  = sizeof(int);
 740         sendtype->nelm     = 2;
 741         sendtype->basesize = sizeof(int);
 742         sendtype->displs   = (int *)malloc( sendtype->nelm * sizeof(int) );
 743         sendtype->index    = (int *)malloc( sendtype->nelm * sizeof(int) );
 744         if (!sendtype->displs || !sendtype->index) {
 745             MTestError( "Out of memory in type init\n" );
 746         }
 747         /* index -> block size */
 748         sendtype->index[0]   = (recvtype->count + 1) / 2;
 749         sendtype->displs[0]  = 0;
 750         sendtype->index[1]   = recvtype->count - sendtype->index[0];
 751         sendtype->displs[1]  = sendtype->index[0] + 1;
 752         /* There is a deliberate gap here */
 753
 754         merr = MPI_Type_indexed( sendtype->nelm,
 755                                  sendtype->index, sendtype->displs,
 756                                  MPI_INT, &sendtype->datatype );
 757         if (merr) MTestPrintError( merr );
 758         merr = MPI_Type_commit( &sendtype->datatype );
 759         if (merr) MTestPrintError( merr );
 760         merr = MPI_Type_set_name( sendtype->datatype,
 761                                   (char*)"int-indexed(2 blocks)" );
 762         if (merr) MTestPrintError( merr );
 763         sendtype->count    = 1;
 764         sendtype->InitBuf  = MTestTypeIndexedInit;
 765         sendtype->FreeBuf  = MTestTypeIndexedFree;
 766         sendtype->CheckBuf = 0;
 767
 768         recvtype->datatype = MPI_INT;
 769         recvtype->isBasic  = 1;
 770         recvtype->count    = sendtype->index[0] + sendtype->index[1];
 771         recvtype->InitBuf  = MTestTypeContigInitRecv;
 772         recvtype->FreeBuf  = MTestTypeContigFree;
 773         recvtype->CheckBuf = MTestTypeContigCheckbuf;
 774         break;
 775
 776     case 7:
 777         /* Indexed receive using many small blocks and contig send */
 778         recvtype->blksize  = sizeof(int);
 779         recvtype->nelm     = recvtype->count;
 780         recvtype->basesize = sizeof(int);
 781         recvtype->displs   = (int *)malloc( recvtype->nelm * sizeof(int) );
 782         recvtype->index    = (int *)malloc( recvtype->nelm * sizeof(int) );
 783         if (!recvtype->displs || !recvtype->index) {
 784             MTestError( "Out of memory in type recv init\n" );
 785         }
 786         /* Make the sizes larger (4 ints) to help push the total
 787            size to over 256k in some cases, as the MPICH code as of
 788            10/1/06 used large internal buffers for packing non-contiguous
 789            messages */
 790         /* Note that there are gaps in the indexed type */
 791         for (i=0; i<recvtype->nelm; i++) {
 792             recvtype->index[i]   = 4;
 793             recvtype->displs[i]  = 5*i;
 794         }
 795         merr = MPI_Type_indexed( recvtype->nelm,
 796                                  recvtype->index, recvtype->displs,
 797                                  MPI_INT, &recvtype->datatype );
 798         if (merr) MTestPrintError( merr );
 799         merr = MPI_Type_commit( &recvtype->datatype );
 800         if (merr) MTestPrintError( merr );
 801         merr = MPI_Type_set_name( recvtype->datatype,
 802                                   (char*)"recv-int-indexed(4-int)" );
 803         if (merr) MTestPrintError( merr );
 804         recvtype->count    = 1;
 805         recvtype->InitBuf  = MTestTypeIndexedInitRecv;
 806         recvtype->FreeBuf  = MTestTypeIndexedFree;
 807         recvtype->CheckBuf = MTestTypeIndexedCheckbuf;
 808
 809         sendtype->datatype = MPI_INT;
 810         sendtype->isBasic  = 1;
 811         sendtype->count    = count * 4;
 812         sendtype->InitBuf  = MTestTypeContigInit;
 813         sendtype->FreeBuf  = MTestTypeContigFree;
 814         sendtype->CheckBuf = 0;
 815         break;
 816
 817         /* Less commonly used but still simple types */
 818     case 8:
 819         sendtype->datatype = MPI_SHORT;
 820         sendtype->isBasic  = 1;
 821         recvtype->datatype = MPI_SHORT;
 822         recvtype->isBasic  = 1;
 823         break;
 824     case 9:
 825         sendtype->datatype = MPI_LONG;
 826         sendtype->isBasic  = 1;
 827         recvtype->datatype = MPI_LONG;
 828         recvtype->isBasic  = 1;
 829         break;
 830     case 10:
 831         sendtype->datatype = MPI_CHAR;
 832         sendtype->isBasic  = 1;
 833         recvtype->datatype = MPI_CHAR;
 834         recvtype->isBasic  = 1;
 835         break;
 836     case 11:
 837         sendtype->datatype = MPI_UINT64_T;
 838         sendtype->isBasic  = 1;
 839         recvtype->datatype = MPI_UINT64_T;
 840         recvtype->isBasic  = 1;
 841         break;
 842     case 12:
 843         sendtype->datatype = MPI_FLOAT;
 844         sendtype->isBasic  = 1;
 845         recvtype->datatype = MPI_FLOAT;
 846         recvtype->isBasic  = 1;
 847         break;
 848
 849 #ifndef USE_STRICT_MPI
 850         /* MPI_BYTE may only be used with MPI_BYTE in strict MPI */
 851     case 13:
 852         sendtype->datatype = MPI_INT;
 853         sendtype->isBasic  = 1;
 854         recvtype->datatype = MPI_BYTE;
 855         recvtype->isBasic  = 1;
 856         recvtype->count    *= sizeof(int);
 857         break;
 858 #endif
 859     default:
 860         datatype_index = -1;
 861     }
 862
 863     if (!sendtype->InitBuf) {
 864         sendtype->InitBuf  = MTestTypeContigInit;
 865         recvtype->InitBuf  = MTestTypeContigInitRecv;
 866         sendtype->FreeBuf  = MTestTypeContigFree;
 867         recvtype->FreeBuf  = MTestTypeContigFree;
 868         sendtype->CheckBuf = MTestTypeContigCheckbuf;
 869         recvtype->CheckBuf = MTestTypeContigCheckbuf;
 870     }
 871     datatype_index++;
 872
 873     if (dbgflag && datatype_index > 0) {
 874         int typesize;
 875         fprintf( stderr, "%d: sendtype is %s\n", wrank, MTestGetDatatypeName( sendtype ) );
 876         merr = MPI_Type_size( sendtype->datatype, &typesize );
 877         if (merr) MTestPrintError( merr );
 878         fprintf( stderr, "%d: sendtype size = %d\n", wrank, typesize );
 879         fprintf( stderr, "%d: recvtype is %s\n", wrank, MTestGetDatatypeName( recvtype ) );
 880         merr = MPI_Type_size( recvtype->datatype, &typesize );
 881         if (merr) MTestPrintError( merr );
 882         fprintf( stderr, "%d: recvtype size = %d\n", wrank, typesize );
 883         fflush( stderr );
 884
 885     }
 886     else if (verbose && datatype_index > 0) {
 887         printf( "Get new datatypes: send = %s, recv = %s\n",
 888                 MTestGetDatatypeName( sendtype ),
 889                 MTestGetDatatypeName( recvtype ) );
 890         fflush( stdout );
 891     }
 892
 893     return datatype_index;
 894 }
 895
 896 /* Reset the datatype index (start from the initial data type.
 897    Note: This routine is rarely needed; MTestGetDatatypes automatically
 898    starts over after the last available datatype is used.
 899 */
 900 void MTestResetDatatypes( void )
 901 {
 902     datatype_index = 0;
 903 }
 904 /* Return the index of the current datatype.  This is rarely needed and
 905    is provided mostly to enable debugging of the MTest package itself */
 906 int MTestGetDatatypeIndex( void )
 907 {
 908     return datatype_index;
 909 }
 910
 911 /* Free the storage associated with a datatype */
 912 void MTestFreeDatatype( MTestDatatype *mtype )
 913 {
 914     int merr;
 915     /* Invoke a datatype-specific free function to handle
 916        both the datatype and the send/receive buffers */
 917     if (mtype->FreeBuf) {
 918         (mtype->FreeBuf)( mtype );
 919     }
 920     /* Free the datatype itself if it was created */
 921     if (!mtype->isBasic) {
 922         merr = MPI_Type_free( &mtype->datatype );
 923         if (merr) MTestPrintError( merr );
 924     }
 925 }
 926
 927 /* Check that a message was received correctly.  Returns the number of
 928    errors detected.  Status may be NULL or MPI_STATUS_IGNORE */
 929 int MTestCheckRecv( MPI_Status *status, MTestDatatype *recvtype )
 930 {
 931     int count;
 932     int errs = 0, merr;
 933
 934     if (status && status != MPI_STATUS_IGNORE) {
 935         merr = MPI_Get_count( status, recvtype->datatype, &count );
 936         if (merr) MTestPrintError( merr );
 937
 938         /* Check count against expected count */
 939         if (count != recvtype->count) {
 940             errs ++;
 941         }
 942     }
 943
 944     /* Check received data */
 945     if (!errs && recvtype->CheckBuf( recvtype )) {
 946         errs++;
 947     }
 948     return errs;
 949 }
 950
 951 /* This next routine uses a circular buffer of static name arrays just to
 952    simplify the use of the routine */
 953 const char *MTestGetDatatypeName( MTestDatatype *dtype )
 954 {
 955     static char name[4][MPI_MAX_OBJECT_NAME];
 956     static int sp=0;
 957     int rlen, merr;
 958
 959     if (sp >= 4) sp = 0;
 960     merr = MPI_Type_get_name( dtype->datatype, name[sp], &rlen );
 961     if (merr) MTestPrintError( merr );
 962     return (const char *)name[sp++];
 963 }
 964 /* ----------------------------------------------------------------------- */
 965
 966 /*
 967  * Create communicators.  Use separate routines for inter and intra
 968  * communicators (there is a routine to give both)
 969  * Note that the routines may return MPI_COMM_NULL, so code should test for
 970  * that return value as well.
 971  *
 972  */
 973 static int interCommIdx = 0;
 974 static int intraCommIdx = 0;
 975 static const char *intraCommName = 0;
 976 static const char *interCommName = 0;
 977
 978 /*
 979  * Get an intracommunicator with at least min_size members.  If "allowSmaller"
 980  * is true, allow the communicator to be smaller than MPI_COMM_WORLD and
 981  * for this routine to return MPI_COMM_NULL for some values.  Returns 0 if
 982  * no more communicators are available.
 983  */
 984 int MTestGetIntracommGeneral( MPI_Comm *comm, int min_size, int allowSmaller )
 985 {
 986     int size, rank, merr;
 987     int done2, done=0;
 988     int isBasic = 0;
 989
 990     /* The while loop allows us to skip communicators that are too small.
 991        MPI_COMM_NULL is always considered large enough */
 992     while (!done) {
 993         isBasic = 0;
 994         intraCommName = "";
 995         switch (intraCommIdx) {
 996         case 0:
 997             *comm = MPI_COMM_WORLD;
 998             isBasic = 1;
 999             intraCommName = "MPI_COMM_WORLD";
1000             break;
1001         case 1:
1002             /* dup of world */
1003             merr = MPI_Comm_dup(MPI_COMM_WORLD, comm );
1004             if (merr) MTestPrintError( merr );
1005             intraCommName = "Dup of MPI_COMM_WORLD";
1006             break;
1007         case 2:
1008             /* reverse ranks */
1009             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1010             if (merr) MTestPrintError( merr );
1011             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1012             if (merr) MTestPrintError( merr );
1013             merr = MPI_Comm_split( MPI_COMM_WORLD, 0, size-rank, comm );
1014             if (merr) MTestPrintError( merr );
1015             intraCommName = "Rank reverse of MPI_COMM_WORLD";
1016             break;
1017         case 3:
1018             /* subset of world, with reversed ranks */
1019             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1020             if (merr) MTestPrintError( merr );
1021             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1022             if (merr) MTestPrintError( merr );
1023             merr = MPI_Comm_split( MPI_COMM_WORLD, ((rank < size/2) ? 1 : MPI_UNDEFINED),
1024                                    size-rank, comm );
1025             if (merr) MTestPrintError( merr );
1026             intraCommName = "Rank reverse of half of MPI_COMM_WORLD";
1027             break;
1028         case 4:
1029             *comm = MPI_COMM_SELF;
1030             isBasic = 1;
1031             intraCommName = "MPI_COMM_SELF";
1032             break;
1033
1034             /* These next cases are communicators that include some
1035                but not all of the processes */
1036         case 5:
1037         case 6:
1038         case 7:
1039         case 8:
1040         {
1041             int newsize;
1042             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1043             if (merr) MTestPrintError( merr );
1044             newsize = size - (intraCommIdx - 4);
1045
1046             if (allowSmaller && newsize >= min_size) {
1047                 merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1048                 if (merr) MTestPrintError( merr );
1049                 merr = MPI_Comm_split( MPI_COMM_WORLD, rank < newsize, rank,
1050                                        comm );
1051                 if (merr) MTestPrintError( merr );
1052                 if (rank >= newsize) {
1053                     merr = MPI_Comm_free( comm );
1054                     if (merr) MTestPrintError( merr );
1055                     *comm = MPI_COMM_NULL;
1056                 }
1057                 else {
1058                     intraCommName = "Split of WORLD";
1059                 }
1060             }
1061             else {
1062                 /* Act like default */
1063                 *comm = MPI_COMM_NULL;
1064                 intraCommIdx = -1;
1065             }
1066         }
1067         break;
1068
1069             /* Other ideas: dup of self, cart comm, graph comm */
1070         default:
1071             *comm = MPI_COMM_NULL;
1072             intraCommIdx = -1;
1073             break;
1074         }
1075
1076         if (*comm != MPI_COMM_NULL) {
1077             merr = MPI_Comm_size( *comm, &size );
1078             if (merr) MTestPrintError( merr );
1079             if (size >= min_size)
1080                 done = 1;
1081         }
1082         else {
1083             intraCommName = "MPI_COMM_NULL";
1084             isBasic = 1;
1085             done = 1;
1086         }
1087 done2=done;
1088         /* we are only done if all processes are done */
1089         MPI_Allreduce(&done2, &done, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD);
1090
1091         /* Advance the comm index whether we are done or not, otherwise we could
1092          * spin forever trying to allocate a too-small communicator over and
1093          * over again. */
1094         intraCommIdx++;
1095
1096         if (!done && !isBasic && *comm != MPI_COMM_NULL) {
1097             /* avoid leaking communicators */
1098             merr = MPI_Comm_free(comm);
1099             if (merr) MTestPrintError(merr);
1100         }
1101     }
1102
1103     return intraCommIdx;
1104 }
1105
1106 /*
1107  * Get an intracommunicator with at least min_size members.
1108  */
1109 int MTestGetIntracomm( MPI_Comm *comm, int min_size )
1110 {
1111     return MTestGetIntracommGeneral( comm, min_size, 0 );
1112 }
1113
1114 /* Return the name of an intra communicator */
1115 const char *MTestGetIntracommName( void )
1116 {
1117     return intraCommName;
1118 }
1119
1120 /*
1121  * Return an intercomm; set isLeftGroup to 1 if the calling process is
1122  * a member of the "left" group.
1123  */
1124 int MTestGetIntercomm( MPI_Comm *comm, int *isLeftGroup, int min_size )
1125 {
1126     int size, rank, remsize, merr;
1127     int done=0;
1128     MPI_Comm mcomm  = MPI_COMM_NULL;
1129     MPI_Comm mcomm2 = MPI_COMM_NULL;
1130     int rleader;
1131
1132     /* The while loop allows us to skip communicators that are too small.
1133        MPI_COMM_NULL is always considered large enough.  The size is
1134        the sum of the sizes of the local and remote groups */
1135     while (!done) {
1136         *comm = MPI_COMM_NULL;
1137         *isLeftGroup = 0;
1138         interCommName = "MPI_COMM_NULL";
1139
1140         switch (interCommIdx) {
1141         case 0:
1142             /* Split comm world in half */
1143             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1144             if (merr) MTestPrintError( merr );
1145             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1146             if (merr) MTestPrintError( merr );
1147             if (size > 1) {
1148                 merr = MPI_Comm_split( MPI_COMM_WORLD, (rank < size/2), rank,
1149                                        &mcomm );
1150                 if (merr) MTestPrintError( merr );
1151                 if (rank == 0) {
1152                     rleader = size/2;
1153                 }
1154                 else if (rank == size/2) {
1155                     rleader = 0;
1156                 }
1157                 else {
1158                     /* Remote leader is signficant only for the processes
1159                        designated local leaders */
1160                     rleader = -1;
1161                 }
1162                 *isLeftGroup = rank < size/2;
1163                 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader,
1164                                              12345, comm );
1165                 if (merr) MTestPrintError( merr );
1166                 interCommName = "Intercomm by splitting MPI_COMM_WORLD";
1167             }
1168             else
1169                 *comm = MPI_COMM_NULL;
1170             break;
1171         case 1:
1172             /* Split comm world in to 1 and the rest */
1173             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1174             if (merr) MTestPrintError( merr );
1175             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1176             if (merr) MTestPrintError( merr );
1177             if (size > 1) {
1178                 merr = MPI_Comm_split( MPI_COMM_WORLD, rank == 0, rank,
1179                                        &mcomm );
1180                 if (merr) MTestPrintError( merr );
1181                 if (rank == 0) {
1182                     rleader = 1;
1183                 }
1184                 else if (rank == 1) {
1185                     rleader = 0;
1186                 }
1187                 else {
1188                     /* Remote leader is signficant only for the processes
1189                        designated local leaders */
1190                     rleader = -1;
1191                 }
1192                 *isLeftGroup = rank == 0;
1193                 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD,
1194                                              rleader, 12346, comm );
1195                 if (merr) MTestPrintError( merr );
1196                 interCommName = "Intercomm by splitting MPI_COMM_WORLD into 1, rest";
1197             }
1198             else
1199                 *comm = MPI_COMM_NULL;
1200             break;
1201
1202         case 2:
1203             /* Split comm world in to 2 and the rest */
1204             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1205             if (merr) MTestPrintError( merr );
1206             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1207             if (merr) MTestPrintError( merr );
1208             if (size > 3) {
1209                 merr = MPI_Comm_split( MPI_COMM_WORLD, rank < 2, rank,
1210                                        &mcomm );
1211                 if (merr) MTestPrintError( merr );
1212                 if (rank == 0) {
1213                     rleader = 2;
1214                 }
1215                 else if (rank == 2) {
1216                     rleader = 0;
1217                 }
1218                 else {
1219                     /* Remote leader is signficant only for the processes
1220                        designated local leaders */
1221                     rleader = -1;
1222                 }
1223                 *isLeftGroup = rank < 2;
1224                 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD,
1225                                              rleader, 12347, comm );
1226                 if (merr) MTestPrintError( merr );
1227                 interCommName = "Intercomm by splitting MPI_COMM_WORLD into 2, rest";
1228             }
1229             else
1230                 *comm = MPI_COMM_NULL;
1231             break;
1232
1233         case 3:
1234             /* Split comm world in half, then dup */
1235             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1236             if (merr) MTestPrintError( merr );
1237             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1238             if (merr) MTestPrintError( merr );
1239             if (size > 1) {
1240                 merr = MPI_Comm_split( MPI_COMM_WORLD, (rank < size/2), rank,
1241                                        &mcomm );
1242                 if (merr) MTestPrintError( merr );
1243                 if (rank == 0) {
1244                     rleader = size/2;
1245                 }
1246                 else if (rank == size/2) {
1247                     rleader = 0;
1248                 }
1249                 else {
1250                     /* Remote leader is signficant only for the processes
1251                        designated local leaders */
1252                     rleader = -1;
1253                 }
1254                 *isLeftGroup = rank < size/2;
1255                 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader,
1256                                              12345, comm );
1257                 if (merr) MTestPrintError( merr );
1258                 /* avoid leaking after assignment below */
1259                 merr = MPI_Comm_free( &mcomm );
1260                 if (merr) MTestPrintError( merr );
1261
1262                 /* now dup, some bugs only occur for dup's of intercomms */
1263                 mcomm = *comm;
1264                 merr = MPI_Comm_dup(mcomm, comm);
1265                 if (merr) MTestPrintError( merr );
1266                 interCommName = "Intercomm by splitting MPI_COMM_WORLD then dup'ing";
1267             }
1268             else
1269                 *comm = MPI_COMM_NULL;
1270             break;
1271
1272         case 4:
1273             /* Split comm world in half, form intercomm, then split that intercomm */
1274             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1275             if (merr) MTestPrintError( merr );
1276             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1277             if (merr) MTestPrintError( merr );
1278             if (size > 1) {
1279                 merr = MPI_Comm_split( MPI_COMM_WORLD, (rank < size/2), rank,
1280                                        &mcomm );
1281                 if (merr) MTestPrintError( merr );
1282                 if (rank == 0) {
1283                     rleader = size/2;
1284                 }
1285                 else if (rank == size/2) {
1286                     rleader = 0;
1287                 }
1288                 else {
1289                     /* Remote leader is signficant only for the processes
1290                        designated local leaders */
1291                     rleader = -1;
1292                 }
1293                 *isLeftGroup = rank < size/2;
1294                 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader,
1295                                              12345, comm );
1296                 if (merr) MTestPrintError( merr );
1297                 /* avoid leaking after assignment below */
1298                 merr = MPI_Comm_free( &mcomm );
1299                 if (merr) MTestPrintError( merr );
1300
1301                 /* now split, some bugs only occur for splits of intercomms */
1302                 mcomm = *comm;
1303                 rank = MPI_Comm_rank(mcomm, &rank);
1304                 if (merr) MTestPrintError( merr );
1305                 /* this split is effectively a dup but tests the split code paths */
1306                 merr = MPI_Comm_split(mcomm, 0, rank, comm);
1307                 if (merr) MTestPrintError( merr );
1308                 interCommName = "Intercomm by splitting MPI_COMM_WORLD then then splitting again";
1309             }
1310             else
1311                 *comm = MPI_COMM_NULL;
1312             break;
1313
1314         case 5:
1315             /* split comm world in half discarding rank 0 on the "left"
1316              * communicator, then form them into an intercommunicator */
1317             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1318             if (merr) MTestPrintError( merr );
1319             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1320             if (merr) MTestPrintError( merr );
1321             if (size >= 4) {
1322                 int color = (rank < size/2 ? 0 : 1);
1323                 if (rank == 0)
1324                     color = MPI_UNDEFINED;
1325
1326                 merr = MPI_Comm_split( MPI_COMM_WORLD, color, rank, &mcomm );
1327                 if (merr) MTestPrintError( merr );
1328
1329                 if (rank == 1) {
1330                     rleader = size/2;
1331                 }
1332                 else if (rank == (size/2)) {
1333                     rleader = 1;
1334                 }
1335                 else {
1336                     /* Remote leader is signficant only for the processes
1337                        designated local leaders */
1338                     rleader = -1;
1339                 }
1340                 *isLeftGroup = rank < size/2;
1341                 if (rank != 0) { /* 0's mcomm is MPI_COMM_NULL */
1342                     merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader, 12345, comm );
1343                     if (merr) MTestPrintError( merr );
1344                 }
1345                 interCommName = "Intercomm by splitting MPI_COMM_WORLD (discarding rank 0 in the left group) then MPI_Intercomm_create'ing";
1346             }
1347             else {
1348                 *comm = MPI_COMM_NULL;
1349             }
1350             break;
1351
1352         case 6:
1353             /* Split comm world in half then form them into an
1354              * intercommunicator.  Then discard rank 0 from each group of the
1355              * intercomm via MPI_Comm_create. */
1356             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1357             if (merr) MTestPrintError( merr );
1358             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1359             if (merr) MTestPrintError( merr );
1360             if (size >= 4) {
1361                 MPI_Group oldgroup, newgroup;
1362                 int ranks[1];
1363                 int color = (rank < size/2 ? 0 : 1);
1364
1365                 merr = MPI_Comm_split( MPI_COMM_WORLD, color, rank, &mcomm );
1366                 if (merr) MTestPrintError( merr );
1367
1368                 if (rank == 0) {
1369                     rleader = size/2;
1370                 }
1371                 else if (rank == (size/2)) {
1372                     rleader = 0;
1373                 }
1374                 else {
1375                     /* Remote leader is signficant only for the processes
1376                        designated local leaders */
1377                     rleader = -1;
1378                 }
1379                 *isLeftGroup = rank < size/2;
1380                 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader, 12345, &mcomm2 );
1381                 if (merr) MTestPrintError( merr );
1382
1383                 /* We have an intercomm between the two halves of comm world. Now create
1384                  * a new intercomm that removes rank 0 on each side. */
1385                 merr = MPI_Comm_group(mcomm2, &oldgroup);
1386                 if (merr) MTestPrintError( merr );
1387                 ranks[0] = 0;
1388                 merr = MPI_Group_excl(oldgroup, 1, ranks, &newgroup);
1389                 if (merr) MTestPrintError( merr );
1390                 merr = MPI_Comm_create(mcomm2, newgroup, comm);
1391                 if (merr) MTestPrintError( merr );
1392
1393                 merr = MPI_Group_free(&oldgroup);
1394                 if (merr) MTestPrintError( merr );
1395                 merr = MPI_Group_free(&newgroup);
1396                 if (merr) MTestPrintError( merr );
1397
1398                 interCommName = "Intercomm by splitting MPI_COMM_WORLD then discarding 0 ranks with MPI_Comm_create";
1399             }
1400             else {
1401                 *comm = MPI_COMM_NULL;
1402             }
1403             break;
1404
1405         default:
1406             *comm = MPI_COMM_NULL;
1407             interCommIdx = -1;
1408             break;
1409         }
1410
1411         if (*comm != MPI_COMM_NULL) {
1412             merr = MPI_Comm_size( *comm, &size );
1413             if (merr) MTestPrintError( merr );
1414             merr = MPI_Comm_remote_size( *comm, &remsize );
1415             if (merr) MTestPrintError( merr );
1416             if (size + remsize >= min_size) done = 1;
1417         }
1418         else {
1419             interCommName = "MPI_COMM_NULL";
1420             done = 1;
1421         }
1422
1423         /* we are only done if all processes are done */
1424         MPI_Allreduce(MPI_IN_PLACE, &done, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD);
1425
1426         /* Advance the comm index whether we are done or not, otherwise we could
1427          * spin forever trying to allocate a too-small communicator over and
1428          * over again. */
1429         interCommIdx++;
1430
1431         if (!done && *comm != MPI_COMM_NULL) {
1432             /* avoid leaking communicators */
1433             merr = MPI_Comm_free(comm);
1434             if (merr) MTestPrintError(merr);
1435         }
1436
1437         /* cleanup for common temp objects */
1438         if (mcomm != MPI_COMM_NULL) {
1439             merr = MPI_Comm_free(&mcomm);
1440             if (merr) MTestPrintError( merr );
1441         }
1442         if (mcomm2 != MPI_COMM_NULL) {
1443             merr = MPI_Comm_free(&mcomm2);
1444             if (merr) MTestPrintError( merr );
1445         }
1446     }
1447
1448     return interCommIdx;
1449 }
1450 /* Return the name of an intercommunicator */
1451 const char *MTestGetIntercommName( void )
1452 {
1453     return interCommName;
1454 }
1455
1456 /* Get a communicator of a given minimum size.  Both intra and inter
1457    communicators are provided */
1458 int MTestGetComm( MPI_Comm *comm, int min_size )
1459 {
1460     int idx=0;
1461     static int getinter = 0;
1462
1463     if (!getinter) {
1464         idx = MTestGetIntracomm( comm, min_size );
1465         if (idx == 0) {
1466             getinter = 1;
1467         }
1468     }
1469     if (getinter) {
1470         int isLeft;
1471         idx = MTestGetIntercomm( comm, &isLeft, min_size );
1472         if (idx == 0) {
1473             getinter = 0;
1474         }
1475     }
1476
1477     return idx;
1478 }
1479
1480 /* Free a communicator.  It may be called with a predefined communicator
1481  or MPI_COMM_NULL */
1482 void MTestFreeComm( MPI_Comm *comm )
1483 {
1484     int merr;
1485     if (*comm != MPI_COMM_WORLD &&
1486         *comm != MPI_COMM_SELF &&
1487         *comm != MPI_COMM_NULL) {
1488         merr = MPI_Comm_free( comm );
1489         if (merr) MTestPrintError( merr );
1490     }
1491 }
1492
1493 /* ------------------------------------------------------------------------ */
1494 void MTestPrintError( int errcode )
1495 {
1496     int errclass, slen;
1497     char string[MPI_MAX_ERROR_STRING];
1498
1499     MPI_Error_class( errcode, &errclass );
1500     MPI_Error_string( errcode, string, &slen );
1501     printf( "Error class %d (%s)\n", errclass, string );
1502     fflush( stdout );
1503 }
1504 void MTestPrintErrorMsg( const char msg[], int errcode )
1505 {
1506     int errclass, slen;
1507     char string[MPI_MAX_ERROR_STRING];
1508
1509     MPI_Error_class( errcode, &errclass );
1510     MPI_Error_string( errcode, string, &slen );
1511     printf( "%s: Error class %d (%s)\n", msg, errclass, string );
1512     fflush( stdout );
1513 }
1514 /* ------------------------------------------------------------------------ */
1515 /*
1516  If verbose output is selected and the level is at least that of the
1517  value of the verbose flag, then perform printf( format, ... );
1518  */
1519 void MTestPrintfMsg( int level, const char format[], ... )
1520 {
1521     va_list list;
1522
1523     if (verbose && level >= verbose) {
1524         va_start(list,format);
1525         vprintf( format, list );
1526         va_end(list);
1527         fflush(stdout);
1528     }
1529 }
1530 /* Fatal error.  Report and exit */
1531 void MTestError( const char *msg )
1532 {
1533     fprintf( stderr, "%s\n", msg );
1534     fflush( stderr );
1535     MPI_Abort( MPI_COMM_WORLD, 1 );
1536     exit(1);
1537 }
1538 /* ------------------------------------------------------------------------ */
1539 static void MTestResourceSummary( FILE *fp )
1540 {
1541 #ifdef HAVE_GETRUSAGE
1542     struct rusage ru;
1543     static int pfThreshold = -2;
1544     int doOutput = 1;
1545     if (getrusage( RUSAGE_SELF, &ru ) == 0) {
1546         /* There is an option to generate output only when a resource
1547            exceeds a threshold.  To date, only page faults supported. */
1548         if (pfThreshold == -2) {
1549             char *p = getenv("MPITEST_RUSAGE_PF");
1550             pfThreshold = -1;
1551             if (p) {
1552                 pfThreshold = strtol( p, 0, 0 );
1553             }
1554         }
1555         if (pfThreshold > 0) {
1556             doOutput = ru.ru_minflt > pfThreshold;
1557         }
1558         if (doOutput) {
1559             /* Cast values to long in case some system has defined them
1560                as another integer type */
1561             fprintf( fp, "RUSAGE: max resident set = %ldKB\n",
1562                      (long)ru.ru_maxrss );
1563             fprintf( fp, "RUSAGE: page faults = %ld : %ld\n",
1564                      (long)ru.ru_minflt, (long)ru.ru_majflt );
1565             /* Not every Unix provides useful information for the xxrss fields */
1566             fprintf( fp, "RUSAGE: memory in text/data/stack = %ld : %ld : %ld\n",
1567                      (long)ru.ru_ixrss, (long)ru.ru_idrss, (long)ru.ru_isrss );
1568             fprintf( fp, "RUSAGE: I/O in and out = %ld : %ld\n",
1569                      (long)ru.ru_inblock, (long)ru.ru_oublock );
1570             fprintf( fp, "RUSAGE: context switch = %ld : %ld\n",
1571                      (long)ru.ru_nvcsw, (long)ru.ru_nivcsw );
1572         }
1573     }
1574     else {
1575         fprintf( fp, "RUSAGE: return error %d\n", errno );
1576     }
1577 #endif
1578 }
1579 /* ------------------------------------------------------------------------ */
1580 #ifdef HAVE_MPI_WIN_CREATE
1581 /*
1582  * Create MPI Windows
1583  */
1584 static int win_index = 0;
1585 static const char *winName;
1586 /* Use an attribute to remember the type of memory allocation (static,
1587    malloc, or MPI_Alloc_mem) */
1588 static int mem_keyval = MPI_KEYVAL_INVALID;
1589 int MTestGetWin( MPI_Win *win, int mustBePassive )
1590 {
1591     static char actbuf[1024];
1592     static char *pasbuf;
1593     char        *buf;
1594     int         n, rank, merr;
1595     MPI_Info    info;
1596
1597     if (mem_keyval == MPI_KEYVAL_INVALID) {
1598         /* Create the keyval */
1599         merr = MPI_Win_create_keyval( MPI_WIN_NULL_COPY_FN,
1600                                       MPI_WIN_NULL_DELETE_FN,
1601                                       &mem_keyval, 0 );
1602         if (merr) MTestPrintError( merr );
1603
1604     }
1605
1606     switch (win_index) {
1607     case 0:
1608         /* Active target window */
1609         merr = MPI_Win_create( actbuf, 1024, 1, MPI_INFO_NULL, MPI_COMM_WORLD,
1610                                win );
1611         if (merr) MTestPrintError( merr );
1612         winName = "active-window";
1613         merr = MPI_Win_set_attr( *win, mem_keyval, (void *)0 );
1614         if (merr) MTestPrintError( merr );
1615         break;
1616     case 1:
1617         /* Passive target window */
1618         merr = MPI_Alloc_mem( 1024, MPI_INFO_NULL, &pasbuf );
1619         if (merr) MTestPrintError( merr );
1620         merr = MPI_Win_create( pasbuf, 1024, 1, MPI_INFO_NULL, MPI_COMM_WORLD,
1621                                win );
1622         if (merr) MTestPrintError( merr );
1623         winName = "passive-window";
1624         merr = MPI_Win_set_attr( *win, mem_keyval, (void *)2 );
1625         if (merr) MTestPrintError( merr );
1626         break;
1627     case 2:
1628         /* Active target; all windows different sizes */
1629         merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1630         if (merr) MTestPrintError( merr );
1631         n = rank * 64;
1632         if (n)
1633             buf = (char *)malloc( n );
1634         else
1635             buf = 0;
1636         merr = MPI_Win_create( buf, n, 1, MPI_INFO_NULL, MPI_COMM_WORLD,
1637                                win );
1638         if (merr) MTestPrintError( merr );
1639         winName = "active-all-different-win";
1640         merr = MPI_Win_set_attr( *win, mem_keyval, (void *)1 );
1641         if (merr) MTestPrintError( merr );
1642         break;
1643     case 3:
1644         /* Active target, no locks set */
1645         merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1646         if (merr) MTestPrintError( merr );
1647         n = rank * 64;
1648         if (n)
1649             buf = (char *)malloc( n );
1650         else
1651             buf = 0;
1652         merr = MPI_Info_create( &info );
1653         if (merr) MTestPrintError( merr );
1654         merr = MPI_Info_set( info, (char*)"nolocks", (char*)"true" );
1655         if (merr) MTestPrintError( merr );
1656         merr = MPI_Win_create( buf, n, 1, info, MPI_COMM_WORLD, win );
1657         if (merr) MTestPrintError( merr );
1658         merr = MPI_Info_free( &info );
1659         if (merr) MTestPrintError( merr );
1660         winName = "active-nolocks-all-different-win";
1661         merr = MPI_Win_set_attr( *win, mem_keyval, (void *)1 );
1662         if (merr) MTestPrintError( merr );
1663         break;
1664     default:
1665         win_index = -1;
1666     }
1667     win_index++;
1668     return win_index;
1669 }
1670 /* Return a pointer to the name associated with a window object */
1671 const char *MTestGetWinName( void )
1672 {
1673     return winName;
1674 }
1675 /* Free the storage associated with a window object */
1676 void MTestFreeWin( MPI_Win *win )
1677 {
1678     void *addr;
1679     int  flag, merr;
1680
1681     merr = MPI_Win_get_attr( *win, MPI_WIN_BASE, &addr, &flag );
1682     if (merr) MTestPrintError( merr );
1683     if (!flag) {
1684         MTestError( "Could not get WIN_BASE from window" );
1685     }
1686     if (addr) {
1687         void *val;
1688         merr = MPI_Win_get_attr( *win, mem_keyval, &val, &flag );
1689         if (merr) MTestPrintError( merr );
1690         if (flag) {
1691             if (val == (void *)1) {
1692                 free( addr );
1693             }
1694             else if (val == (void *)2) {
1695                 merr = MPI_Free_mem( addr );
1696                 if (merr) MTestPrintError( merr );
1697             }
1698             /* if val == (void *)0, then static data that must not be freed */
1699         }
1700     }
1701     merr = MPI_Win_free(win);
1702     if (merr) MTestPrintError( merr );
1703 }
1704 static void MTestRMACleanup( void )
1705 {
1706     if (mem_keyval != MPI_KEYVAL_INVALID) {
1707         MPI_Win_free_keyval( &mem_keyval );
1708     }
1709 }
1710 #else
1711 static void MTestRMACleanup( void ) {}
1712 #endif