1 /* -*- Mode: C; c-basic-offset:4 ; indent-tabs-mode:nil ; -*- */
4 * (C) 2001 by Argonne National Laboratory.
5 * See COPYRIGHT in top-level directory.
8 #include "mpitestconf.h"
10 #if defined(HAVE_STDIO_H) || defined(STDC_HEADERS)
13 #if defined(HAVE_STDLIB_H) || defined(STDC_HEADERS)
16 #if defined(HAVE_STRING_H) || defined(STDC_HEADERS)
22 /* The following two includes permit the collection of resource usage
25 #ifdef HAVE_SYS_TIME_H
28 #ifdef HAVE_SYS_RESOURCE_H
29 #include <sys/resource.h>
35 * Utility routines for writing MPI tests.
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
45 static void MTestRMACleanup( void );
46 static void MTestResourceSummary( FILE * );
48 /* Here is where we could put the includes and definitions to enable
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); /* */
59 /* Provide backward portability to MPI 1 */
64 #define MPI_THREAD_SINGLE 0
68 * Initialize and Finalize MTest
72 Initialize MTest, initializing MPI if necessary.
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'
83 void MTest_Init_thread( int *argc, char ***argv, int required, int *provided )
88 MPI_Initialized( &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 );
95 MPI_Init( argc, argv );
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) );
105 /* Check for verbose control */
106 envval = getenv( "MPITEST_VERBOSE" );
109 long val = strtol( envval, &s, 0 );
111 /* This is the error case for strtol */
112 fprintf( stderr, "Warning: %s not valid for MPITEST_VERBOSE\n",
118 SMPI_VARGET_GLOBAL(verbose) = val;
121 fprintf( stderr, "Warning: %s not valid for MPITEST_VERBOSE\n",
127 /* Check for option to return success/failure in the return value of main */
128 envval = getenv( "MPITEST_RETURN_WITH_CODE" );
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;
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;
144 "Warning: %s not valid for MPITEST_RETURN_WITH_CODE\n",
150 /* Print rusage data if set */
151 if (getenv( "MPITEST_RUSAGE" )) {
152 SMPI_VARGET_GLOBAL(usageOutput) = 1;
156 * Initialize the tests, using an MPI-1 style init. Supports
157 * MTEST_THREADLEVEL_DEFAULT to test with user-specified thread level
159 void MTest_Init( int *argc, char ***argv )
162 #if MPI_VERSION >= 2 || defined(HAVE_MPI_INIT_THREAD)
166 threadLevel = MPI_THREAD_SINGLE;
167 str = getenv( "MTEST_THREADLEVEL_DEFAULT" );
168 if (!str) str = getenv( "MPITEST_THREADLEVEL_DEFAULT" );
170 if (strcmp(str,"MULTIPLE") == 0 || strcmp(str,"multiple") == 0) {
171 threadLevel = MPI_THREAD_MULTIPLE;
173 else if (strcmp(str,"SERIALIZED") == 0 ||
174 strcmp(str,"serialized") == 0) {
175 threadLevel = MPI_THREAD_SERIALIZED;
177 else if (strcmp(str,"FUNNELED") == 0 || strcmp(str,"funneled") == 0) {
178 threadLevel = MPI_THREAD_FUNNELED;
180 else if (strcmp(str,"SINGLE") == 0 || strcmp(str,"single") == 0) {
181 threadLevel = MPI_THREAD_SINGLE;
184 fprintf( stderr, "Unrecognized thread level %s\n", str );
185 /* Use exit since MPI_Init/Init_thread has not been called. */
189 MTest_Init_thread( argc, argv, threadLevel, &provided );
191 /* If the MPI_VERSION is 1, there is no MPI_THREAD_xxx defined */
192 MTest_Init_thread( argc, argv, 0, &provided );
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.
202 void MTest_Finalize( int errs )
204 int rank, toterrs, merr;
206 merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
207 if (merr) MTestPrintError( merr );
209 merr = MPI_Reduce( &errs, &toterrs, 1, MPI_INT, MPI_SUM,
211 if (merr) MTestPrintError( merr );
214 printf( " Found %d errors\n", toterrs );
217 printf( " No Errors\n" );
222 if (SMPI_VARGET_GLOBAL(usageOutput))
223 MTestResourceSummary( stdout );
226 /* Clean up any persistent objects that we allocated */
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.
233 int MTestReturnValue( int errors )
235 if (SMPI_VARGET_GLOBAL(returnWithVal)) return errors ? 1 : 0;
238 /* ------------------------------------------------------------------------ */
241 * Miscellaneous utilities, particularly to eliminate OS dependencies
243 * MTestSleep( seconds )
245 #ifdef HAVE_WINDOWS_H
247 void MTestSleep( int sec )
253 void MTestSleep( int sec )
262 * Eventually, this could read a description of a file. For now, we hard
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.
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
280 SMPI_VARINIT_GLOBAL_AND_SET(datatype_index, int, 0);
282 /* ------------------------------------------------------------------------ */
283 /* Datatype routines for contiguous datatypes */
284 /* ------------------------------------------------------------------------ */
286 * Setup contiguous buffers of n copies of a datatype.
288 static void *MTestTypeContigInit( MTestDatatype *mtype )
293 if (mtype->count > 0) {
296 merr = MPI_Type_extent( mtype->datatype, &size );
297 if (merr) MTestPrintError( merr );
298 totsize = size * mtype->count;
300 mtype->buf = (void *) malloc( totsize );
302 p = (signed char *)(mtype->buf);
304 /* Error - out of memory */
305 MTestError( "Out of memory in type buffer init" );
307 for (i=0; i<totsize; i++) {
308 p[i] = 0xff ^ (i & 0xff);
321 * Setup contiguous buffers of n copies of a datatype. Initialize for
322 * reception (e.g., set initial data to detect failure)
324 static void *MTestTypeContigInitRecv( MTestDatatype *mtype )
329 if (mtype->count > 0) {
332 merr = MPI_Type_extent( mtype->datatype, &size );
333 if (merr) MTestPrintError( merr );
334 totsize = size * mtype->count;
336 mtype->buf = (void *) malloc( totsize );
338 p = (signed char *)(mtype->buf);
340 /* Error - out of memory */
341 MTestError( "Out of memory in type buffer init" );
343 for (i=0; i<totsize; i++) {
355 static void *MTestTypeContigFree( MTestDatatype *mtype )
363 static int MTestTypeContigCheckbuf( MTestDatatype *mtype )
366 unsigned char expected;
367 int i, totsize, err = 0, merr;
370 p = (unsigned char *)mtype->buf;
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) {
379 if (mtype->printErrors && err < 10) {
380 printf( "Data expected = %x but got p[%d] = %x\n",
390 /* ------------------------------------------------------------------------ */
391 /* Datatype routines for vector datatypes */
392 /* ------------------------------------------------------------------------ */
394 static void *MTestTypeVectorInit( MTestDatatype *mtype )
399 if (mtype->count > 0) {
401 int i, j, k, nc, totsize;
403 merr = MPI_Type_extent( mtype->datatype, &size );
404 if (merr) MTestPrintError( merr );
405 totsize = mtype->count * size;
407 mtype->buf = (void *) malloc( totsize );
409 p = (unsigned char *)(mtype->buf);
411 /* Error - out of memory */
412 MTestError( "Out of memory in type buffer init" );
415 /* First, set to -1 */
416 for (i=0; i<totsize; i++) p[i] = 0xff;
418 /* Now, set the actual elements to the successive values.
419 To do this, we need to run 3 loops */
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++) {
426 for (j=0; j<mtype->blksize; j++) {
427 p[j] = (0xff ^ (nc & 0xff));
440 static void *MTestTypeVectorFree( MTestDatatype *mtype )
449 /* ------------------------------------------------------------------------ */
450 /* Datatype routines for indexed block datatypes */
451 /* ------------------------------------------------------------------------ */
454 * Setup a buffer for one copy of an indexed datatype.
456 static void *MTestTypeIndexedInit( MTestDatatype *mtype )
461 if (mtype->count > 1) {
462 MTestError( "This datatype is supported only for a single count" );
464 if (mtype->count == 1) {
468 /* Allocate the send/recv buffer */
469 merr = MPI_Type_extent( mtype->datatype, &totsize );
470 if (merr) MTestPrintError( merr );
472 mtype->buf = (void *) malloc( totsize );
474 p = (signed char *)(mtype->buf);
476 MTestError( "Out of memory in type buffer init\n" );
478 /* Initialize the elements */
479 /* First, set to -1 */
480 for (i=0; i<totsize; i++) p[i] = 0xff;
482 /* Now, set the actual elements to the successive values.
483 We require that the base type is a contiguous type */
485 for (i=0; i<mtype->nelm; i++) {
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);
494 offset += mtype->basesize;
509 * Setup indexed buffers for 1 copy of a datatype. Initialize for
510 * reception (e.g., set initial data to detect failure)
512 static void *MTestTypeIndexedInitRecv( MTestDatatype *mtype )
517 if (mtype->count > 1) {
518 MTestError( "This datatype is supported only for a single count" );
520 if (mtype->count == 1) {
523 merr = MPI_Type_extent( mtype->datatype, &totsize );
524 if (merr) MTestPrintError( merr );
526 mtype->buf = (void *) malloc( totsize );
528 p = (signed char *)(mtype->buf);
530 /* Error - out of memory */
531 MTestError( "Out of memory in type buffer init\n" );
533 for (i=0; i<totsize; i++) {
547 static void *MTestTypeIndexedFree( MTestDatatype *mtype )
551 free( mtype->displs );
552 free( mtype->index );
560 static int MTestTypeIndexedCheckbuf( MTestDatatype *mtype )
563 unsigned char expected;
564 int i, err = 0, merr;
567 p = (unsigned char *)mtype->buf;
570 merr = MPI_Type_extent( mtype->datatype, &totsize );
571 if (merr) MTestPrintError( merr );
574 for (i=0; i<mtype->nelm; i++) {
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) {
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] );
591 offset += mtype->basesize;
599 /* ------------------------------------------------------------------------ */
600 /* Routines to select a datatype and associated buffer create/fill/check */
602 /* ------------------------------------------------------------------------ */
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
611 int MTestGetDatatypes( MTestDatatype *sendtype, MTestDatatype *recvtype,
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;
626 recvtype->CheckBuf = 0;
627 recvtype->datatype = 0;
628 recvtype->isBasic = 0;
629 recvtype->printErrors = 0;
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
639 switch (SMPI_VARGET_GLOBAL(datatype_index)) {
641 sendtype->datatype = MPI_INT;
642 sendtype->isBasic = 1;
643 recvtype->datatype = MPI_INT;
644 recvtype->isBasic = 1;
647 sendtype->datatype = MPI_DOUBLE;
648 sendtype->isBasic = 1;
649 recvtype->datatype = MPI_DOUBLE;
650 recvtype->isBasic = 1;
653 sendtype->datatype = MPI_FLOAT_INT;
654 sendtype->isBasic = 1;
655 recvtype->datatype = MPI_FLOAT_INT;
656 recvtype->isBasic = 1;
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) */
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;
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 );
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;
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" );
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
712 for (i=0; i<sendtype->nelm; i++) {
713 sendtype->index[i] = 4;
714 sendtype->displs[i] = 5*i;
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 );
726 sendtype->InitBuf = MTestTypeIndexedInit;
727 sendtype->FreeBuf = MTestTypeIndexedFree;
728 sendtype->CheckBuf = 0;
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;
739 /* Indexed send using 2 large blocks and contig receive */
740 sendtype->blksize = sizeof(int);
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" );
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 */
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 );
765 sendtype->InitBuf = MTestTypeIndexedInit;
766 sendtype->FreeBuf = MTestTypeIndexedFree;
767 sendtype->CheckBuf = 0;
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;
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" );
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
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;
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 );
806 recvtype->InitBuf = MTestTypeIndexedInitRecv;
807 recvtype->FreeBuf = MTestTypeIndexedFree;
808 recvtype->CheckBuf = MTestTypeIndexedCheckbuf;
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;
818 /* Less commonly used but still simple types */
820 sendtype->datatype = MPI_SHORT;
821 sendtype->isBasic = 1;
822 recvtype->datatype = MPI_SHORT;
823 recvtype->isBasic = 1;
826 sendtype->datatype = MPI_LONG;
827 sendtype->isBasic = 1;
828 recvtype->datatype = MPI_LONG;
829 recvtype->isBasic = 1;
832 sendtype->datatype = MPI_CHAR;
833 sendtype->isBasic = 1;
834 recvtype->datatype = MPI_CHAR;
835 recvtype->isBasic = 1;
838 sendtype->datatype = MPI_UINT64_T;
839 sendtype->isBasic = 1;
840 recvtype->datatype = MPI_UINT64_T;
841 recvtype->isBasic = 1;
844 sendtype->datatype = MPI_FLOAT;
845 sendtype->isBasic = 1;
846 recvtype->datatype = MPI_FLOAT;
847 recvtype->isBasic = 1;
850 #ifndef USE_STRICT_MPI
851 /* MPI_BYTE may only be used with MPI_BYTE in strict MPI */
853 sendtype->datatype = MPI_INT;
854 sendtype->isBasic = 1;
855 recvtype->datatype = MPI_BYTE;
856 recvtype->isBasic = 1;
857 recvtype->count *= sizeof(int);
861 SMPI_VARGET_GLOBAL(datatype_index) = -1;
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;
872 SMPI_VARGET_GLOBAL(datatype_index)++;
874 if (SMPI_VARGET_GLOBAL(dbgflag) && SMPI_VARGET_GLOBAL(datatype_index) > 0) {
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 );
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 ) );
894 return SMPI_VARGET_GLOBAL(datatype_index);
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.
901 void MTestResetDatatypes( void )
903 SMPI_VARGET_GLOBAL(datatype_index) = 0;
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 )
909 return SMPI_VARGET_GLOBAL(datatype_index);
912 /* Free the storage associated with a datatype */
913 void MTestFreeDatatype( MTestDatatype *mtype )
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 );
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 );
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 )
935 if (status && status != MPI_STATUS_IGNORE) {
936 merr = MPI_Get_count( status, recvtype->datatype, &count );
937 if (merr) MTestPrintError( merr );
939 /* Check count against expected count */
940 if (count != recvtype->count) {
945 /* Check received data */
946 if (!errs && recvtype->CheckBuf( recvtype )) {
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 )
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);
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)++];
966 /* ----------------------------------------------------------------------- */
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.
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);
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.
986 int MTestGetIntracommGeneral( MPI_Comm *comm, int min_size, int allowSmaller )
988 int size, rank, merr;
992 /* The while loop allows us to skip communicators that are too small.
993 MPI_COMM_NULL is always considered large enough */
996 SMPI_VARGET_GLOBAL(intraCommName) = "";
997 switch (SMPI_VARGET_GLOBAL(intraCommIdx)) {
999 *comm = MPI_COMM_WORLD;
1001 SMPI_VARGET_GLOBAL(intraCommName) = "MPI_COMM_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";
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";
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),
1027 if (merr) MTestPrintError( merr );
1028 SMPI_VARGET_GLOBAL(intraCommName) = "Rank reverse of half of MPI_COMM_WORLD";
1031 *comm = MPI_COMM_SELF;
1033 SMPI_VARGET_GLOBAL(intraCommName) = "MPI_COMM_SELF";
1036 /* These next cases are communicators that include some
1037 but not all of the processes */
1044 merr = MPI_Comm_size( MPI_COMM_WORLD, &size );
1045 if (merr) MTestPrintError( merr );
1046 newsize = size - (SMPI_VARGET_GLOBAL(intraCommIdx) - 4);
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,
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;
1060 SMPI_VARGET_GLOBAL(intraCommName) = "Split of WORLD";
1064 /* Act like default */
1065 *comm = MPI_COMM_NULL;
1066 SMPI_VARGET_GLOBAL(intraCommIdx) = -1;
1071 /* Other ideas: dup of self, cart comm, graph comm */
1073 *comm = MPI_COMM_NULL;
1074 SMPI_VARGET_GLOBAL(intraCommIdx) = -1;
1078 if (*comm != MPI_COMM_NULL) {
1079 merr = MPI_Comm_size( *comm, &size );
1080 if (merr) MTestPrintError( merr );
1081 if (size >= min_size)
1085 SMPI_VARGET_GLOBAL(intraCommName) = "MPI_COMM_NULL";
1090 /* we are only done if all processes are done */
1091 MPI_Allreduce(&done2, &done, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD);
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
1096 SMPI_VARGET_GLOBAL(intraCommIdx)++;
1098 if (!done && !isBasic && *comm != MPI_COMM_NULL) {
1099 /* avoid leaking communicators */
1100 merr = MPI_Comm_free(comm);
1101 if (merr) MTestPrintError(merr);
1105 return SMPI_VARGET_GLOBAL(intraCommIdx);
1109 * Get an intracommunicator with at least min_size members.
1111 int MTestGetIntracomm( MPI_Comm *comm, int min_size )
1113 return MTestGetIntracommGeneral( comm, min_size, 0 );
1116 /* Return the name of an intra communicator */
1117 const char *MTestGetIntracommName( void )
1119 return SMPI_VARGET_GLOBAL(intraCommName);
1123 * Return an intercomm; set isLeftGroup to 1 if the calling process is
1124 * a member of the "left" group.
1126 int MTestGetIntercomm( MPI_Comm *comm, int *isLeftGroup, int min_size )
1128 int size, rank, remsize, merr;
1130 MPI_Comm mcomm = MPI_COMM_NULL;
1131 MPI_Comm mcomm2 = MPI_COMM_NULL;
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 */
1138 *comm = MPI_COMM_NULL;
1140 SMPI_VARGET_GLOBAL(interCommName) = "MPI_COMM_NULL";
1142 switch (SMPI_VARGET_GLOBAL(interCommIdx)) {
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 );
1150 merr = MPI_Comm_split( MPI_COMM_WORLD, (rank < size/2), rank,
1152 if (merr) MTestPrintError( merr );
1156 else if (rank == size/2) {
1160 /* Remote leader is signficant only for the processes
1161 designated local leaders */
1164 *isLeftGroup = rank < size/2;
1165 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader,
1167 if (merr) MTestPrintError( merr );
1168 SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD";
1171 *comm = MPI_COMM_NULL;
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 );
1180 merr = MPI_Comm_split( MPI_COMM_WORLD, rank == 0, rank,
1182 if (merr) MTestPrintError( merr );
1186 else if (rank == 1) {
1190 /* Remote leader is signficant only for the processes
1191 designated local leaders */
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";
1201 *comm = MPI_COMM_NULL;
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 );
1211 merr = MPI_Comm_split( MPI_COMM_WORLD, rank < 2, rank,
1213 if (merr) MTestPrintError( merr );
1217 else if (rank == 2) {
1221 /* Remote leader is signficant only for the processes
1222 designated local leaders */
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";
1232 *comm = MPI_COMM_NULL;
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 );
1242 merr = MPI_Comm_split( MPI_COMM_WORLD, (rank < size/2), rank,
1244 if (merr) MTestPrintError( merr );
1248 else if (rank == size/2) {
1252 /* Remote leader is signficant only for the processes
1253 designated local leaders */
1256 *isLeftGroup = rank < size/2;
1257 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader,
1259 if (merr) MTestPrintError( merr );
1260 /* avoid leaking after assignment below */
1261 merr = MPI_Comm_free( &mcomm );
1262 if (merr) MTestPrintError( merr );
1264 /* now dup, some bugs only occur for dup's of intercomms */
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";
1271 *comm = MPI_COMM_NULL;
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 );
1281 merr = MPI_Comm_split( MPI_COMM_WORLD, (rank < size/2), rank,
1283 if (merr) MTestPrintError( merr );
1287 else if (rank == size/2) {
1291 /* Remote leader is signficant only for the processes
1292 designated local leaders */
1295 *isLeftGroup = rank < size/2;
1296 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader,
1298 if (merr) MTestPrintError( merr );
1299 /* avoid leaking after assignment below */
1300 merr = MPI_Comm_free( &mcomm );
1301 if (merr) MTestPrintError( merr );
1303 /* now split, some bugs only occur for splits of intercomms */
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";
1313 *comm = MPI_COMM_NULL;
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 );
1324 int color = (rank < size/2 ? 0 : 1);
1326 color = MPI_UNDEFINED;
1328 merr = MPI_Comm_split( MPI_COMM_WORLD, color, rank, &mcomm );
1329 if (merr) MTestPrintError( merr );
1334 else if (rank == (size/2)) {
1338 /* Remote leader is signficant only for the processes
1339 designated local leaders */
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 );
1347 SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD (discarding rank 0 in the left group) then MPI_Intercomm_create'ing";
1350 *comm = MPI_COMM_NULL;
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 );
1363 MPI_Group oldgroup, newgroup;
1365 int color = (rank < size/2 ? 0 : 1);
1367 merr = MPI_Comm_split( MPI_COMM_WORLD, color, rank, &mcomm );
1368 if (merr) MTestPrintError( merr );
1373 else if (rank == (size/2)) {
1377 /* Remote leader is signficant only for the processes
1378 designated local leaders */
1381 *isLeftGroup = rank < size/2;
1382 merr = MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader, 12345, &mcomm2 );
1383 if (merr) MTestPrintError( merr );
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 );
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 );
1395 merr = MPI_Group_free(&oldgroup);
1396 if (merr) MTestPrintError( merr );
1397 merr = MPI_Group_free(&newgroup);
1398 if (merr) MTestPrintError( merr );
1400 SMPI_VARGET_GLOBAL(interCommName) = "Intercomm by splitting MPI_COMM_WORLD then discarding 0 ranks with MPI_Comm_create";
1403 *comm = MPI_COMM_NULL;
1408 *comm = MPI_COMM_NULL;
1409 SMPI_VARGET_GLOBAL(interCommIdx) = -1;
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;
1421 SMPI_VARGET_GLOBAL(interCommName) = "MPI_COMM_NULL";
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);
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
1431 SMPI_VARGET_GLOBAL(interCommIdx)++;
1433 if (!done && *comm != MPI_COMM_NULL) {
1434 /* avoid leaking communicators */
1435 merr = MPI_Comm_free(comm);
1436 if (merr) MTestPrintError(merr);
1439 /* cleanup for common temp objects */
1440 if (mcomm != MPI_COMM_NULL) {
1441 merr = MPI_Comm_free(&mcomm);
1442 if (merr) MTestPrintError( merr );
1444 if (mcomm2 != MPI_COMM_NULL) {
1445 merr = MPI_Comm_free(&mcomm2);
1446 if (merr) MTestPrintError( merr );
1450 return SMPI_VARGET_GLOBAL(interCommIdx);
1452 /* Return the name of an intercommunicator */
1453 const char *MTestGetIntercommName( void )
1455 return SMPI_VARGET_GLOBAL(interCommName);
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 )
1463 SMPI_VARINIT_STATIC_AND_SET(getinter, int, 0);
1465 if (!SMPI_VARGET_STATIC(getinter)) {
1466 idx = MTestGetIntracomm( comm, min_size );
1468 SMPI_VARGET_STATIC(getinter) = 1;
1471 if (SMPI_VARGET_STATIC(getinter)) {
1473 idx = MTestGetIntercomm( comm, &isLeft, min_size );
1475 SMPI_VARGET_STATIC(getinter) = 0;
1482 /* Free a communicator. It may be called with a predefined communicator
1484 void MTestFreeComm( MPI_Comm *comm )
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 );
1495 /* ------------------------------------------------------------------------ */
1496 void MTestPrintError( int errcode )
1499 char string[MPI_MAX_ERROR_STRING];
1501 MPI_Error_class( errcode, &errclass );
1502 MPI_Error_string( errcode, string, &slen );
1503 printf( "Error class %d (%s)\n", errclass, string );
1506 void MTestPrintErrorMsg( const char msg[], int errcode )
1509 char string[MPI_MAX_ERROR_STRING];
1511 MPI_Error_class( errcode, &errclass );
1512 MPI_Error_string( errcode, string, &slen );
1513 printf( "%s: Error class %d (%s)\n", msg, errclass, string );
1516 /* ------------------------------------------------------------------------ */
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, ... );
1521 void MTestPrintfMsg( int level, const char format[], ... )
1525 if (SMPI_VARGET_GLOBAL(verbose) && level >= SMPI_VARGET_GLOBAL(verbose)) {
1526 va_start(list,format);
1527 vprintf( format, list );
1532 /* Fatal error. Report and exit */
1533 void MTestError( const char *msg )
1535 fprintf( stderr, "%s\n", msg );
1537 MPI_Abort( MPI_COMM_WORLD, 1 );
1540 /* ------------------------------------------------------------------------ */
1541 static void MTestResourceSummary( FILE *fp )
1543 #ifdef HAVE_GETRUSAGE
1545 SMPI_VARINIT_STATIC_AND_SET(pfThreshold, int, -2);
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;
1554 SMPI_VARGET_STATIC(pfThreshold) = strtol( p, 0, 0 );
1557 if (SMPI_VARGET_STATIC(pfThreshold) > 0) {
1558 doOutput = ru.ru_minflt > SMPI_VARGET_STATIC(pfThreshold);
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 );
1577 fprintf( fp, "RUSAGE: return error %d\n", errno );
1581 /* ------------------------------------------------------------------------ */
1582 #ifdef HAVE_MPI_WIN_CREATE
1584 * Create MPI Windows
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 )
1593 typedef char actbuf_type[1024];
1594 SMPI_VARINIT_STATIC(actbuf, actbuf_type);
1595 SMPI_VARINIT_STATIC(pasbuf, char *);
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 );
1609 switch (SMPI_VARGET_GLOBAL(win_index)) {
1611 /* Active target window */
1612 merr = MPI_Win_create( SMPI_VARGET_STATIC(actbuf), 1024, 1, MPI_INFO_NULL, MPI_COMM_WORLD,
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 );
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,
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 );
1631 /* Active target; all windows different sizes */
1632 merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1633 if (merr) MTestPrintError( merr );
1636 buf = (char *)malloc( n );
1639 merr = MPI_Win_create( buf, n, 1, MPI_INFO_NULL, MPI_COMM_WORLD,
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 );
1647 /* Active target, no locks set */
1648 merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
1649 if (merr) MTestPrintError( merr );
1652 buf = (char *)malloc( n );
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 );
1668 SMPI_VARGET_GLOBAL(win_index) = -1;
1670 SMPI_VARGET_GLOBAL(win_index)++;
1671 return SMPI_VARGET_GLOBAL(win_index);
1673 /* Return a pointer to the name associated with a window object */
1674 const char *MTestGetWinName( void )
1676 return SMPI_VARGET_GLOBAL(winName);
1678 /* Free the storage associated with a window object */
1679 void MTestFreeWin( MPI_Win *win )
1684 merr = MPI_Win_get_attr( *win, MPI_WIN_BASE, &addr, &flag );
1685 if (merr) MTestPrintError( merr );
1687 MTestError( "Could not get WIN_BASE from window" );
1691 merr = MPI_Win_get_attr( *win, SMPI_VARGET_GLOBAL(mem_keyval), &val, &flag );
1692 if (merr) MTestPrintError( merr );
1694 if (val == (void *)1) {
1697 else if (val == (void *)2) {
1698 merr = MPI_Free_mem( addr );
1699 if (merr) MTestPrintError( merr );
1701 /* if val == (void *)0, then static data that must not be freed */
1704 merr = MPI_Win_free(win);
1705 if (merr) MTestPrintError( merr );
1707 static void MTestRMACleanup( void )
1709 if (SMPI_VARGET_GLOBAL(mem_keyval) != MPI_KEYVAL_INVALID) {
1710 MPI_Win_free_keyval( &SMPI_VARGET_GLOBAL(mem_keyval) );
1714 static void MTestRMACleanup( void ) {}