1 /* -*- Mode: C++; c-basic-offset:4 ; -*- */
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 #ifdef HAVE_IOSTREAM
10 // Not all C++ compilers have iostream instead of iostream.h
11 #include <iostream>
12 #ifdef HAVE_NAMESPACE_STD
13 // Those that do often need the std namespace; otherwise, a bare "cout"
14 // is likely to fail to compile
15 using namespace std;
16 #endif
17 #else
18 #include <iostream.h>
19 #endif
20 #include "mpitestcxx.h"
21 #include <stdlib.h>
22 #include <string.h>
23
24 static int dbgflag = 0; /* Flag used for debugging */
25 static int wrank = -1; /* World rank */
26 static int verbose = 0; /* Message level (0 is none) */
27
28 static void MTestRMACleanup( void );
29
30 /*
31 * Initialize and Finalize MTest
32 */
33
34 /*
35 Initialize MTest, initializing MPI if necessary.
36
37 Environment Variables:
38 + MPITEST_DEBUG - If set (to any value), turns on debugging output
39 - MPITEST_VERBOSE - If set to a numeric value, turns on that level of
40 verbose output.
41
42 */
MTest_Init(void)43 void MTest_Init( void )
44 {
45 bool flag;
46 const char *envval = 0;
47 int threadLevel, provided;
48
49 threadLevel = MPI::THREAD_SINGLE;
50 envval = getenv( "MTEST_THREADLEVEL_DEFAULT" );
51 if (envval && *envval) {
52 if (strcmp(envval,"MULTIPLE") == 0 || strcmp(envval,"multiple") == 0) {
53 threadLevel = MPI::THREAD_MULTIPLE;
54 }
55 else if (strcmp(envval,"SERIALIZED") == 0 ||
56 strcmp(envval,"serialized") == 0) {
57 threadLevel = MPI::THREAD_SERIALIZED;
58 }
59 else if (strcmp(envval,"FUNNELED") == 0 ||
60 strcmp(envval,"funneled") == 0) {
61 threadLevel = MPI::THREAD_FUNNELED;
62 }
63 else if (strcmp(envval,"SINGLE") == 0 || strcmp(envval,"single") == 0) {
64 threadLevel = MPI::THREAD_SINGLE;
65 }
66 else {
67 cerr << "Unrecognized thread level " << envval << "\n";
68 cerr.flush();
69 /* Use exit since MPI_Init/Init_thread has not been called. */
70 exit(1);
71 }
72 }
73
74 flag = MPI::Is_initialized( );
75 if (!flag) {
76 provided = MPI::Init_thread( threadLevel );
77 }
78
79 /* Check for debugging control */
80 if (getenv( "MPITEST_DEBUG" )) {
81 dbgflag = 1;
82 wrank = MPI::COMM_WORLD.Get_rank();
83 }
84
85 /* Check for verbose control */
86 envval = getenv( "MPITEST_VERBOSE" );
87 if (envval) {
88 char *s;
89 long val = strtol( envval, &s, 0 );
90 if (s == envval) {
91 /* This is the error case for strtol */
92 cerr << "Warning: "<< envval << " not valid for MPITEST_VERBOSE\n";
93 cerr.flush();
94 }
95 else {
96 if (val >= 0) {
97 verbose = val;
98 }
99 else {
100 cerr << "Warning: " << envval <<
101 " not valid for MPITEST_VERBOSE\n";
102 cerr.flush();
103 }
104 }
105 }
106 }
107
108 /*
109 Finalize MTest. errs is the number of errors on the calling process;
110 this routine will write the total number of errors over all of MPI_COMM_WORLD
111 to the process with rank zero, or " No Errors".
112 It does *not* finalize MPI.
113 */
MTest_Finalize(int errs)114 void MTest_Finalize( int errs )
115 {
116 int rank, toterrs;
117
118 rank = MPI::COMM_WORLD.Get_rank();
119
120 MPI::COMM_WORLD.Allreduce( &errs, &toterrs, 1, MPI::INT, MPI::SUM );
121 if (rank == 0) {
122 if (toterrs) {
123 cout << " Found " << toterrs << " errors\n";
124 }
125 else {
126 cout << " No Errors\n";
127 }
128 cout.flush();
129 }
130
131 // Clean up any persistent objects that we allocated
132 MTestRMACleanup();
133 }
134
135 /*
136 * Datatypes
137 *
138 * Eventually, this could read a description of a file. For now, we hard
139 * code the choices
140 *
141 */
142 static int datatype_index = 0;
143
144 /*
145 * Setup contiguous buffers of n copies of a datatype.
146 */
MTestTypeContigInit(MTestDatatype * mtype)147 static void *MTestTypeContigInit( MTestDatatype *mtype )
148 {
149 MPI::Aint size, lb;
150 if (mtype->count > 0) {
151 signed char *p;
152 int i;
153 MPI::Aint totsize;
154 mtype->datatype.Get_extent( lb, size );
155 totsize = size * mtype->count;
156 if (!mtype->buf) {
157 mtype->buf = (void *) malloc( totsize );
158 }
159 p = (signed char *)(mtype->buf);
160 if (!p) {
161 /* Error - out of memory */
162 MTestError( "Out of memory in type buffer init" );
163 }
164 for (i=0; i<totsize; i++) {
165 p[i] = 0xff ^ (i & 0xff);
166 }
167 }
168 else {
169 mtype->buf = 0;
170 }
171 return mtype->buf;
172 }
173
174 /*
175 * Setup contiguous buffers of n copies of a datatype. Initialize for
176 * reception (e.g., set initial data to detect failure)
177 */
MTestTypeContigInitRecv(MTestDatatype * mtype)178 static void *MTestTypeContigInitRecv( MTestDatatype *mtype )
179 {
180 MPI_Aint size;
181 if (mtype->count > 0) {
182 signed char *p;
183 int i;
184 MPI::Aint totsize;
185 MPI_Type_extent( mtype->datatype, &size );
186 totsize = size * mtype->count;
187 if (!mtype->buf) {
188 mtype->buf = (void *) malloc( totsize );
189 }
190 p = (signed char *)(mtype->buf);
191 if (!p) {
192 /* Error - out of memory */
193 MTestError( "Out of memory in type buffer init" );
194 }
195 for (i=0; i<totsize; i++) {
196 p[i] = 0xff;
197 }
198 }
199 else {
200 if (mtype->buf) {
201 free( mtype->buf );
202 }
203 mtype->buf = 0;
204 }
205 return mtype->buf;
206 }
MTestTypeContigFree(MTestDatatype * mtype)207 static void *MTestTypeContigFree( MTestDatatype *mtype )
208 {
209 if (mtype->buf) {
210 free( mtype->buf );
211 mtype->buf = 0;
212 }
213 return 0;
214 }
MTestTypeContigCheckbuf(MTestDatatype * mtype)215 static int MTestTypeContigCheckbuf( MTestDatatype *mtype )
216 {
217 unsigned char *p;
218 unsigned char expected;
219 int i, err = 0;
220 MPI_Aint size, totsize;
221
222 p = (unsigned char *)mtype->buf;
223 if (p) {
224 MPI_Type_extent( mtype->datatype, &size );
225 totsize = size * mtype->count;
226 for (i=0; i<totsize; i++) {
227 expected = (0xff ^ (i & 0xff));
228 if (p[i] != expected) {
229 err++;
230 if (mtype->printErrors && err < 10) {
231 cout << "Data expected = " << hex << expected <<
232 " but got " << p[i] << " for the " <<
233 dec << i << "th entry\n";
234 cout.flush();
235 }
236 }
237 }
238 }
239 return err;
240 }
241
242 /* ------------------------------------------------------------------------ */
243 /* Datatype routines for vector datatypes */
244 /* ------------------------------------------------------------------------ */
245
MTestTypeVectorInit(MTestDatatype * mtype)246 static void *MTestTypeVectorInit( MTestDatatype *mtype )
247 {
248 MPI::Aint size, lb;
249
250 if (mtype->count > 0) {
251 unsigned char *p;
252 int i, j, k, nc;
253 MPI::Aint totsize;
254
255 mtype->datatype.Get_extent( lb, size );
256 totsize = mtype->count * size;
257 if (!mtype->buf) {
258 mtype->buf = (void *) malloc( totsize );
259 }
260 p = (unsigned char *)(mtype->buf);
261 if (!p) {
262 /* Error - out of memory */
263 MTestError( "Out of memory in type buffer init" );
264 }
265
266 /* First, set to -1 */
267 for (i=0; i<totsize; i++) p[i] = 0xff;
268
269 /* Now, set the actual elements to the successive values.
270 To do this, we need to run 3 loops */
271 nc = 0;
272 /* count is usually one for a vector type */
273 for (k=0; k<mtype->count; k++) {
274 /* For each element (block) */
275 for (i=0; i<mtype->nelm; i++) {
276 /* For each value */
277 for (j=0; j<mtype->blksize; j++) {
278 p[j] = (0xff ^ (nc & 0xff));
279 nc++;
280 }
281 p += mtype->stride;
282 }
283 }
284 }
285 else {
286 mtype->buf = 0;
287 }
288 return mtype->buf;
289 }
290
MTestTypeVectorFree(MTestDatatype * mtype)291 static void *MTestTypeVectorFree( MTestDatatype *mtype )
292 {
293 if (mtype->buf) {
294 free( mtype->buf );
295 mtype->buf = 0;
296 }
297 return 0;
298 }
299
300 /* ------------------------------------------------------------------------ */
301 /* Routines to select a datatype and associated buffer create/fill/check */
302 /* routines */
303 /* ------------------------------------------------------------------------ */
304
305 /*
306 Create a range of datatypes with a given count elements.
307 This uses a selection of types, rather than an exhaustive collection.
308 It allocates both send and receive types so that they can have the same
309 type signature (collection of basic types) but different type maps (layouts
310 in memory)
311 */
MTestGetDatatypes(MTestDatatype * sendtype,MTestDatatype * recvtype,int count)312 int MTestGetDatatypes( MTestDatatype *sendtype, MTestDatatype *recvtype,
313 int count )
314 {
315 sendtype->InitBuf = 0;
316 sendtype->FreeBuf = 0;
317 sendtype->CheckBuf = 0;
318 sendtype->datatype = 0;
319 sendtype->isBasic = 0;
320 sendtype->printErrors = 0;
321 recvtype->InitBuf = 0;
322 recvtype->FreeBuf = 0;
323 recvtype->CheckBuf = 0;
324 recvtype->datatype = 0;
325 recvtype->isBasic = 0;
326 recvtype->printErrors = 0;
327
328 sendtype->buf = 0;
329 recvtype->buf = 0;
330
331 /* Set the defaults for the message lengths */
332 sendtype->count = count;
333 recvtype->count = count;
334 /* Use datatype_index to choose a datatype to use. If at the end of the
335 list, return 0 */
336 switch (datatype_index) {
337 case 0:
338 sendtype->datatype = MPI::INT;
339 sendtype->isBasic = 1;
340 recvtype->datatype = MPI::INT;
341 recvtype->isBasic = 1;
342 break;
343 case 1:
344 sendtype->datatype = MPI::DOUBLE;
345 sendtype->isBasic = 1;
346 recvtype->datatype = MPI::DOUBLE;
347 recvtype->isBasic = 1;
348 break;
349 case 2:
350 sendtype->datatype = MPI::INT;
351 sendtype->isBasic = 1;
352 recvtype->datatype = MPI::BYTE;
353 recvtype->isBasic = 1;
354 recvtype->count *= sizeof(int);
355 break;
356 case 3:
357 sendtype->datatype = MPI::FLOAT_INT;
358 sendtype->isBasic = 1;
359 recvtype->datatype = MPI::FLOAT_INT;
360 recvtype->isBasic = 1;
361 break;
362 case 4:
363 sendtype->datatype = MPI::INT.Dup();
364 sendtype->datatype.Set_name( "dup of MPI::INT" );
365 recvtype->datatype = MPI::INT.Dup();
366 recvtype->datatype.Set_name( "dup of MPI::INT" );
367 /* dup'ed types are already committed if the original type
368 was committed (MPI-2, section 8.8) */
369 break;
370 case 5:
371 /* vector send type and contiguous receive type */
372 /* These sizes are in bytes (see the VectorInit code) */
373 sendtype->stride = 3 * sizeof(int);
374 sendtype->blksize = sizeof(int);
375 sendtype->nelm = recvtype->count;
376 sendtype->datatype = MPI::INT.Create_vector( recvtype->count, 1, sendtype->stride );
377 sendtype->datatype.Commit();
378 sendtype->datatype.Set_name( "int-vector" );
379 sendtype->count = 1;
380 recvtype->datatype = MPI::INT;
381 recvtype->isBasic = 1;
382 sendtype->InitBuf = MTestTypeVectorInit;
383 recvtype->InitBuf = MTestTypeContigInitRecv;
384 sendtype->FreeBuf = MTestTypeVectorFree;
385 recvtype->FreeBuf = MTestTypeContigFree;
386 sendtype->CheckBuf = 0;
387 recvtype->CheckBuf = MTestTypeContigCheckbuf;
388 break;
389 default:
390 datatype_index = -1;
391 }
392
393 if (!sendtype->InitBuf) {
394 sendtype->InitBuf = MTestTypeContigInit;
395 recvtype->InitBuf = MTestTypeContigInitRecv;
396 sendtype->FreeBuf = MTestTypeContigFree;
397 recvtype->FreeBuf = MTestTypeContigFree;
398 sendtype->CheckBuf = MTestTypeContigCheckbuf;
399 recvtype->CheckBuf = MTestTypeContigCheckbuf;
400 }
401 datatype_index++;
402
403 if (dbgflag && datatype_index > 0) {
404 int typesize;
405 cout << wrank << ": sendtype is " << MTestGetDatatypeName( sendtype )
406 << "\n";
407 typesize = sendtype->datatype.Get_size();
408 cout << wrank << ": sendtype size = " << typesize << "\n";
409 cout << wrank << ": recvtype is " << MTestGetDatatypeName( recvtype )
410 << "\n";
411 typesize = recvtype->datatype.Get_size();
412 cout << wrank << ": recvtype size = " << typesize << "\n";
413 cout.flush();
414 }
415 return datatype_index;
416 }
417
418 /* Reset the datatype index (start from the initial data type.
419 Note: This routine is rarely needed; MTestGetDatatypes automatically
420 starts over after the last available datatype is used.
421 */
MTestResetDatatypes(void)422 void MTestResetDatatypes( void )
423 {
424 datatype_index = 0;
425 }
426 /* Return the index of the current datatype. This is rarely needed and
427 is provided mostly to enable debugging of the MTest package itself */
MTestGetDatatypeIndex(void)428 int MTestGetDatatypeIndex( void )
429 {
430 return datatype_index;
431 }
432
MTestFreeDatatype(MTestDatatype * mtype)433 void MTestFreeDatatype( MTestDatatype *mtype )
434 {
435 /* Invoke a datatype-specific free function to handle
436 both the datatype and the send/receive buffers */
437 if (mtype->FreeBuf) {
438 (mtype->FreeBuf)( mtype );
439 }
440 // Free the datatype itself if it was created
441 if (!mtype->isBasic) {
442 mtype->datatype.Free();
443 }
444 }
445
446 /* Check that a message was received correctly. Returns the number of
447 errors detected. Status may be NULL or MPI_STATUS_IGNORE */
MTestCheckRecv(MPI::Status & status,MTestDatatype * recvtype)448 int MTestCheckRecv( MPI::Status &status, MTestDatatype *recvtype )
449 {
450 int count;
451 int errs = 0;
452
453 /* Note that status may not be MPI_STATUS_IGNORE; C++ doesn't include
454 MPI_STATUS_IGNORE, instead using different function prototypes that
455 do not include the status argument */
456 count = status.Get_count( recvtype->datatype );
457
458 /* Check count against expected count */
459 if (count != recvtype->count) {
460 errs ++;
461 }
462
463 /* Check received data */
464 if (!errs && recvtype->CheckBuf( recvtype )) {
465 errs++;
466 }
467 return errs;
468 }
469
470 /* This next routine uses a circular buffer of static name arrays just to
471 simplify the use of the routine */
MTestGetDatatypeName(MTestDatatype * dtype)472 const char *MTestGetDatatypeName( MTestDatatype *dtype )
473 {
474 static char name[4][MPI_MAX_OBJECT_NAME];
475 static int sp=0;
476 int rlen;
477
478 if (sp >= 4) sp = 0;
479 dtype->datatype.Get_name( name[sp], rlen );
480 return (const char *)name[sp++];
481 }
482 /* ----------------------------------------------------------------------- */
483
484 /*
485 * Create communicators. Use separate routines for inter and intra
486 * communicators (there is a routine to give both)
487 * Note that the routines may return MPI::COMM_NULL, so code should test for
488 * that return value as well.
489 *
490 */
491 static int interCommIdx = 0;
492 static int intraCommIdx = 0;
493 static const char *intraCommName = 0;
494 static const char *interCommName = 0;
495
496 /*
497 * Get an intracommunicator with at least min_size members. If "allowSmaller"
498 * is true, allow the communicator to be smaller than MPI::COMM_WORLD and
499 * for this routine to return MPI::COMM_NULL for some values. Returns 0 if
500 * no more communicators are available.
501 */
MTestGetIntracommGeneral(MPI::Intracomm & comm,int min_size,bool allowSmaller)502 int MTestGetIntracommGeneral( MPI::Intracomm &comm, int min_size,
503 bool allowSmaller )
504 {
505 int size, rank;
506 bool done=false;
507 bool isBasic = false;
508
509 /* The while loop allows us to skip communicators that are too small.
510 MPI::COMM_NULL is always considered large enough */
511 while (!done) {
512 switch (intraCommIdx) {
513 case 0:
514 comm = MPI::COMM_WORLD;
515 isBasic = true;
516 intraCommName = "MPI::COMM_WORLD";
517 break;
518 case 1:
519 /* dup of world */
520 comm = MPI::COMM_WORLD.Dup();
521 intraCommName = "Dup of MPI::COMM_WORLD";
522 break;
523 case 2:
524 /* reverse ranks */
525 size = MPI::COMM_WORLD.Get_size();
526 rank = MPI::COMM_WORLD.Get_rank();
527 comm = MPI::COMM_WORLD.Split( 0, size-rank );
528 intraCommName = "Rank reverse of MPI::COMM_WORLD";
529 break;
530 case 3:
531 /* subset of world, with reversed ranks */
532 size = MPI::COMM_WORLD.Get_size();
533 rank = MPI::COMM_WORLD.Get_rank();
534 comm = MPI::COMM_WORLD.Split( (rank < size/2), size-rank );
535 intraCommName = "Rank reverse of half of MPI::COMM_WORLD";
536 break;
537 case 4:
538 comm = MPI::COMM_SELF;
539 isBasic = true;
540 intraCommName = "MPI::COMM_SELF";
541 break;
542
543 /* These next cases are communicators that include some
544 but not all of the processes */
545 case 5:
546 case 6:
547 case 7:
548 case 8:
549 {
550 int newsize;
551 size = MPI::COMM_WORLD.Get_size();
552 newsize = size - (intraCommIdx - 4);
553
554 if (allowSmaller && newsize >= min_size) {
555 rank = MPI::COMM_WORLD.Get_rank();
556 comm = MPI::COMM_WORLD.Split( rank < newsize, rank );
557 if (rank >= newsize) {
558 comm.Free();
559 comm = MPI::COMM_NULL;
560 }
561 }
562 else {
563 /* Act like default */
564 comm = MPI::COMM_NULL;
565 isBasic = true;
566 intraCommName = "MPI::COMM_NULL";
567 intraCommIdx = -1;
568 }
569 }
570 break;
571
572 /* Other ideas: dup of self, cart comm, graph comm */
573 default:
574 comm = MPI::COMM_NULL;
575 isBasic = true;
576 intraCommName = "MPI::COMM_NULL";
577 intraCommIdx = -1;
578 break;
579 }
580
581 if (comm != MPI::COMM_NULL) {
582 size = comm.Get_size();
583 if (size >= min_size)
584 done = true;
585 else {
586 /* Try again */
587 if (!isBasic) comm.Free();
588 intraCommIdx++;
589 }
590 }
591 else
592 done = true;
593 }
594
595 intraCommIdx++;
596 return intraCommIdx;
597 }
598
599 /*
600 * Get an intracommunicator with at least min_size members.
601 */
MTestGetIntracomm(MPI::Intracomm & comm,int min_size)602 int MTestGetIntracomm( MPI::Intracomm &comm, int min_size )
603 {
604 return MTestGetIntracommGeneral( comm, min_size, false );
605 }
606
607 /* Return the name of an intra communicator */
MTestGetIntracommName(void)608 const char *MTestGetIntracommName( void )
609 {
610 return intraCommName;
611 }
612
613 /*
614 * Return an intercomm; set isLeftGroup to 1 if the calling process is
615 * a member of the "left" group.
616 */
MTestGetIntercomm(MPI::Intercomm & comm,int & isLeftGroup,int min_size)617 int MTestGetIntercomm( MPI::Intercomm &comm, int &isLeftGroup, int min_size )
618 {
619 int size, rank, remsize;
620 bool done=false;
621 MPI::Intracomm mcomm;
622 int rleader;
623
624 /* The while loop allows us to skip communicators that are too small.
625 MPI::COMM_NULL is always considered large enough. The size is
626 the sum of the sizes of the local and remote groups */
627 while (!done) {
628 comm = MPI::COMM_NULL;
629 isLeftGroup = 0;
630 interCommName = "MPI_COMM_NULL";
631
632 switch (interCommIdx) {
633 case 0:
634 /* Split comm world in half */
635 rank = MPI::COMM_WORLD.Get_rank();
636 size = MPI::COMM_WORLD.Get_size();
637 if (size > 1) {
638 mcomm = MPI::COMM_WORLD.Split( (rank < size/2), rank );
639 if (rank == 0) {
640 rleader = size/2;
641 }
642 else if (rank == size/2) {
643 rleader = 0;
644 }
645 else {
646 /* Remote leader is signficant only for the processes
647 designated local leaders */
648 rleader = -1;
649 }
650 isLeftGroup = rank < size/2;
651 comm = mcomm.Create_intercomm( 0, MPI::COMM_WORLD, rleader, 12345 );
652 mcomm.Free();
653 interCommName = "Intercomm by splitting MPI::COMM_WORLD";
654 }
655 else {
656 comm = MPI::COMM_NULL;
657 }
658 break;
659 case 1:
660 /* Split comm world in to 1 and the rest */
661 rank = MPI::COMM_WORLD.Get_rank();
662 size = MPI::COMM_WORLD.Get_size();
663 if (size > 1) {
664 mcomm = MPI::COMM_WORLD.Split( rank == 0, rank );
665 if (rank == 0) {
666 rleader = 1;
667 }
668 else if (rank == 1) {
669 rleader = 0;
670 }
671 else {
672 /* Remote leader is signficant only for the processes
673 designated local leaders */
674 rleader = -1;
675 }
676 isLeftGroup = rank == 0;
677 comm = mcomm.Create_intercomm( 0, MPI::COMM_WORLD, rleader, 12346 );
678 mcomm.Free();
679 interCommName = "Intercomm by splitting MPI::COMM_WORLD into 1, rest";
680 }
681 else {
682 comm = MPI::COMM_NULL;
683 }
684 break;
685
686 case 2:
687 /* Split comm world in to 2 and the rest */
688 rank = MPI::COMM_WORLD.Get_rank();
689 size = MPI::COMM_WORLD.Get_size();
690 if (size > 3) {
691 mcomm = MPI::COMM_WORLD.Split( rank < 2, rank );
692 if (rank == 0) {
693 rleader = 2;
694 }
695 else if (rank == 2) {
696 rleader = 0;
697 }
698 else {
699 /* Remote leader is signficant only for the processes
700 designated local leaders */
701 rleader = -1;
702 }
703 isLeftGroup = rank < 2;
704 comm = mcomm.Create_intercomm( 0, MPI::COMM_WORLD, rleader, 12347 );
705 mcomm.Free();
706 interCommName = "Intercomm by splitting MPI::COMM_WORLD into 2, rest";
707 }
708 else {
709 comm = MPI::COMM_NULL;
710 }
711 break;
712
713 default:
714 comm = MPI::COMM_NULL;
715 interCommName = "MPI::COMM_NULL";
716 interCommIdx = -1;
717 break;
718 }
719 if (comm != MPI::COMM_NULL) {
720 size = comm.Get_size();
721 remsize = comm.Get_remote_size();
722 if (size + remsize >= min_size) done = true;
723 }
724 else
725 done = true;
726
727 /* we are only done if all processes are done */
728 MPI::COMM_WORLD.Allreduce(MPI_IN_PLACE, &done, 1, MPI::BOOL, MPI::LAND);
729
730 /* Advance the comm index whether we are done or not, otherwise we could
731 * spin forever trying to allocate a too-small communicator over and
732 * over again. */
733 interCommIdx++;
734
735 if (!done && comm != MPI::COMM_NULL) {
736 comm.Free();
737 }
738 }
739
740 return interCommIdx;
741 }
742 /* Return the name of an intercommunicator */
MTestGetIntercommName(void)743 const char *MTestGetIntercommName( void )
744 {
745 return interCommName;
746 }
747
748 /* Get a communicator of a given minimum size. Both intra and inter
749 communicators are provided
750 Because Comm is an abstract base class, you can only have references
751 to a Comm.*/
MTestGetComm(MPI::Comm ** comm,int min_size)752 int MTestGetComm( MPI::Comm **comm, int min_size )
753 {
754 int idx;
755 static int getinter = 0;
756
757 if (!getinter) {
758 MPI::Intracomm rcomm;
759 idx = MTestGetIntracomm( rcomm, min_size );
760 if (idx == 0) {
761 getinter = 1;
762 }
763 else {
764 MPI::Intracomm *ncomm = new MPI::Intracomm(rcomm);
765 *comm = ncomm;
766 }
767 }
768 if (getinter) {
769 MPI::Intercomm icomm;
770 int isLeft;
771 idx = MTestGetIntercomm( icomm, isLeft, min_size );
772 if (idx == 0) {
773 getinter = 0;
774 }
775 else {
776 MPI::Intercomm *ncomm = new MPI::Intercomm(icomm);
777 *comm = ncomm;
778 }
779 }
780
781 return idx;
782 }
783
784 /* Free a communicator. It may be called with a predefined communicator
785 or MPI_COMM_NULL */
MTestFreeComm(MPI::Comm & comm)786 void MTestFreeComm( MPI::Comm &comm )
787 {
788 if (comm != MPI::COMM_WORLD &&
789 comm != MPI::COMM_SELF &&
790 comm != MPI::COMM_NULL) {
791 comm.Free();
792 }
793 }
794
795 /* ------------------------------------------------------------------------ */
MTestPrintError(int errcode)796 void MTestPrintError( int errcode )
797 {
798 int errclass, slen;
799 char string[MPI_MAX_ERROR_STRING];
800
801 errclass = MPI::Get_error_class( errcode );
802 MPI::Get_error_string( errcode, string, slen );
803 cout << "Error class " << errclass << "(" << string << ")\n";
804 cout.flush();
805 }
MTestPrintErrorMsg(const char msg[],int errcode)806 void MTestPrintErrorMsg( const char msg[], int errcode )
807 {
808 int errclass, slen;
809 char string[MPI_MAX_ERROR_STRING];
810
811 errclass = MPI::Get_error_class( errcode );
812 MPI::Get_error_string( errcode, string, slen );
813 cout << msg << ": Error class " << errclass << " (" << string << ")\n";
814 cout.flush();
815 }
816 /* ------------------------------------------------------------------------ */
817 /* Fatal error. Report and exit */
MTestError(const char * msg)818 void MTestError( const char *msg )
819 {
820 cerr << msg << "\n";
821 cerr.flush();
822 MPI::COMM_WORLD.Abort(1);
823 }
824
825 #ifdef HAVE_MPI_WIN_CREATE
826 /*
827 * Create MPI Windows
828 */
829 static int win_index = 0;
830 static const char *winName;
831 /* Use an attribute to remember the type of memory allocation (static,
832 malloc, or MPI_Alloc_mem) */
833 static int mem_keyval = MPI::KEYVAL_INVALID;
MTestGetWin(MPI::Win & win,bool mustBePassive)834 int MTestGetWin( MPI::Win &win, bool mustBePassive )
835 {
836 static char actbuf[1024];
837 static char *pasbuf;
838 char *buf;
839 int n, rank;
840 MPI::Info info;
841
842 if (mem_keyval == MPI::KEYVAL_INVALID) {
843 /* Create the keyval */
844 mem_keyval = MPI::Win::Create_keyval( MPI::Win::NULL_COPY_FN,
845 MPI::Win::NULL_DELETE_FN, 0 );
846 }
847
848 switch (win_index) {
849 case 0:
850 /* Active target window */
851 win = MPI::Win::Create( actbuf, 1024, 1, MPI::INFO_NULL, MPI::COMM_WORLD );
852 winName = "active-window";
853 win.Set_attr( mem_keyval, (void *)0 );
854 break;
855 case 1:
856 /* Passive target window */
857 pasbuf = (char *)MPI::Alloc_mem( 1024, MPI::INFO_NULL );
858 win = MPI::Win::Create( pasbuf, 1024, 1, MPI::INFO_NULL, MPI::COMM_WORLD );
859 winName = "passive-window";
860 win.Set_attr( mem_keyval, (void *)2 );
861 break;
862 case 2:
863 /* Active target; all windows different sizes */
864 rank = MPI::COMM_WORLD.Get_rank();
865 n = rank * 64;
866 if (n)
867 buf = (char *)malloc( n );
868 else
869 buf = 0;
870 win = MPI::Win::Create( buf, n, 1, MPI::INFO_NULL, MPI::COMM_WORLD );
871 winName = "active-all-different-win";
872 win.Set_attr( mem_keyval, (void *)1 );
873 break;
874 case 3:
875 /* Active target, no locks set */
876 rank = MPI::COMM_WORLD.Get_rank();
877 n = rank * 64;
878 if (n)
879 buf = (char *)malloc( n );
880 else
881 buf = 0;
882 info = MPI::Info::Create( );
883 info.Set( "nolocks", "true" );
884 win = MPI::Win::Create( buf, n, 1, info, MPI::COMM_WORLD );
885 info.Free();
886 winName = "active-nolocks-all-different-win";
887 win.Set_attr( mem_keyval, (void *)1 );
888 break;
889 default:
890 win_index = -1;
891 }
892 win_index++;
893 return win_index;
894 }
895 /* Return a pointer to the name associated with a window object */
MTestGetWinName(void)896 const char *MTestGetWinName( void )
897 {
898
899 return winName;
900 }
901 /* Free the storage associated with a window object */
MTestFreeWin(MPI::Win & win)902 void MTestFreeWin( MPI::Win &win )
903 {
904 void *addr;
905 bool flag;
906
907 flag = win.Get_attr( MPI_WIN_BASE, &addr );
908 if (!flag) {
909 MTestError( "Could not get WIN_BASE from window" );
910 }
911 if (addr) {
912 void *val;
913 flag = win.Get_attr( mem_keyval, &val );
914 if (flag) {
915 if (val == (void *)1) {
916 free( addr );
917 }
918 else if (val == (void *)2) {
919 MPI::Free_mem( addr );
920 }
921 /* if val == (void *)0, then static data that must not be freed */
922 }
923 }
924 win.Free();
925 }
MTestRMACleanup(void)926 static void MTestRMACleanup( void )
927 {
928 if (mem_keyval != MPI::KEYVAL_INVALID) {
929 MPI::Win::Free_keyval( mem_keyval );
930 }
931 }
932 #else
MTestRMACleanup(void)933 static void MTestRMACleanup( void ) {}
934 #endif
935