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     }
 557     return 0;
 558 }
 559
 560 static int MTestTypeIndexedCheckbuf( MTestDatatype *mtype )
 561 {
 562     unsigned char *p;
 563     unsigned char expected;
 564     int  i, err = 0, merr;
 565     MPI_Aint totsize;
 566
 567     p = (unsigned char *)mtype->buf;
 568     if (p) {
 569         int j, k, offset;
 570         merr = MPI_Type_extent( mtype->datatype, &totsize );
 571         if (merr) MTestPrintError( merr );
 572
 573         k = 0;
 574         for (i=0; i<mtype->nelm; i++) {
 575             int b;
 576             /* Compute the offset: */
 577             offset = mtype->displs[i] * mtype->basesize;
 578             for (b=0; b<mtype->index[i]; b++) {
 579                 for (j=0; j<mtype->basesize; j++) {
 580                     expected = (0xff ^ (k & 0xff));
 581                     if (p[offset+j] != expected) {
 582                         err++;
 583                         if (mtype->printErrors && err < 10) {
 584                             printf( "Data expected = %x but got p[%d,%d] = %x\n",
 585                                     expected, i,j, p[offset+j] );
 586                             fflush( stdout );
 587                         }
 588                     }
 589                     k++;
 590                 }
 591                 offset += mtype->basesize;
 592             }
 593         }
 594     }
 595     return err;
 596 }
 597
 598
 599 /* ------------------------------------------------------------------------ */
 600 /* Routines to select a datatype and associated buffer create/fill/check    */
 601 /* routines                                                                 */
 602 /* ------------------------------------------------------------------------ */
 603
 604 /*
 605    Create a range of datatypes with a given count elements.
 606    This uses a selection of types, rather than an exhaustive collection.
 607    It allocates both send and receive types so that they can have the same
 608    type signature (collection of basic types) but different type maps (layouts
 609    in memory)
 610  */
 611 int MTestGetDatatypes( MTestDatatype *sendtype, MTestDatatype *recvtype,
 612                        int count )
 613 {
 614     int merr;
 615     int i;
 616
 617     sendtype->InitBuf     = 0;
 618     sendtype->FreeBuf     = 0;
 619     sendtype->CheckBuf    = 0;
 620     sendtype->datatype    = 0;
 621     sendtype->isBasic     = 0;
 622     sendtype->printErrors = 0;
 623     recvtype->InitBuf     = 0;
 624     recvtype->FreeBuf     = 0;
 625
 626     recvtype->CheckBuf    = 0;
 627     recvtype->datatype    = 0;
 628     recvtype->isBasic     = 0;
 629     recvtype->printErrors = 0;
 630
 631     sendtype->buf         = 0;
 632     recvtype->buf         = 0;
 633
 634     /* Set the defaults for the message lengths */
 635     sendtype->count       = count;
 636     recvtype->count       = count;
 637     /* Use datatype_index to choose a datatype to use.  If at the end of the
 638        list, return 0 */
 639     switch (datatype_index) {
 640     case 0:
 641         sendtype->datatype = MPI_INT;
 642         sendtype->isBasic  = 1;
 643         recvtype->datatype = MPI_INT;
 644         recvtype->isBasic  = 1;
 645         break;
 646     case 1:
 647         sendtype->datatype = MPI_DOUBLE;
 648         sendtype->isBasic  = 1;
 649         recvtype->datatype = MPI_DOUBLE;
 650         recvtype->isBasic  = 1;
 651         break;
 652     case 2:
 653         sendtype->datatype = MPI_FLOAT_INT;
 654         sendtype->isBasic  = 1;
 655         recvtype->datatype = MPI_FLOAT_INT;
 656         recvtype->isBasic  = 1;
 657         break;
 658     case 3:
 659         merr = MPI_Type_dup( MPI_INT, &sendtype->datatype );
 660         if (merr) MTestPrintError( merr );
 661         merr = MPI_Type_set_name( sendtype->datatype,
 662                                   (char*)"dup of MPI_INT" );
 663         if (merr) MTestPrintError( merr );
 664         merr = MPI_Type_dup( MPI_INT, &recvtype->datatype );
 665         if (merr) MTestPrintError( merr );
 666         merr = MPI_Type_set_name( recvtype->datatype,
 667                                   (char*)"dup of MPI_INT" );
 668         if (merr) MTestPrintError( merr );
 669         /* dup'ed types are already committed if the original type
 670            was committed (MPI-2, section 8.8) */
 671         break;
 672     case 4:
 673         /* vector send type and contiguous receive type */
 674         /* These sizes are in bytes (see the VectorInit code) */
 675         sendtype->stride   = 3 * sizeof(int);
 676         sendtype->blksize  = sizeof(int);
 677         sendtype->nelm     = recvtype->count;
 678
 679         merr = MPI_Type_vector( recvtype->count, 1, 3, MPI_INT,
 680                                 &sendtype->datatype );
 681         if (merr) MTestPrintError( merr );
 682         merr = MPI_Type_commit( &sendtype->datatype );
 683         if (merr) MTestPrintError( merr );
 684         merr = MPI_Type_set_name( sendtype->datatype,
 685                                   (char*)"int-vector" );
 686         if (merr) MTestPrintError( merr );
 687         sendtype->count    = 1;
 688         recvtype->datatype = MPI_INT;
 689         recvtype->isBasic  = 1;
 690         sendtype->InitBuf  = MTestTypeVectorInit;
 691         recvtype->InitBuf  = MTestTypeContigInitRecv;
 692         sendtype->FreeBuf  = MTestTypeVectorFree;
 693         recvtype->FreeBuf  = MTestTypeContigFree;
 694         sendtype->CheckBuf = 0;
 695         recvtype->CheckBuf = MTestTypeContigCheckbuf;
 696         break;
 697
 698     case 5:
 699         /* Indexed send using many small blocks and contig receive */
 700         sendtype->blksize  = sizeof(int);
 701         sendtype->nelm     = recvtype->count;
 702         sendtype->basesize = sizeof(int);
 703         sendtype->displs   = (int *)malloc( sendtype->nelm * sizeof(int) );
 704         sendtype->index    = (int *)malloc( sendtype->nelm * sizeof(int) );
 705         if (!sendtype->displs || !sendtype->index) {
 706             MTestError( "Out of memory in type init\n" );
 707         }
 708         /* Make the sizes larger (4 ints) to help push the total
 709            size to over 256k in some cases, as the MPICH code as of
 710            10/1/06 used large internal buffers for packing non-contiguous
 711            messages */
 712         for (i=0; i<sendtype->nelm; i++) {
 713             sendtype->index[i]   = 4;
 714             sendtype->displs[i]  = 5*i;
 715         }
 716         merr = MPI_Type_indexed( sendtype->nelm,
 717                                  sendtype->index, sendtype->displs,
 718                                  MPI_INT, &sendtype->datatype );
 719         if (merr) MTestPrintError( merr );
 720         merr = MPI_Type_commit( &sendtype->datatype );
 721         if (merr) MTestPrintError( merr );
 722         merr = MPI_Type_set_name( sendtype->datatype,
 723                                   (char*)"int-indexed(4-int)" );
 724         if (merr) MTestPrintError( merr );
 725         sendtype->count    = 1;
 726         sendtype->InitBuf  = MTestTypeIndexedInit;
 727         sendtype->FreeBuf  = MTestTypeIndexedFree;
 728         sendtype->CheckBuf = 0;
 729
 730         recvtype->datatype = MPI_INT;
 731         recvtype->isBasic  = 1;
 732         recvtype->count    = count * 4;
 733         recvtype->InitBuf  = MTestTypeContigInitRecv;
 734         recvtype->FreeBuf  = MTestTypeContigFree;
 735         recvtype->CheckBuf = MTestTypeContigCheckbuf;
 736         break;
 737
 738     case 6:
 739         /* Indexed send using 2 large blocks and contig receive */
 740         sendtype->blksize  = sizeof(int);
 741         sendtype->nelm     = 2;
 742         sendtype->basesize = sizeof(int);
 743         sendtype->displs   = (int *)malloc( sendtype->nelm * sizeof(int) );
 744         sendtype->index    = (int *)malloc( sendtype->nelm * sizeof(int) );
 745         if (!sendtype->displs || !sendtype->index) {
 746             MTestError( "Out of memory in type init\n" );
 747         }
 748         /* index -> block size */
 749         sendtype->index[0]   = (recvtype->count + 1) / 2;
 750         sendtype->displs[0]  = 0;
 751         sendtype->index[1]   = recvtype->count - sendtype->index[0];
 752         sendtype->displs[1]  = sendtype->index[0] + 1;
 753         /* There is a deliberate gap here */
 754
 755         merr = MPI_Type_indexed( sendtype->nelm,
 756                                  sendtype->index, sendtype->displs,
 757                                  MPI_INT, &sendtype->datatype );
 758         if (merr) MTestPrintError( merr );
 759         merr = MPI_Type_commit( &sendtype->datatype );
 760         if (merr) MTestPrintError( merr );
 761         merr = MPI_Type_set_name( sendtype->datatype,
 762                                   (char*)"int-indexed(2 blocks)" );
 763         if (merr) MTestPrintError( merr );
 764         sendtype->count    = 1;
 765         sendtype->InitBuf  = MTestTypeIndexedInit;
 766         sendtype->FreeBuf  = MTestTypeIndexedFree;
 767         sendtype->CheckBuf = 0;
 768
 769         recvtype->datatype = MPI_INT;
 770         recvtype->isBasic  = 1;
 771         recvtype->count    = sendtype->index[0] + sendtype->index[1];
 772         recvtype->InitBuf  = MTestTypeContigInitRecv;
 773         recvtype->FreeBuf  = MTestTypeContigFree;
 774         recvtype->CheckBuf = MTestTypeContigCheckbuf;
 775         break;
 776
 777     case 7:
 778         /* Indexed receive using many small blocks and contig send */
 779         recvtype->blksize  = sizeof(int);
 780         recvtype->nelm     = recvtype->count;
 781         recvtype->basesize = sizeof(int);
 782         recvtype->displs   = (int *)malloc( recvtype->nelm * sizeof(int) );
 783         recvtype->index    = (int *)malloc( recvtype->nelm * sizeof(int) );
 784         if (!recvtype->displs || !recvtype->index) {
 785             MTestError( "Out of memory in type recv init\n" );
 786         }
 787         /* Make the sizes larger (4 ints) to help push the total
 788            size to over 256k in some cases, as the MPICH code as of
 789            10/1/06 used large internal buffers for packing non-contiguous
 790            messages */
 791         /* Note that there are gaps in the indexed type */
 792         for (i=0; i<recvtype->nelm; i++) {
 793             recvtype->index[i]   = 4;
 794             recvtype->displs[i]  = 5*i;
 795         }
 796         merr = MPI_Type_indexed( recvtype->nelm,
 797                                  recvtype->index, recvtype->displs,
 798                                  MPI_INT, &recvtype->datatype );
 799         if (merr) MTestPrintError( merr );
 800         merr = MPI_Type_commit( &recvtype->datatype );
 801         if (merr) MTestPrintError( merr );
 802         merr = MPI_Type_set_name( recvtype->datatype,
 803                                   (char*)"recv-int-indexed(4-int)" );
 804         if (merr) MTestPrintError( merr );
 805         recvtype->count    = 1;
 806         recvtype->InitBuf  = MTestTypeIndexedInitRecv;
 807         recvtype->FreeBuf  = MTestTypeIndexedFree;
 808         recvtype->CheckBuf = MTestTypeIndexedCheckbuf;
 809
 810         sendtype->datatype = MPI_INT;
 811         sendtype->isBasic  = 1;
 812         sendtype->count    = count * 4;
 813         sendtype->InitBuf  = MTestTypeContigInit;
 814         sendtype->FreeBuf  = MTestTypeContigFree;
 815         sendtype->CheckBuf = 0;
 816         break;
 817
 818         /* Less commonly used but still simple types */
 819     case 8:
 820         sendtype->datatype = MPI_SHORT;
 821         sendtype->isBasic  = 1;
 822         recvtype->datatype = MPI_SHORT;
 823         recvtype->isBasic  = 1;
 824         break;
 825     case 9:
 826         sendtype->datatype = MPI_LONG;
 827         sendtype->isBasic  = 1;
 828         recvtype->datatype = MPI_LONG;
 829         recvtype->isBasic  = 1;
 830         break;
 831     case 10:
 832         sendtype->datatype = MPI_CHAR;
 833         sendtype->isBasic  = 1;
 834         recvtype->datatype = MPI_CHAR;
 835         recvtype->isBasic  = 1;
 836         break;
 837     case 11:
 838         sendtype->datatype = MPI_UINT64_T;
 839         sendtype->isBasic  = 1;
 840         recvtype->datatype = MPI_UINT64_T;
 841         recvtype->isBasic  = 1;
 842         break;
 843     case 12:
 844         sendtype->datatype = MPI_FLOAT;
 845         sendtype->isBasic  = 1;
 846         recvtype->datatype = MPI_FLOAT;
 847         recvtype->isBasic  = 1;
 848         break;
 849
 850 #ifndef USE_STRICT_MPI
 851         /* MPI_BYTE may only be used with MPI_BYTE in strict MPI */
 852     case 13:
 853         sendtype->datatype = MPI_INT;
 854         sendtype->isBasic  = 1;
 855         recvtype->datatype = MPI_BYTE;
 856         recvtype->isBasic  = 1;
 857         recvtype->count    *= sizeof(int);
 858         break;
 859 #endif
 860     default:
 861         datatype_index = -1;
 862     }
 863
 864     if (!sendtype->InitBuf) {
 865         sendtype->InitBuf  = MTestTypeContigInit;
 866         recvtype->InitBuf  = MTestTypeContigInitRecv;
 867         sendtype->FreeBuf  = MTestTypeContigFree;
 868         recvtype->FreeBuf  = MTestTypeContigFree;
 869         sendtype->CheckBuf = MTestTypeContigCheckbuf;
 870         recvtype->CheckBuf = MTestTypeContigCheckbuf;
 871     }
 872     datatype_index++;
 873
 874     if (dbgflag && datatype_index > 0) {
 875         int typesize;
 876         fprintf( stderr, "%d: sendtype is %s\n", wrank, MTestGetDatatypeName( sendtype ) );
 877         merr = MPI_Type_size( sendtype->datatype, &typesize );
 878         if (merr) MTestPrintError( merr );
 879         fprintf( stderr, "%d: sendtype size = %d\n", wrank, typesize );
 880         fprintf( stderr, "%d: recvtype is %s\n", wrank, MTestGetDatatypeName( recvtype ) );
 881         merr = MPI_Type_size( recvtype->datatype, &typesize );
 882         if (merr) MTestPrintError( merr );
 883         fprintf( stderr, "%d: recvtype size = %d\n", wrank, typesize );
 884         fflush( stderr );
 885
 886     }
 887     else if (verbose && datatype_index > 0) {
 888         printf( "Get new datatypes: send = %s, recv = %s\n",
 889                 MTestGetDatatypeName( sendtype ),
 890                 MTestGetDatatypeName( recvtype ) );
 891         fflush( stdout );
 892     }
 893
 894     return datatype_index;
 895 }
 896
 897 /* Reset the datatype index (start from the initial data type.
 898    Note: This routine is rarely needed; MTestGetDatatypes automatically
 899    starts over after the last available datatype is used.
 900 */
 901 void MTestResetDatatypes( void )
 902 {
 903     datatype_index = 0;
 904 }
 905 /* Return the index of the current datatype.  This is rarely needed and
 906    is provided mostly to enable debugging of the MTest package itself */
 907 int MTestGetDatatypeIndex( void )
 908 {
 909     return datatype_index;
 910 }
 911
 912 /* Free the storage associated with a datatype */
 913 void MTestFreeDatatype( MTestDatatype *mtype )
 914 {
 915     int merr;
 916     /* Invoke a datatype-specific free function to handle
 917        both the datatype and the send/receive buffers */
 918     if (mtype->FreeBuf) {
 919         (mtype->FreeBuf)( mtype );
 920     }
 921     /* Free the datatype itself if it was created */
 922     if (!mtype->isBasic) {
 923         merr = MPI_Type_free( &mtype->datatype );
 924         if (merr) MTestPrintError( merr );
 925     }
 926 }
 927
 928 /* Check that a message was received correctly.  Returns the number of
 929    errors detected.  Status may be NULL or MPI_STATUS_IGNORE */
 930 int MTestCheckRecv( MPI_Status *status, MTestDatatype *recvtype )
 931 {
 932     int count;
 933     int errs = 0, merr;
 934
 935     if (status && status != MPI_STATUS_IGNORE) {
 936         merr = MPI_Get_count( status, recvtype->datatype, &count );
 937         if (merr) MTestPrintError( merr );
 938
 939         /* Check count against expected count */
 940         if (count != recvtype->count) {
 941             errs ++;
 942         }
 943     }
 944
 945     /* Check received data */
 946     if (!errs && recvtype->CheckBuf( recvtype )) {
 947         errs++;
 948     }
 949     return errs;
 950 }
 951
 952 /* This next routine uses a circular buffer of static name arrays just to
 953    simplify the use of the routine */
 954 const char *MTestGetDatatypeName( MTestDatatype *dtype )
 955 {
 956     static char name[4][MPI_MAX_OBJECT_NAME];
 957     static int sp=0;
 958     int rlen, merr;
 959
 960     if (sp >= 4) sp = 0;
 961     merr = MPI_Type_get_name( dtype->datatype, name[sp], &rlen );
 962     if (merr) MTestPrintError( merr );
 963     return (const char *)name[sp++];
 964 }
 965 /* ----------------------------------------------------------------------- */
 966
 967 /*
 968  * Create communicators.  Use separate routines for inter and intra
 969  * communicators (there is a routine to give both)
 970  * Note that the routines may return MPI_COMM_NULL, so code should test for
 971  * that return value as well.
 972  *
 973  */
 974 static int interCommIdx = 0;
 975 static int intraCommIdx = 0;
 976 static const char *intraCommName = 0;
 977 static const char *interCommName = 0;
 978
 979 /*
 980  * Get an intracommunicator with at least min_size members.  If "allowSmaller"
 981  * is true, allow the communicator to be smaller than MPI_COMM_WORLD and
 982  * for this routine to return MPI_COMM_NULL for some values.  Returns 0 if
 983  * no more communicators are available.
 984  */
 985 int MTestGetIntracommGeneral( MPI_Comm *comm, int min_size, int allowSmaller )
 986 {
 987     int size, rank, merr;
 988     int done2, done=0;
 989     int isBasic = 0;
 990
 991     /* The while loop allows us to skip communicators that are too small.
 992        MPI_COMM_NULL is always considered large enough */
 993     while (!done) {
 994         isBasic = 0;
 995         intraCommName = "";
 996         switch (intraCommIdx) {
 997         case 0:
 998             *comm = MPI_COMM_WORLD;
 999             isBasic = 1;
1000             intraCommName = "MPI_COMM_WORLD";
1001             break;
1002         case 1:
1003             /* dup of world */
1004             merr = MPI_Comm_dup(MPI_COMM_WORLD, comm );
1005             if (merr) MTestPrintError( merr );
1006             intraCommName = "Dup of MPI_COMM_WORLD";
1007             break;
1008         case 2:
1009             /* reverse ranks */
1010             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1011             if (merr) MTestPrintError( merr );
1012             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1013             if (merr) MTestPrintError( merr );
1014             merr = MPI_Comm_split( MPI_COMM_WORLD, 0, size-rank, comm );
1015             if (merr) MTestPrintError( merr );
1016             intraCommName = "Rank reverse of MPI_COMM_WORLD";
1017             break;
1018         case 3:
1019             /* subset of world, with reversed ranks */
1020             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1021             if (merr) MTestPrintError( merr );
1022             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1023             if (merr) MTestPrintError( merr );
1024             merr = MPI_Comm_split( MPI_COMM_WORLD, ((rank < size/2) ? 1 : MPI_UNDEFINED),
1025                                    size-rank, comm );
1026             if (merr) MTestPrintError( merr );
1027             intraCommName = "Rank reverse of half of MPI_COMM_WORLD";
1028             break;
1029         case 4:
1030             *comm = MPI_COMM_SELF;
1031             isBasic = 1;
1032             intraCommName = "MPI_COMM_SELF";
1033             break;
1034
1035             /* These next cases are communicators that include some
1036                but not all of the processes */
1037         case 5:
1038         case 6:
1039         case 7:
1040         case 8:
1041         {
1042             int newsize;
1043             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1044             if (merr) MTestPrintError( merr );
1045             newsize = size - (intraCommIdx - 4);
1046
1047             if (allowSmaller && newsize >= min_size) {
1048                 merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1049                 if (merr) MTestPrintError( merr );
1050                 merr = MPI_Comm_split( MPI_COMM_WORLD, rank < newsize, rank,
1051                                        comm );
1052                 if (merr) MTestPrintError( merr );
1053                 if (rank >= newsize) {
1054                     merr = MPI_Comm_free( comm );
1055                     if (merr) MTestPrintError( merr );
1056                     *comm = MPI_COMM_NULL;
1057                 }
1058                 else {
1059                     intraCommName = "Split of WORLD";
1060                 }
1061             }
1062             else {
1063                 /* Act like default */
1064                 *comm = MPI_COMM_NULL;
1065                 intraCommIdx = -1;
1066             }
1067         }
1068         break;
1069
1070             /* Other ideas: dup of self, cart comm, graph comm */
1071         default:
1072             *comm = MPI_COMM_NULL;
1073             intraCommIdx = -1;
1074             break;
1075         }
1076
1077         if (*comm != MPI_COMM_NULL) {
1078             merr = MPI_Comm_size( *comm, &size );
1079             if (merr) MTestPrintError( merr );
1080             if (size >= min_size)
1081                 done = 1;
1082         }
1083         else {
1084             intraCommName = "MPI_COMM_NULL";
1085             isBasic = 1;
1086             done = 1;
1087         }
1088 done2=done;
1089         /* we are only done if all processes are done */
1090         MPI_Allreduce(&done2, &done, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD);
1091
1092         /* Advance the comm index whether we are done or not, otherwise we could
1093          * spin forever trying to allocate a too-small communicator over and
1094          * over again. */
1095         intraCommIdx++;
1096
1097         if (!done && !isBasic && *comm != MPI_COMM_NULL) {
1098             /* avoid leaking communicators */
1099             merr = MPI_Comm_free(comm);
1100             if (merr) MTestPrintError(merr);
1101         }
1102     }
1103
1104     return intraCommIdx;
1105 }
1106
1107 /*
1108  * Get an intracommunicator with at least min_size members.
1109  */
1110 int MTestGetIntracomm( MPI_Comm *comm, int min_size )
1111 {
1112     return MTestGetIntracommGeneral( comm, min_size, 0 );
1113 }
1114
1115 /* Return the name of an intra communicator */
1116 const char *MTestGetIntracommName( void )
1117 {
1118     return intraCommName;
1119 }
1120
1121 /*
1122  * Return an intercomm; set isLeftGroup to 1 if the calling process is
1123  * a member of the "left" group.
1124  */
1125 int MTestGetIntercomm( MPI_Comm *comm, int *isLeftGroup, int min_size )
1126 {
1127     int size, rank, remsize, merr;
1128     int done=0;
1129     MPI_Comm mcomm  = MPI_COMM_NULL;
1130     MPI_Comm mcomm2 = MPI_COMM_NULL;
1131     int rleader;
1132
1133     /* The while loop allows us to skip communicators that are too small.
1134        MPI_COMM_NULL is always considered large enough.  The size is
1135        the sum of the sizes of the local and remote groups */
1136     while (!done) {
1137         *comm = MPI_COMM_NULL;
1138         *isLeftGroup = 0;
1139         interCommName = "MPI_COMM_NULL";
1140
1141         switch (interCommIdx) {
1142         case 0:
1143             /* Split comm world in half */
1144             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1145             if (merr) MTestPrintError( merr );
1146             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1147             if (merr) MTestPrintError( merr );
1148             if (size > 1) {
1149                 merr = MPI_Comm_split( MPI_COMM_WORLD, (rank < size/2), rank,
1150                                        &mcomm );
1151                 if (merr) MTestPrintError( merr );
1152                 if (rank == 0) {
1153                     rleader = size/2;
1154                 }
1155                 else if (rank == size/2) {
1156                     rleader = 0;
1157                 }
1158                 else {
1159                     /* Remote leader is signficant only for the processes
1160                        designated local leaders */
1161                     rleader = -1;
1162                 }
1163                 *isLeftGroup = rank < size/2;
1164                 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader,
1165                                              12345, comm );
1166                 if (merr) MTestPrintError( merr );
1167                 interCommName = "Intercomm by splitting MPI_COMM_WORLD";
1168             }
1169             else
1170                 *comm = MPI_COMM_NULL;
1171             break;
1172         case 1:
1173             /* Split comm world in to 1 and the rest */
1174             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1175             if (merr) MTestPrintError( merr );
1176             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1177             if (merr) MTestPrintError( merr );
1178             if (size > 1) {
1179                 merr = MPI_Comm_split( MPI_COMM_WORLD, rank == 0, rank,
1180                                        &mcomm );
1181                 if (merr) MTestPrintError( merr );
1182                 if (rank == 0) {
1183                     rleader = 1;
1184                 }
1185                 else if (rank == 1) {
1186                     rleader = 0;
1187                 }
1188                 else {
1189                     /* Remote leader is signficant only for the processes
1190                        designated local leaders */
1191                     rleader = -1;
1192                 }
1193                 *isLeftGroup = rank == 0;
1194                 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD,
1195                                              rleader, 12346, comm );
1196                 if (merr) MTestPrintError( merr );
1197                 interCommName = "Intercomm by splitting MPI_COMM_WORLD into 1, rest";
1198             }
1199             else
1200                 *comm = MPI_COMM_NULL;
1201             break;
1202
1203         case 2:
1204             /* Split comm world in to 2 and the rest */
1205             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1206             if (merr) MTestPrintError( merr );
1207             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1208             if (merr) MTestPrintError( merr );
1209             if (size > 3) {
1210                 merr = MPI_Comm_split( MPI_COMM_WORLD, rank < 2, rank,
1211                                        &mcomm );
1212                 if (merr) MTestPrintError( merr );
1213                 if (rank == 0) {
1214                     rleader = 2;
1215                 }
1216                 else if (rank == 2) {
1217                     rleader = 0;
1218                 }
1219                 else {
1220                     /* Remote leader is signficant only for the processes
1221                        designated local leaders */
1222                     rleader = -1;
1223                 }
1224                 *isLeftGroup = rank < 2;
1225                 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD,
1226                                              rleader, 12347, comm );
1227                 if (merr) MTestPrintError( merr );
1228                 interCommName = "Intercomm by splitting MPI_COMM_WORLD into 2, rest";
1229             }
1230             else
1231                 *comm = MPI_COMM_NULL;
1232             break;
1233
1234         case 3:
1235             /* Split comm world in half, then dup */
1236             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1237             if (merr) MTestPrintError( merr );
1238             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1239             if (merr) MTestPrintError( merr );
1240             if (size > 1) {
1241                 merr = MPI_Comm_split( MPI_COMM_WORLD, (rank < size/2), rank,
1242                                        &mcomm );
1243                 if (merr) MTestPrintError( merr );
1244                 if (rank == 0) {
1245                     rleader = size/2;
1246                 }
1247                 else if (rank == size/2) {
1248                     rleader = 0;
1249                 }
1250                 else {
1251                     /* Remote leader is signficant only for the processes
1252                        designated local leaders */
1253                     rleader = -1;
1254                 }
1255                 *isLeftGroup = rank < size/2;
1256                 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader,
1257                                              12345, comm );
1258                 if (merr) MTestPrintError( merr );
1259                 /* avoid leaking after assignment below */
1260                 merr = MPI_Comm_free( &mcomm );
1261                 if (merr) MTestPrintError( merr );
1262
1263                 /* now dup, some bugs only occur for dup's of intercomms */
1264                 mcomm = *comm;
1265                 merr = MPI_Comm_dup(mcomm, comm);
1266                 if (merr) MTestPrintError( merr );
1267                 interCommName = "Intercomm by splitting MPI_COMM_WORLD then dup'ing";
1268             }
1269             else
1270                 *comm = MPI_COMM_NULL;
1271             break;
1272
1273         case 4:
1274             /* Split comm world in half, form intercomm, then split that intercomm */
1275             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1276             if (merr) MTestPrintError( merr );
1277             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1278             if (merr) MTestPrintError( merr );
1279             if (size > 1) {
1280                 merr = MPI_Comm_split( MPI_COMM_WORLD, (rank < size/2), rank,
1281                                        &mcomm );
1282                 if (merr) MTestPrintError( merr );
1283                 if (rank == 0) {
1284                     rleader = size/2;
1285                 }
1286                 else if (rank == size/2) {
1287                     rleader = 0;
1288                 }
1289                 else {
1290                     /* Remote leader is signficant only for the processes
1291                        designated local leaders */
1292                     rleader = -1;
1293                 }
1294                 *isLeftGroup = rank < size/2;
1295                 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader,
1296                                              12345, comm );
1297                 if (merr) MTestPrintError( merr );
1298                 /* avoid leaking after assignment below */
1299                 merr = MPI_Comm_free( &mcomm );
1300                 if (merr) MTestPrintError( merr );
1301
1302                 /* now split, some bugs only occur for splits of intercomms */
1303                 mcomm = *comm;
1304                 rank = MPI_Comm_rank(mcomm, &rank);
1305                 if (merr) MTestPrintError( merr );
1306                 /* this split is effectively a dup but tests the split code paths */
1307                 merr = MPI_Comm_split(mcomm, 0, rank, comm);
1308                 if (merr) MTestPrintError( merr );
1309                 interCommName = "Intercomm by splitting MPI_COMM_WORLD then then splitting again";
1310             }
1311             else
1312                 *comm = MPI_COMM_NULL;
1313             break;
1314
1315         case 5:
1316             /* split comm world in half discarding rank 0 on the "left"
1317              * communicator, then form them into an intercommunicator */
1318             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1319             if (merr) MTestPrintError( merr );
1320             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1321             if (merr) MTestPrintError( merr );
1322             if (size >= 4) {
1323                 int color = (rank < size/2 ? 0 : 1);
1324                 if (rank == 0)
1325                     color = MPI_UNDEFINED;
1326
1327                 merr = MPI_Comm_split( MPI_COMM_WORLD, color, rank, &mcomm );
1328                 if (merr) MTestPrintError( merr );
1329
1330                 if (rank == 1) {
1331                     rleader = size/2;
1332                 }
1333                 else if (rank == (size/2)) {
1334                     rleader = 1;
1335                 }
1336                 else {
1337                     /* Remote leader is signficant only for the processes
1338                        designated local leaders */
1339                     rleader = -1;
1340                 }
1341                 *isLeftGroup = rank < size/2;
1342                 if (rank != 0) { /* 0's mcomm is MPI_COMM_NULL */
1343                     merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader, 12345, comm );
1344                     if (merr) MTestPrintError( merr );
1345                 }
1346                 interCommName = "Intercomm by splitting MPI_COMM_WORLD (discarding rank 0 in the left group) then MPI_Intercomm_create'ing";
1347             }
1348             else {
1349                 *comm = MPI_COMM_NULL;
1350             }
1351             break;
1352
1353         case 6:
1354             /* Split comm world in half then form them into an
1355              * intercommunicator.  Then discard rank 0 from each group of the
1356              * intercomm via MPI_Comm_create. */
1357             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1358             if (merr) MTestPrintError( merr );
1359             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1360             if (merr) MTestPrintError( merr );
1361             if (size >= 4) {
1362                 MPI_Group oldgroup, newgroup;
1363                 int ranks[1];
1364                 int color = (rank < size/2 ? 0 : 1);
1365
1366                 merr = MPI_Comm_split( MPI_COMM_WORLD, color, rank, &mcomm );
1367                 if (merr) MTestPrintError( merr );
1368
1369                 if (rank == 0) {
1370                     rleader = size/2;
1371                 }
1372                 else if (rank == (size/2)) {
1373                     rleader = 0;
1374                 }
1375                 else {
1376                     /* Remote leader is signficant only for the processes
1377                        designated local leaders */
1378                     rleader = -1;
1379                 }
1380                 *isLeftGroup = rank < size/2;
1381                 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader, 12345, &mcomm2 );
1382                 if (merr) MTestPrintError( merr );
1383
1384                 /* We have an intercomm between the two halves of comm world. Now create
1385                  * a new intercomm that removes rank 0 on each side. */
1386                 merr = MPI_Comm_group(mcomm2, &oldgroup);
1387                 if (merr) MTestPrintError( merr );
1388                 ranks[0] = 0;
1389                 merr = MPI_Group_excl(oldgroup, 1, ranks, &newgroup);
1390                 if (merr) MTestPrintError( merr );
1391                 merr = MPI_Comm_create(mcomm2, newgroup, comm);
1392                 if (merr) MTestPrintError( merr );
1393
1394                 merr = MPI_Group_free(&oldgroup);
1395                 if (merr) MTestPrintError( merr );
1396                 merr = MPI_Group_free(&newgroup);
1397                 if (merr) MTestPrintError( merr );
1398
1399                 interCommName = "Intercomm by splitting MPI_COMM_WORLD then discarding 0 ranks with MPI_Comm_create";
1400             }
1401             else {
1402                 *comm = MPI_COMM_NULL;
1403             }
1404             break;
1405
1406         default:
1407             *comm = MPI_COMM_NULL;
1408             interCommIdx = -1;
1409             break;
1410         }
1411
1412         if (*comm != MPI_COMM_NULL) {
1413             merr = MPI_Comm_size( *comm, &size );
1414             if (merr) MTestPrintError( merr );
1415             merr = MPI_Comm_remote_size( *comm, &remsize );
1416             if (merr) MTestPrintError( merr );
1417             if (size + remsize >= min_size) done = 1;
1418         }
1419         else {
1420             interCommName = "MPI_COMM_NULL";
1421             done = 1;
1422         }
1423
1424         /* we are only done if all processes are done */
1425         MPI_Allreduce(MPI_IN_PLACE, &done, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD);
1426
1427         /* Advance the comm index whether we are done or not, otherwise we could
1428          * spin forever trying to allocate a too-small communicator over and
1429          * over again. */
1430         interCommIdx++;
1431
1432         if (!done && *comm != MPI_COMM_NULL) {
1433             /* avoid leaking communicators */
1434             merr = MPI_Comm_free(comm);
1435             if (merr) MTestPrintError(merr);
1436         }
1437
1438         /* cleanup for common temp objects */
1439         if (mcomm != MPI_COMM_NULL) {
1440             merr = MPI_Comm_free(&mcomm);
1441             if (merr) MTestPrintError( merr );
1442         }
1443         if (mcomm2 != MPI_COMM_NULL) {
1444             merr = MPI_Comm_free(&mcomm2);
1445             if (merr) MTestPrintError( merr );
1446         }
1447     }
1448
1449     return interCommIdx;
1450 }
1451 /* Return the name of an intercommunicator */
1452 const char *MTestGetIntercommName( void )
1453 {
1454     return interCommName;
1455 }
1456
1457 /* Get a communicator of a given minimum size.  Both intra and inter
1458    communicators are provided */
1459 int MTestGetComm( MPI_Comm *comm, int min_size )
1460 {
1461     int idx=0;
1462     static int getinter = 0;
1463
1464     if (!getinter) {
1465         idx = MTestGetIntracomm( comm, min_size );
1466         if (idx == 0) {
1467             getinter = 1;
1468         }
1469     }
1470     if (getinter) {
1471         int isLeft;
1472         idx = MTestGetIntercomm( comm, &isLeft, min_size );
1473         if (idx == 0) {
1474             getinter = 0;
1475         }
1476     }
1477
1478     return idx;
1479 }
1480
1481 /* Free a communicator.  It may be called with a predefined communicator
1482  or MPI_COMM_NULL */
1483 void MTestFreeComm( MPI_Comm *comm )
1484 {
1485     int merr;
1486     if (*comm != MPI_COMM_WORLD &&
1487         *comm != MPI_COMM_SELF &&
1488         *comm != MPI_COMM_NULL) {
1489         merr = MPI_Comm_free( comm );
1490         if (merr) MTestPrintError( merr );
1491     }
1492 }
1493
1494 /* ------------------------------------------------------------------------ */
1495 void MTestPrintError( int errcode )
1496 {
1497     int errclass, slen;
1498     char string[MPI_MAX_ERROR_STRING];
1499
1500     MPI_Error_class( errcode, &errclass );
1501     MPI_Error_string( errcode, string, &slen );
1502     printf( "Error class %d (%s)\n", errclass, string );
1503     fflush( stdout );
1504 }
1505 void MTestPrintErrorMsg( const char msg[], int errcode )
1506 {
1507     int errclass, slen;
1508     char string[MPI_MAX_ERROR_STRING];
1509
1510     MPI_Error_class( errcode, &errclass );
1511     MPI_Error_string( errcode, string, &slen );
1512     printf( "%s: Error class %d (%s)\n", msg, errclass, string );
1513     fflush( stdout );
1514 }
1515 /* ------------------------------------------------------------------------ */
1516 /*
1517  If verbose output is selected and the level is at least that of the
1518  value of the verbose flag, then perform printf( format, ... );
1519  */
1520 void MTestPrintfMsg( int level, const char format[], ... )
1521 {
1522     va_list list;
1523
1524     if (verbose && level >= verbose) {
1525         va_start(list,format);
1526         vprintf( format, list );
1527         va_end(list);
1528         fflush(stdout);
1529     }
1530 }
1531 /* Fatal error.  Report and exit */
1532 void MTestError( const char *msg )
1533 {
1534     fprintf( stderr, "%s\n", msg );
1535     fflush( stderr );
1536     MPI_Abort( MPI_COMM_WORLD, 1 );
1537     exit(1);
1538 }
1539 /* ------------------------------------------------------------------------ */
1540 static void MTestResourceSummary( FILE *fp )
1541 {
1542 #ifdef HAVE_GETRUSAGE
1543     struct rusage ru;
1544     static int pfThreshold = -2;
1545     int doOutput = 1;
1546     if (getrusage( RUSAGE_SELF, &ru ) == 0) {
1547         /* There is an option to generate output only when a resource
1548            exceeds a threshold.  To date, only page faults supported. */
1549         if (pfThreshold == -2) {
1550             char *p = getenv("MPITEST_RUSAGE_PF");
1551             pfThreshold = -1;
1552             if (p) {
1553                 pfThreshold = strtol( p, 0, 0 );
1554             }
1555         }
1556         if (pfThreshold > 0) {
1557             doOutput = ru.ru_minflt > pfThreshold;
1558         }
1559         if (doOutput) {
1560             /* Cast values to long in case some system has defined them
1561                as another integer type */
1562             fprintf( fp, "RUSAGE: max resident set = %ldKB\n",
1563                      (long)ru.ru_maxrss );
1564             fprintf( fp, "RUSAGE: page faults = %ld : %ld\n",
1565                      (long)ru.ru_minflt, (long)ru.ru_majflt );
1566             /* Not every Unix provides useful information for the xxrss fields */
1567             fprintf( fp, "RUSAGE: memory in text/data/stack = %ld : %ld : %ld\n",
1568                      (long)ru.ru_ixrss, (long)ru.ru_idrss, (long)ru.ru_isrss );
1569             fprintf( fp, "RUSAGE: I/O in and out = %ld : %ld\n",
1570                      (long)ru.ru_inblock, (long)ru.ru_oublock );
1571             fprintf( fp, "RUSAGE: context switch = %ld : %ld\n",
1572                      (long)ru.ru_nvcsw, (long)ru.ru_nivcsw );
1573         }
1574     }
1575     else {
1576         fprintf( fp, "RUSAGE: return error %d\n", errno );
1577     }
1578 #endif
1579 }
1580 /* ------------------------------------------------------------------------ */
1581 #ifdef HAVE_MPI_WIN_CREATE
1582 /*
1583  * Create MPI Windows
1584  */
1585 static int win_index = 0;
1586 static const char *winName;
1587 /* Use an attribute to remember the type of memory allocation (static,
1588    malloc, or MPI_Alloc_mem) */
1589 static int mem_keyval = MPI_KEYVAL_INVALID;
1590 int MTestGetWin( MPI_Win *win, int mustBePassive )
1591 {
1592     static char actbuf[1024];
1593     static char *pasbuf;
1594     char        *buf;
1595     int         n, rank, merr;
1596     MPI_Info    info;
1597
1598     if (mem_keyval == MPI_KEYVAL_INVALID) {
1599         /* Create the keyval */
1600         merr = MPI_Win_create_keyval( MPI_WIN_NULL_COPY_FN,
1601                                       MPI_WIN_NULL_DELETE_FN,
1602                                       &mem_keyval, 0 );
1603         if (merr) MTestPrintError( merr );
1604
1605     }
1606
1607     switch (win_index) {
1608     case 0:
1609         /* Active target window */
1610         merr = MPI_Win_create( actbuf, 1024, 1, MPI_INFO_NULL, MPI_COMM_WORLD,
1611                                win );
1612         if (merr) MTestPrintError( merr );
1613         winName = "active-window";
1614         merr = MPI_Win_set_attr( *win, mem_keyval, (void *)0 );
1615         if (merr) MTestPrintError( merr );
1616         break;
1617     case 1:
1618         /* Passive target window */
1619         merr = MPI_Alloc_mem( 1024, MPI_INFO_NULL, &pasbuf );
1620         if (merr) MTestPrintError( merr );
1621         merr = MPI_Win_create( pasbuf, 1024, 1, MPI_INFO_NULL, MPI_COMM_WORLD,
1622                                win );
1623         if (merr) MTestPrintError( merr );
1624         winName = "passive-window";
1625         merr = MPI_Win_set_attr( *win, mem_keyval, (void *)2 );
1626         if (merr) MTestPrintError( merr );
1627         break;
1628     case 2:
1629         /* Active target; all windows different sizes */
1630         merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1631         if (merr) MTestPrintError( merr );
1632         n = rank * 64;
1633         if (n)
1634             buf = (char *)malloc( n );
1635         else
1636             buf = 0;
1637         merr = MPI_Win_create( buf, n, 1, MPI_INFO_NULL, MPI_COMM_WORLD,
1638                                win );
1639         if (merr) MTestPrintError( merr );
1640         winName = "active-all-different-win";
1641         merr = MPI_Win_set_attr( *win, mem_keyval, (void *)1 );
1642         if (merr) MTestPrintError( merr );
1643         break;
1644     case 3:
1645         /* Active target, no locks set */
1646         merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1647         if (merr) MTestPrintError( merr );
1648         n = rank * 64;
1649         if (n)
1650             buf = (char *)malloc( n );
1651         else
1652             buf = 0;
1653         merr = MPI_Info_create( &info );
1654         if (merr) MTestPrintError( merr );
1655         merr = MPI_Info_set( info, (char*)"nolocks", (char*)"true" );
1656         if (merr) MTestPrintError( merr );
1657         merr = MPI_Win_create( buf, n, 1, info, MPI_COMM_WORLD, win );
1658         if (merr) MTestPrintError( merr );
1659         merr = MPI_Info_free( &info );
1660         if (merr) MTestPrintError( merr );
1661         winName = "active-nolocks-all-different-win";
1662         merr = MPI_Win_set_attr( *win, mem_keyval, (void *)1 );
1663         if (merr) MTestPrintError( merr );
1664         break;
1665     default:
1666         win_index = -1;
1667     }
1668     win_index++;
1669     return win_index;
1670 }
1671 /* Return a pointer to the name associated with a window object */
1672 const char *MTestGetWinName( void )
1673 {
1674     return winName;
1675 }
1676 /* Free the storage associated with a window object */
1677 void MTestFreeWin( MPI_Win *win )
1678 {
1679     void *addr;
1680     int  flag, merr;
1681
1682     merr = MPI_Win_get_attr( *win, MPI_WIN_BASE, &addr, &flag );
1683     if (merr) MTestPrintError( merr );
1684     if (!flag) {
1685         MTestError( "Could not get WIN_BASE from window" );
1686     }
1687     if (addr) {
1688         void *val;
1689         merr = MPI_Win_get_attr( *win, mem_keyval, &val, &flag );
1690         if (merr) MTestPrintError( merr );
1691         if (flag) {
1692             if (val == (void *)1) {
1693                 free( addr );
1694             }
1695             else if (val == (void *)2) {
1696                 merr = MPI_Free_mem( addr );
1697                 if (merr) MTestPrintError( merr );
1698             }
1699             /* if val == (void *)0, then static data that must not be freed */
1700         }
1701     }
1702     merr = MPI_Win_free(win);
1703     if (merr) MTestPrintError( merr );
1704 }
1705 static void MTestRMACleanup( void )
1706 {
1707     if (mem_keyval != MPI_KEYVAL_INVALID) {
1708         MPI_Win_free_keyval( &mem_keyval );
1709     }
1710 }
1711 #else
1712 static void MTestRMACleanup( void ) {}
1713 #endif