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