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

   1 /* -*- Mode: C; c-basic-offset:4 ; indent-tabs-mode:nil ; -*- */
   2 /*
   3  *
   4  *  (C) 2001 by Argonne National Laboratory.
   5  *      See COPYRIGHT in top-level directory.
   6  */
   7 #include "mpi.h"
   8 #include "mpitestconf.h"
   9 #include "mpitest.h"
  10 #if defined(HAVE_STDIO_H) || defined(STDC_HEADERS)
  11 #include <stdio.h>
  12 #endif
  13 #if defined(HAVE_STDLIB_H) || defined(STDC_HEADERS)
  14 #include <stdlib.h>
  15 #endif
  16 #if defined(HAVE_STRING_H) || defined(STDC_HEADERS)
  17 #include <string.h>
  18 #endif
  19 #ifdef HAVE_STDARG_H
  20 #include <stdarg.h>
  21 #endif
  22 /* The following two includes permit the collection of resource usage
  23    data in the tests
  24  */
  25 #ifdef HAVE_SYS_TIME_H
  26 #include <sys/time.h>
  27 #endif
  28 #ifdef HAVE_SYS_RESOURCE_H
  29 #include <sys/resource.h>
  30 #endif
  31 #include <errno.h>
  32
  33
  34 /*
  35  * Utility routines for writing MPI tests.
  36  *
  37  * We check the return codes on all MPI routines (other than INIT)
  38  * to allow the program that uses these routines to select MPI_ERRORS_RETURN
  39  * as the error handler.  We do *not* set MPI_ERRORS_RETURN because
  40  * the code that makes use of these routines may not check return
  41  * codes.
  42  *
  43  */
  44
  45 static void MTestRMACleanup( void );
  46 static void MTestResourceSummary( FILE * );
  47
  48 /* Here is where we could put the includes and definitions to enable
  49    memory testing */
  50
  51 SMPI_VARINIT_GLOBAL_AND_SET(dbgflag, int, 0); /* Flag used for debugging */
  52 SMPI_VARINIT_GLOBAL_AND_SET(wrank, int, -1);  /* World rank */
  53 SMPI_VARINIT_GLOBAL_AND_SET(verbose, int, 0); /* Message level (0 is none) */
  54 SMPI_VARINIT_GLOBAL_AND_SET(returnWithVal, int, 0); /* Allow programs to return
  55                                    with a non-zero if there was an error (may
  56                                    cause problems with some runtime systems) */
  57 SMPI_VARINIT_GLOBAL_AND_SET(usageOutput, int, 0); /* */
  58
  59 /* Provide backward portability to MPI 1 */
  60 #ifndef MPI_VERSION
  61 #define MPI_VERSION 1
  62 #endif
  63 #if MPI_VERSION < 2
  64 #define MPI_THREAD_SINGLE 0
  65 #endif
  66
  67 /*
  68  * Initialize and Finalize MTest
  69  */
  70
  71 /*
  72    Initialize MTest, initializing MPI if necessary.
  73
  74  Environment Variables:
  75 + MPITEST_DEBUG - If set (to any value), turns on debugging output
  76 . MPITEST_THREADLEVEL_DEFAULT - If set, use as the default "provided"
  77                                 level of thread support.  Applies to
  78                                 MTest_Init but not MTest_Init_thread.
  79 - MPITEST_VERBOSE - If set to a numeric value, turns on that level of
  80   verbose output.  This is used by the routine 'MTestPrintfMsg'
  81
  82 */
  83 void MTest_Init_thread( int *argc, char ***argv, int required, int *provided )
  84 {
  85     int flag;
  86     char *envval = 0;
  87
  88     MPI_Initialized( &flag );
  89     if (!flag) {
  90         /* Permit an MPI that claims only MPI 1 but includes the
  91            MPI_Init_thread routine (e.g., IBM MPI) */
  92 #if MPI_VERSION >= 2 || defined(HAVE_MPI_INIT_THREAD)
  93         MPI_Init_thread( argc, argv, required, provided );
  94 #else
  95         MPI_Init( argc, argv );
  96         *provided = -1;
  97 #endif
  98     }
  99     /* Check for debugging control */
 100     if (getenv( "MPITEST_DEBUG" )) {
 101         SMPI_VARGET_GLOBAL(dbgflag) = 1;
 102         MPI_Comm_rank( MPI_COMM_WORLD, &SMPI_VARGET_GLOBAL(wrank) );
 103     }
 104
 105     /* Check for verbose control */
 106     envval = getenv( "MPITEST_VERBOSE" );
 107     if (envval) {
 108         char *s;
 109         long val = strtol( envval, &s, 0 );
 110         if (s == envval) {
 111             /* This is the error case for strtol */
 112             fprintf( stderr, "Warning: %s not valid for MPITEST_VERBOSE\n",
 113                      envval );
 114             fflush( stderr );
 115         }
 116         else {
 117             if (val >= 0) {
 118                 SMPI_VARGET_GLOBAL(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             SMPI_VARGET_GLOBAL(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             SMPI_VARGET_GLOBAL(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         SMPI_VARGET_GLOBAL(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 (SMPI_VARGET_GLOBAL(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 (SMPI_VARGET_GLOBAL(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 HAVE_WINDOWS_H
 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 SMPI_VARINIT_GLOBAL_AND_SET(datatype_index, int, 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 (SMPI_VARGET_GLOBAL(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         SMPI_VARGET_GLOBAL(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     SMPI_VARGET_GLOBAL(datatype_index)++;
 873
 874     if (SMPI_VARGET_GLOBAL(dbgflag) && SMPI_VARGET_GLOBAL(datatype_index) > 0) {
 875         int typesize;
 876         fprintf( stderr, "%d: sendtype is %s\n", SMPI_VARGET_GLOBAL(wrank), MTestGetDatatypeName( sendtype ) );
 877         merr = MPI_Type_size( sendtype->datatype, &typesize );
 878         if (merr) MTestPrintError( merr );
 879         fprintf( stderr, "%d: sendtype size = %d\n", SMPI_VARGET_GLOBAL(wrank), typesize );
 880         fprintf( stderr, "%d: recvtype is %s\n", SMPI_VARGET_GLOBAL(wrank), MTestGetDatatypeName( recvtype ) );
 881         merr = MPI_Type_size( recvtype->datatype, &typesize );
 882         if (merr) MTestPrintError( merr );
 883         fprintf( stderr, "%d: recvtype size = %d\n", SMPI_VARGET_GLOBAL(wrank), typesize );
 884         fflush( stderr );
 885
 886     }
 887     else if (SMPI_VARGET_GLOBAL(verbose) && SMPI_VARGET_GLOBAL(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 SMPI_VARGET_GLOBAL(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     SMPI_VARGET_GLOBAL(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 SMPI_VARGET_GLOBAL(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     typedef char name_type[4][MPI_MAX_OBJECT_NAME];
 957     SMPI_VARINIT_STATIC(name, name_type);
 958     SMPI_VARINIT_STATIC_AND_SET(sp, int, 0);
 959     int rlen, merr;
 960
 961     if (SMPI_VARGET_STATIC(sp) >= 4) SMPI_VARGET_STATIC(sp) = 0;
 962     merr = MPI_Type_get_name( dtype->datatype, SMPI_VARGET_STATIC(name)[SMPI_VARGET_STATIC(sp)], &rlen );
 963     if (merr) MTestPrintError( merr );
 964     return (const char *)SMPI_VARGET_STATIC(name)[SMPI_VARGET_STATIC(sp)++];
 965 }
 966 /* ----------------------------------------------------------------------- */
 967
 968 /*
 969  * Create communicators.  Use separate routines for inter and intra
 970  * communicators (there is a routine to give both)
 971  * Note that the routines may return MPI_COMM_NULL, so code should test for
 972  * that return value as well.
 973  *
 974  */
 975 SMPI_VARINIT_GLOBAL_AND_SET(interCommIdx, int, 0);
 976 SMPI_VARINIT_GLOBAL_AND_SET(intraCommIdx, int, 0);
 977 SMPI_VARINIT_GLOBAL_AND_SET(intraCommName, const char *, 0);
 978 SMPI_VARINIT_GLOBAL_AND_SET(interCommName, const char *, 0);
 979
 980 /*
 981  * Get an intracommunicator with at least min_size members.  If "allowSmaller"
 982  * is true, allow the communicator to be smaller than MPI_COMM_WORLD and
 983  * for this routine to return MPI_COMM_NULL for some values.  Returns 0 if
 984  * no more communicators are available.
 985  */
 986 int MTestGetIntracommGeneral( MPI_Comm *comm, int min_size, int allowSmaller )
 987 {
 988     int size, rank, merr;
 989     int done2, done=0;
 990     int isBasic = 0;
 991
 992     /* The while loop allows us to skip communicators that are too small.
 993        MPI_COMM_NULL is always considered large enough */
 994     while (!done) {
 995         isBasic = 0;
 996         SMPI_VARGET_GLOBAL(intraCommName) = "";
 997         switch (SMPI_VARGET_GLOBAL(intraCommIdx)) {
 998         case 0:
 999             *comm = MPI_COMM_WORLD;
1000             isBasic = 1;
1001             SMPI_VARGET_GLOBAL(intraCommName) = "MPI_COMM_WORLD";
1002             break;
1003         case 1:
1004             /* dup of world */
1005             merr = MPI_Comm_dup(MPI_COMM_WORLD, comm );
1006             if (merr) MTestPrintError( merr );
1007             SMPI_VARGET_GLOBAL(intraCommName) = "Dup of MPI_COMM_WORLD";
1008             break;
1009         case 2:
1010             /* reverse ranks */
1011             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1012             if (merr) MTestPrintError( merr );
1013             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1014             if (merr) MTestPrintError( merr );
1015             merr = MPI_Comm_split( MPI_COMM_WORLD, 0, size-rank, comm );
1016             if (merr) MTestPrintError( merr );
1017             SMPI_VARGET_GLOBAL(intraCommName) = "Rank reverse of MPI_COMM_WORLD";
1018             break;
1019         case 3:
1020             /* subset of world, with reversed ranks */
1021             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1022             if (merr) MTestPrintError( merr );
1023             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1024             if (merr) MTestPrintError( merr );
1025             merr = MPI_Comm_split( MPI_COMM_WORLD, ((rank < size/2) ? 1 : MPI_UNDEFINED),
1026                                    size-rank, comm );
1027             if (merr) MTestPrintError( merr );
1028             SMPI_VARGET_GLOBAL(intraCommName) = "Rank reverse of half of MPI_COMM_WORLD";
1029             break;
1030         case 4:
1031             *comm = MPI_COMM_SELF;
1032             isBasic = 1;
1033             SMPI_VARGET_GLOBAL(intraCommName) = "MPI_COMM_SELF";
1034             break;
1035
1036             /* These next cases are communicators that include some
1037                but not all of the processes */
1038         case 5:
1039         case 6:
1040         case 7:
1041         case 8:
1042         {
1043             int newsize;
1044             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1045             if (merr) MTestPrintError( merr );
1046             newsize = size - (SMPI_VARGET_GLOBAL(intraCommIdx) - 4);
1047
1048             if (allowSmaller && newsize >= min_size) {
1049                 merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1050                 if (merr) MTestPrintError( merr );
1051                 merr = MPI_Comm_split( MPI_COMM_WORLD, rank < newsize, rank,
1052                                        comm );
1053                 if (merr) MTestPrintError( merr );
1054                 if (rank >= newsize) {
1055                     merr = MPI_Comm_free( comm );
1056                     if (merr) MTestPrintError( merr );
1057                     *comm = MPI_COMM_NULL;
1058                 }
1059                 else {
1060                     SMPI_VARGET_GLOBAL(intraCommName) = "Split of WORLD";
1061                 }
1062             }
1063             else {
1064                 /* Act like default */
1065                 *comm = MPI_COMM_NULL;
1066                 SMPI_VARGET_GLOBAL(intraCommIdx) = -1;
1067             }
1068         }
1069         break;
1070
1071             /* Other ideas: dup of self, cart comm, graph comm */
1072         default:
1073             *comm = MPI_COMM_NULL;
1074             SMPI_VARGET_GLOBAL(intraCommIdx) = -1;
1075             break;
1076         }
1077
1078         if (*comm != MPI_COMM_NULL) {
1079             merr = MPI_Comm_size( *comm, &size );
1080             if (merr) MTestPrintError( merr );
1081             if (size >= min_size)
1082                 done = 1;
1083         }
1084         else {
1085             SMPI_VARGET_GLOBAL(intraCommName) = "MPI_COMM_NULL";
1086             isBasic = 1;
1087             done = 1;
1088         }
1089 done2=done;
1090         /* we are only done if all processes are done */
1091         MPI_Allreduce(&done2, &done, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD);
1092
1093         /* Advance the comm index whether we are done or not, otherwise we could
1094          * spin forever trying to allocate a too-small communicator over and
1095          * over again. */
1096         SMPI_VARGET_GLOBAL(intraCommIdx)++;
1097
1098         if (!done && !isBasic && *comm != MPI_COMM_NULL) {
1099             /* avoid leaking communicators */
1100             merr = MPI_Comm_free(comm);
1101             if (merr) MTestPrintError(merr);
1102         }
1103     }
1104
1105     return SMPI_VARGET_GLOBAL(intraCommIdx);
1106 }
1107
1108 /*
1109  * Get an intracommunicator with at least min_size members.
1110  */
1111 int MTestGetIntracomm( MPI_Comm *comm, int min_size )
1112 {
1113     return MTestGetIntracommGeneral( comm, min_size, 0 );
1114 }
1115
1116 /* Return the name of an intra communicator */
1117 const char *MTestGetIntracommName( void )
1118 {
1119     return SMPI_VARGET_GLOBAL(intraCommName);
1120 }
1121
1122 /*
1123  * Return an intercomm; set isLeftGroup to 1 if the calling process is
1124  * a member of the "left" group.
1125  */
1126 int MTestGetIntercomm( MPI_Comm *comm, int *isLeftGroup, int min_size )
1127 {
1128     int size, rank, remsize, merr;
1129     int done=0;
1130     MPI_Comm mcomm  = MPI_COMM_NULL;
1131     MPI_Comm mcomm2 = MPI_COMM_NULL;
1132     int rleader;
1133
1134     /* The while loop allows us to skip communicators that are too small.
1135        MPI_COMM_NULL is always considered large enough.  The size is
1136        the sum of the sizes of the local and remote groups */
1137     while (!done) {
1138         *comm = MPI_COMM_NULL;
1139         *isLeftGroup = 0;
1140         SMPI_VARGET_GLOBAL(interCommName) = "MPI_COMM_NULL";
1141
1142         switch (SMPI_VARGET_GLOBAL(interCommIdx)) {
1143         case 0:
1144             /* Split comm world in half */
1145             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1146             if (merr) MTestPrintError( merr );
1147             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1148             if (merr) MTestPrintError( merr );
1149             if (size > 1) {
1150                 merr = MPI_Comm_split( MPI_COMM_WORLD, (rank < size/2), rank,
1151                                        &mcomm );
1152                 if (merr) MTestPrintError( merr );
1153                 if (rank == 0) {
1154                     rleader = size/2;
1155                 }
1156                 else if (rank == size/2) {
1157                     rleader = 0;
1158                 }
1159                 else {
1160                     /* Remote leader is signficant only for the processes
1161                        designated local leaders */
1162                     rleader = -1;
1163                 }
1164                 *isLeftGroup = rank < size/2;
1165                 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader,
1166                                              12345, comm );
1167                 if (merr) MTestPrintError( merr );
1168                 SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD";
1169             }
1170             else
1171                 *comm = MPI_COMM_NULL;
1172             break;
1173         case 1:
1174             /* Split comm world in to 1 and the rest */
1175             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1176             if (merr) MTestPrintError( merr );
1177             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1178             if (merr) MTestPrintError( merr );
1179             if (size > 1) {
1180                 merr = MPI_Comm_split( MPI_COMM_WORLD, rank == 0, rank,
1181                                        &mcomm );
1182                 if (merr) MTestPrintError( merr );
1183                 if (rank == 0) {
1184                     rleader = 1;
1185                 }
1186                 else if (rank == 1) {
1187                     rleader = 0;
1188                 }
1189                 else {
1190                     /* Remote leader is signficant only for the processes
1191                        designated local leaders */
1192                     rleader = -1;
1193                 }
1194                 *isLeftGroup = rank == 0;
1195                 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD,
1196                                              rleader, 12346, comm );
1197                 if (merr) MTestPrintError( merr );
1198                 SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD into 1, rest";
1199             }
1200             else
1201                 *comm = MPI_COMM_NULL;
1202             break;
1203
1204         case 2:
1205             /* Split comm world in to 2 and the rest */
1206             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1207             if (merr) MTestPrintError( merr );
1208             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1209             if (merr) MTestPrintError( merr );
1210             if (size > 3) {
1211                 merr = MPI_Comm_split( MPI_COMM_WORLD, rank < 2, rank,
1212                                        &mcomm );
1213                 if (merr) MTestPrintError( merr );
1214                 if (rank == 0) {
1215                     rleader = 2;
1216                 }
1217                 else if (rank == 2) {
1218                     rleader = 0;
1219                 }
1220                 else {
1221                     /* Remote leader is signficant only for the processes
1222                        designated local leaders */
1223                     rleader = -1;
1224                 }
1225                 *isLeftGroup = rank < 2;
1226                 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD,
1227                                              rleader, 12347, comm );
1228                 if (merr) MTestPrintError( merr );
1229                 SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD into 2, rest";
1230             }
1231             else
1232                 *comm = MPI_COMM_NULL;
1233             break;
1234
1235         case 3:
1236             /* Split comm world in half, then dup */
1237             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1238             if (merr) MTestPrintError( merr );
1239             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1240             if (merr) MTestPrintError( merr );
1241             if (size > 1) {
1242                 merr = MPI_Comm_split( MPI_COMM_WORLD, (rank < size/2), rank,
1243                                        &mcomm );
1244                 if (merr) MTestPrintError( merr );
1245                 if (rank == 0) {
1246                     rleader = size/2;
1247                 }
1248                 else if (rank == size/2) {
1249                     rleader = 0;
1250                 }
1251                 else {
1252                     /* Remote leader is signficant only for the processes
1253                        designated local leaders */
1254                     rleader = -1;
1255                 }
1256                 *isLeftGroup = rank < size/2;
1257                 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader,
1258                                              12345, comm );
1259                 if (merr) MTestPrintError( merr );
1260                 /* avoid leaking after assignment below */
1261                 merr = MPI_Comm_free( &mcomm );
1262                 if (merr) MTestPrintError( merr );
1263
1264                 /* now dup, some bugs only occur for dup's of intercomms */
1265                 mcomm = *comm;
1266                 merr = MPI_Comm_dup(mcomm, comm);
1267                 if (merr) MTestPrintError( merr );
1268                 SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD then dup'ing";
1269             }
1270             else
1271                 *comm = MPI_COMM_NULL;
1272             break;
1273
1274         case 4:
1275             /* Split comm world in half, form intercomm, then split that intercomm */
1276             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1277             if (merr) MTestPrintError( merr );
1278             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1279             if (merr) MTestPrintError( merr );
1280             if (size > 1) {
1281                 merr = MPI_Comm_split( MPI_COMM_WORLD, (rank < size/2), rank,
1282                                        &mcomm );
1283                 if (merr) MTestPrintError( merr );
1284                 if (rank == 0) {
1285                     rleader = size/2;
1286                 }
1287                 else if (rank == size/2) {
1288                     rleader = 0;
1289                 }
1290                 else {
1291                     /* Remote leader is signficant only for the processes
1292                        designated local leaders */
1293                     rleader = -1;
1294                 }
1295                 *isLeftGroup = rank < size/2;
1296                 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader,
1297                                              12345, comm );
1298                 if (merr) MTestPrintError( merr );
1299                 /* avoid leaking after assignment below */
1300                 merr = MPI_Comm_free( &mcomm );
1301                 if (merr) MTestPrintError( merr );
1302
1303                 /* now split, some bugs only occur for splits of intercomms */
1304                 mcomm = *comm;
1305                 rank = MPI_Comm_rank(mcomm, &rank);
1306                 if (merr) MTestPrintError( merr );
1307                 /* this split is effectively a dup but tests the split code paths */
1308                 merr = MPI_Comm_split(mcomm, 0, rank, comm);
1309                 if (merr) MTestPrintError( merr );
1310                 SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD then then splitting again";
1311             }
1312             else
1313                 *comm = MPI_COMM_NULL;
1314             break;
1315
1316         case 5:
1317             /* split comm world in half discarding rank 0 on the "left"
1318              * communicator, then form them into an intercommunicator */
1319             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1320             if (merr) MTestPrintError( merr );
1321             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1322             if (merr) MTestPrintError( merr );
1323             if (size >= 4) {
1324                 int color = (rank < size/2 ? 0 : 1);
1325                 if (rank == 0)
1326                     color = MPI_UNDEFINED;
1327
1328                 merr = MPI_Comm_split( MPI_COMM_WORLD, color, rank, &mcomm );
1329                 if (merr) MTestPrintError( merr );
1330
1331                 if (rank == 1) {
1332                     rleader = size/2;
1333                 }
1334                 else if (rank == (size/2)) {
1335                     rleader = 1;
1336                 }
1337                 else {
1338                     /* Remote leader is signficant only for the processes
1339                        designated local leaders */
1340                     rleader = -1;
1341                 }
1342                 *isLeftGroup = rank < size/2;
1343                 if (rank != 0) { /* 0's mcomm is MPI_COMM_NULL */
1344                     merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader, 12345, comm );
1345                     if (merr) MTestPrintError( merr );
1346                 }
1347                 SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD (discarding rank 0 in the left group) then MPI_Intercomm_create'ing";
1348             }
1349             else {
1350                 *comm = MPI_COMM_NULL;
1351             }
1352             break;
1353
1354         case 6:
1355             /* Split comm world in half then form them into an
1356              * intercommunicator.  Then discard rank 0 from each group of the
1357              * intercomm via MPI_Comm_create. */
1358             merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1359             if (merr) MTestPrintError( merr );
1360             merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1361             if (merr) MTestPrintError( merr );
1362             if (size >= 4) {
1363                 MPI_Group oldgroup, newgroup;
1364                 int ranks[1];
1365                 int color = (rank < size/2 ? 0 : 1);
1366
1367                 merr = MPI_Comm_split( MPI_COMM_WORLD, color, rank, &mcomm );
1368                 if (merr) MTestPrintError( merr );
1369
1370                 if (rank == 0) {
1371                     rleader = size/2;
1372                 }
1373                 else if (rank == (size/2)) {
1374                     rleader = 0;
1375                 }
1376                 else {
1377                     /* Remote leader is signficant only for the processes
1378                        designated local leaders */
1379                     rleader = -1;
1380                 }
1381                 *isLeftGroup = rank < size/2;
1382                 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader, 12345, &mcomm2 );
1383                 if (merr) MTestPrintError( merr );
1384
1385                 /* We have an intercomm between the two halves of comm world. Now create
1386                  * a new intercomm that removes rank 0 on each side. */
1387                 merr = MPI_Comm_group(mcomm2, &oldgroup);
1388                 if (merr) MTestPrintError( merr );
1389                 ranks[0] = 0;
1390                 merr = MPI_Group_excl(oldgroup, 1, ranks, &newgroup);
1391                 if (merr) MTestPrintError( merr );
1392                 merr = MPI_Comm_create(mcomm2, newgroup, comm);
1393                 if (merr) MTestPrintError( merr );
1394
1395                 merr = MPI_Group_free(&oldgroup);
1396                 if (merr) MTestPrintError( merr );
1397                 merr = MPI_Group_free(&newgroup);
1398                 if (merr) MTestPrintError( merr );
1399
1400                 SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD then discarding 0 ranks with MPI_Comm_create";
1401             }
1402             else {
1403                 *comm = MPI_COMM_NULL;
1404             }
1405             break;
1406
1407         default:
1408             *comm = MPI_COMM_NULL;
1409             SMPI_VARGET_GLOBAL(interCommIdx) = -1;
1410             break;
1411         }
1412
1413         if (*comm != MPI_COMM_NULL) {
1414             merr = MPI_Comm_size( *comm, &size );
1415             if (merr) MTestPrintError( merr );
1416             merr = MPI_Comm_remote_size( *comm, &remsize );
1417             if (merr) MTestPrintError( merr );
1418             if (size + remsize >= min_size) done = 1;
1419         }
1420         else {
1421             SMPI_VARGET_GLOBAL(interCommName) = "MPI_COMM_NULL";
1422             done = 1;
1423         }
1424
1425         /* we are only done if all processes are done */
1426         MPI_Allreduce(MPI_IN_PLACE, &done, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD);
1427
1428         /* Advance the comm index whether we are done or not, otherwise we could
1429          * spin forever trying to allocate a too-small communicator over and
1430          * over again. */
1431         SMPI_VARGET_GLOBAL(interCommIdx)++;
1432
1433         if (!done && *comm != MPI_COMM_NULL) {
1434             /* avoid leaking communicators */
1435             merr = MPI_Comm_free(comm);
1436             if (merr) MTestPrintError(merr);
1437         }
1438
1439         /* cleanup for common temp objects */
1440         if (mcomm != MPI_COMM_NULL) {
1441             merr = MPI_Comm_free(&mcomm);
1442             if (merr) MTestPrintError( merr );
1443         }
1444         if (mcomm2 != MPI_COMM_NULL) {
1445             merr = MPI_Comm_free(&mcomm2);
1446             if (merr) MTestPrintError( merr );
1447         }
1448     }
1449
1450     return SMPI_VARGET_GLOBAL(interCommIdx);
1451 }
1452 /* Return the name of an intercommunicator */
1453 const char *MTestGetIntercommName( void )
1454 {
1455     return SMPI_VARGET_GLOBAL(interCommName);
1456 }
1457
1458 /* Get a communicator of a given minimum size.  Both intra and inter
1459    communicators are provided */
1460 int MTestGetComm( MPI_Comm *comm, int min_size )
1461 {
1462     int idx=0;
1463     SMPI_VARINIT_STATIC_AND_SET(getinter, int, 0);
1464
1465     if (!SMPI_VARGET_STATIC(getinter)) {
1466         idx = MTestGetIntracomm( comm, min_size );
1467         if (idx == 0) {
1468             SMPI_VARGET_STATIC(getinter) = 1;
1469         }
1470     }
1471     if (SMPI_VARGET_STATIC(getinter)) {
1472         int isLeft;
1473         idx = MTestGetIntercomm( comm, &isLeft, min_size );
1474         if (idx == 0) {
1475             SMPI_VARGET_STATIC(getinter) = 0;
1476         }
1477     }
1478
1479     return idx;
1480 }
1481
1482 /* Free a communicator.  It may be called with a predefined communicator
1483  or MPI_COMM_NULL */
1484 void MTestFreeComm( MPI_Comm *comm )
1485 {
1486     int merr;
1487     if (*comm != MPI_COMM_WORLD &&
1488         *comm != MPI_COMM_SELF &&
1489         *comm != MPI_COMM_NULL) {
1490         merr = MPI_Comm_free( comm );
1491         if (merr) MTestPrintError( merr );
1492     }
1493 }
1494
1495 /* ------------------------------------------------------------------------ */
1496 void MTestPrintError( int errcode )
1497 {
1498     int errclass, slen;
1499     char string[MPI_MAX_ERROR_STRING];
1500
1501     MPI_Error_class( errcode, &errclass );
1502     MPI_Error_string( errcode, string, &slen );
1503     printf( "Error class %d (%s)\n", errclass, string );
1504     fflush( stdout );
1505 }
1506 void MTestPrintErrorMsg( const char msg[], int errcode )
1507 {
1508     int errclass, slen;
1509     char string[MPI_MAX_ERROR_STRING];
1510
1511     MPI_Error_class( errcode, &errclass );
1512     MPI_Error_string( errcode, string, &slen );
1513     printf( "%s: Error class %d (%s)\n", msg, errclass, string );
1514     fflush( stdout );
1515 }
1516 /* ------------------------------------------------------------------------ */
1517 /*
1518  If verbose output is selected and the level is at least that of the
1519  value of the verbose flag, then perform printf( format, ... );
1520  */
1521 void MTestPrintfMsg( int level, const char format[], ... )
1522 {
1523     va_list list;
1524
1525     if (SMPI_VARGET_GLOBAL(verbose) && level >= SMPI_VARGET_GLOBAL(verbose)) {
1526         va_start(list,format);
1527         vprintf( format, list );
1528         va_end(list);
1529         fflush(stdout);
1530     }
1531 }
1532 /* Fatal error.  Report and exit */
1533 void MTestError( const char *msg )
1534 {
1535     fprintf( stderr, "%s\n", msg );
1536     fflush( stderr );
1537     MPI_Abort( MPI_COMM_WORLD, 1 );
1538     exit(1);
1539 }
1540 /* ------------------------------------------------------------------------ */
1541 static void MTestResourceSummary( FILE *fp )
1542 {
1543 #ifdef HAVE_GETRUSAGE
1544     struct rusage ru;
1545     SMPI_VARINIT_STATIC_AND_SET(pfThreshold, int, -2);
1546     int doOutput = 1;
1547     if (getrusage( RUSAGE_SELF, &ru ) == 0) {
1548         /* There is an option to generate output only when a resource
1549            exceeds a threshold.  To date, only page faults supported. */
1550         if (SMPI_VARGET_STATIC(pfThreshold) == -2) {
1551             char *p = getenv("MPITEST_RUSAGE_PF");
1552             SMPI_VARGET_STATIC(pfThreshold) = -1;
1553             if (p) {
1554                 SMPI_VARGET_STATIC(pfThreshold) = strtol( p, 0, 0 );
1555             }
1556         }
1557         if (SMPI_VARGET_STATIC(pfThreshold) > 0) {
1558             doOutput = ru.ru_minflt > SMPI_VARGET_STATIC(pfThreshold);
1559         }
1560         if (doOutput) {
1561             /* Cast values to long in case some system has defined them
1562                as another integer type */
1563             fprintf( fp, "RUSAGE: max resident set = %ldKB\n",
1564                      (long)ru.ru_maxrss );
1565             fprintf( fp, "RUSAGE: page faults = %ld : %ld\n",
1566                      (long)ru.ru_minflt, (long)ru.ru_majflt );
1567             /* Not every Unix provides useful information for the xxrss fields */
1568             fprintf( fp, "RUSAGE: memory in text/data/stack = %ld : %ld : %ld\n",
1569                      (long)ru.ru_ixrss, (long)ru.ru_idrss, (long)ru.ru_isrss );
1570             fprintf( fp, "RUSAGE: I/O in and out = %ld : %ld\n",
1571                      (long)ru.ru_inblock, (long)ru.ru_oublock );
1572             fprintf( fp, "RUSAGE: context switch = %ld : %ld\n",
1573                      (long)ru.ru_nvcsw, (long)ru.ru_nivcsw );
1574         }
1575     }
1576     else {
1577         fprintf( fp, "RUSAGE: return error %d\n", errno );
1578     }
1579 #endif
1580 }
1581 /* ------------------------------------------------------------------------ */
1582 #ifdef HAVE_MPI_WIN_CREATE
1583 /*
1584  * Create MPI Windows
1585  */
1586 SMPI_VARINIT_GLOBAL_AND_SET(win_index, int, 0);
1587 SMPI_VARINIT_GLOBAL(winName, const char *);
1588 /* Use an attribute to remember the type of memory allocation (static,
1589    malloc, or MPI_Alloc_mem) */
1590 SMPI_VARINIT_GLOBAL_AND_SET(mem_keyval, int, MPI_KEYVAL_INVALID);
1591 int MTestGetWin( MPI_Win *win, int mustBePassive )
1592 {
1593     typedef char actbuf_type[1024];
1594     SMPI_VARINIT_STATIC(actbuf, actbuf_type);
1595     SMPI_VARINIT_STATIC(pasbuf, char *);
1596     char        *buf;
1597     int         n, rank, merr;
1598     MPI_Info    info;
1599
1600     if (SMPI_VARGET_GLOBAL(mem_keyval) == MPI_KEYVAL_INVALID) {
1601         /* Create the keyval */
1602         merr = MPI_Win_create_keyval( MPI_WIN_NULL_COPY_FN,
1603                                       MPI_WIN_NULL_DELETE_FN,
1604                                       &SMPI_VARGET_GLOBAL(mem_keyval), 0 );
1605         if (merr) MTestPrintError( merr );
1606
1607     }
1608
1609     switch (SMPI_VARGET_GLOBAL(win_index)) {
1610     case 0:
1611         /* Active target window */
1612         merr = MPI_Win_create( SMPI_VARGET_STATIC(actbuf), 1024, 1, MPI_INFO_NULL, MPI_COMM_WORLD,
1613                                win );
1614         if (merr) MTestPrintError( merr );
1615         SMPI_VARGET_GLOBAL(winName) = "active-window";
1616         merr = MPI_Win_set_attr( *win, SMPI_VARGET_GLOBAL(mem_keyval), (void *)0 );
1617         if (merr) MTestPrintError( merr );
1618         break;
1619     case 1:
1620         /* Passive target window */
1621         merr = MPI_Alloc_mem( 1024, MPI_INFO_NULL, &SMPI_VARGET_STATIC(pasbuf) );
1622         if (merr) MTestPrintError( merr );
1623         merr = MPI_Win_create( SMPI_VARGET_STATIC(pasbuf), 1024, 1, MPI_INFO_NULL, MPI_COMM_WORLD,
1624                                win );
1625         if (merr) MTestPrintError( merr );
1626         SMPI_VARGET_GLOBAL(winName) = "passive-window";
1627         merr = MPI_Win_set_attr( *win, SMPI_VARGET_GLOBAL(mem_keyval), (void *)2 );
1628         if (merr) MTestPrintError( merr );
1629         break;
1630     case 2:
1631         /* Active target; all windows different sizes */
1632         merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1633         if (merr) MTestPrintError( merr );
1634         n = rank * 64;
1635         if (n)
1636             buf = (char *)malloc( n );
1637         else
1638             buf = 0;
1639         merr = MPI_Win_create( buf, n, 1, MPI_INFO_NULL, MPI_COMM_WORLD,
1640                                win );
1641         if (merr) MTestPrintError( merr );
1642         SMPI_VARGET_GLOBAL(winName) = "active-all-different-win";
1643         merr = MPI_Win_set_attr( *win, SMPI_VARGET_GLOBAL(mem_keyval), (void *)1 );
1644         if (merr) MTestPrintError( merr );
1645         break;
1646     case 3:
1647         /* Active target, no locks set */
1648         merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1649         if (merr) MTestPrintError( merr );
1650         n = rank * 64;
1651         if (n)
1652             buf = (char *)malloc( n );
1653         else
1654             buf = 0;
1655         merr = MPI_Info_create( &info );
1656         if (merr) MTestPrintError( merr );
1657         merr = MPI_Info_set( info, (char*)"nolocks", (char*)"true" );
1658         if (merr) MTestPrintError( merr );
1659         merr = MPI_Win_create( buf, n, 1, info, MPI_COMM_WORLD, win );
1660         if (merr) MTestPrintError( merr );
1661         merr = MPI_Info_free( &info );
1662         if (merr) MTestPrintError( merr );
1663         SMPI_VARGET_GLOBAL(winName) = "active-nolocks-all-different-win";
1664         merr = MPI_Win_set_attr( *win, SMPI_VARGET_GLOBAL(mem_keyval), (void *)1 );
1665         if (merr) MTestPrintError( merr );
1666         break;
1667     default:
1668         SMPI_VARGET_GLOBAL(win_index) = -1;
1669     }
1670     SMPI_VARGET_GLOBAL(win_index)++;
1671     return SMPI_VARGET_GLOBAL(win_index);
1672 }
1673 /* Return a pointer to the name associated with a window object */
1674 const char *MTestGetWinName( void )
1675 {
1676     return SMPI_VARGET_GLOBAL(winName);
1677 }
1678 /* Free the storage associated with a window object */
1679 void MTestFreeWin( MPI_Win *win )
1680 {
1681     void *addr;
1682     int  flag, merr;
1683
1684     merr = MPI_Win_get_attr( *win, MPI_WIN_BASE, &addr, &flag );
1685     if (merr) MTestPrintError( merr );
1686     if (!flag) {
1687         MTestError( "Could not get WIN_BASE from window" );
1688     }
1689     if (addr) {
1690         void *val;
1691         merr = MPI_Win_get_attr( *win, SMPI_VARGET_GLOBAL(mem_keyval), &val, &flag );
1692         if (merr) MTestPrintError( merr );
1693         if (flag) {
1694             if (val == (void *)1) {
1695                 free( addr );
1696             }
1697             else if (val == (void *)2) {
1698                 merr = MPI_Free_mem( addr );
1699                 if (merr) MTestPrintError( merr );
1700             }
1701             /* if val == (void *)0, then static data that must not be freed */
1702         }
1703     }
1704     merr = MPI_Win_free(win);
1705     if (merr) MTestPrintError( merr );
1706 }
1707 static void MTestRMACleanup( void )
1708 {
1709     if (SMPI_VARGET_GLOBAL(mem_keyval) != MPI_KEYVAL_INVALID) {
1710         MPI_Win_free_keyval( &SMPI_VARGET_GLOBAL(mem_keyval) );
1711     }
1712 }
1713 #else
1714 static void MTestRMACleanup( void ) {}
1715 #endif