Logo AND Algorithmique Numérique Distribuée

Public GIT Repository
Try to fix mpich tests on systems without privatization
[simgrid.git] / 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", envval);
113             fflush(stderr);
114         }
115         else {
116             if (val >= 0) {
117                 SMPI_VARGET_GLOBAL(verbose) = val;
118             }
119             else {
120                 fprintf(stderr, "Warning: %s not valid for MPITEST_VERBOSE\n", envval);
121                 fflush(stderr);
122             }
123         }
124     }
125     /* Check for option to return success/failure in the return value of main */
126     envval = getenv("MPITEST_RETURN_WITH_CODE");
127     if (envval) {
128         if (strcmp(envval, "yes") == 0 ||
129             strcmp(envval, "YES") == 0 ||
130             strcmp(envval, "true") == 0 || strcmp(envval, "TRUE") == 0) {
131             SMPI_VARGET_GLOBAL(returnWithVal) = 1;
132         }
133         else if (strcmp(envval, "no") == 0 ||
134                  strcmp(envval, "NO") == 0 ||
135                  strcmp(envval, "false") == 0 || strcmp(envval, "FALSE") == 0) {
136             SMPI_VARGET_GLOBAL(returnWithVal) = 0;
137         }
138         else {
139             fprintf(stderr, "Warning: %s not valid for MPITEST_RETURN_WITH_CODE\n", envval);
140             fflush(stderr);
141         }
142     }
143
144     /* Print rusage data if set */
145     if (getenv("MPITEST_RUSAGE")) {
146         SMPI_VARGET_GLOBAL(usageOutput) = 1;
147     }
148 }
149
150 /*
151  * Initialize the tests, using an MPI-1 style init.  Supports
152  * MTEST_THREADLEVEL_DEFAULT to test with user-specified thread level
153  */
154 void MTest_Init(int *argc, char ***argv)
155 {
156     int provided;
157 #if MPI_VERSION >= 2 || defined(HAVE_MPI_INIT_THREAD)
158     const char *str = 0;
159     int threadLevel;
160
161     threadLevel = MPI_THREAD_SINGLE;
162     str = getenv("MTEST_THREADLEVEL_DEFAULT");
163     if (!str)
164         str = getenv("MPITEST_THREADLEVEL_DEFAULT");
165     if (str && *str) {
166         if (strcmp(str, "MULTIPLE") == 0 || strcmp(str, "multiple") == 0) {
167             threadLevel = MPI_THREAD_MULTIPLE;
168         }
169         else if (strcmp(str, "SERIALIZED") == 0 || strcmp(str, "serialized") == 0) {
170             threadLevel = MPI_THREAD_SERIALIZED;
171         }
172         else if (strcmp(str, "FUNNELED") == 0 || strcmp(str, "funneled") == 0) {
173             threadLevel = MPI_THREAD_FUNNELED;
174         }
175         else if (strcmp(str, "SINGLE") == 0 || strcmp(str, "single") == 0) {
176             threadLevel = MPI_THREAD_SINGLE;
177         }
178         else {
179             fprintf(stderr, "Unrecognized thread level %s\n", str);
180             /* Use exit since MPI_Init/Init_thread has not been called. */
181             exit(1);
182         }
183     }
184     MTest_Init_thread(argc, argv, threadLevel, &provided);
185 #else
186     /* If the MPI_VERSION is 1, there is no MPI_THREAD_xxx defined */
187     MTest_Init_thread(argc, argv, 0, &provided);
188 #endif
189 }
190
191 /*
192   Finalize MTest.  errs is the number of errors on the calling process;
193   this routine will write the total number of errors over all of MPI_COMM_WORLD
194   to the process with rank zero, or " No Errors".
195   It does *not* finalize MPI.
196  */
197 void MTest_Finalize(int errs)
198 {
199     int rank, toterrs, merr;
200
201     merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
202     if (merr)
203         MTestPrintError(merr);
204
205     merr = MPI_Reduce(&errs, &toterrs, 1, MPI_INT, MPI_SUM, 0, MPI_COMM_WORLD);
206     if (merr)
207         MTestPrintError(merr);
208     if (rank == 0) {
209         if (toterrs) {
210             printf(" Found %d errors\n", toterrs);
211         }
212         else {
213             printf(" No Errors\n");
214         }
215         fflush(stdout);
216     }
217
218     if (SMPI_VARGET_GLOBAL(usageOutput))
219         MTestResourceSummary(stdout);
220
221
222     /* Clean up any persistent objects that we allocated */
223     MTestRMACleanup();
224 }
225
226 /* ------------------------------------------------------------------------ */
227 /* This routine may be used instead of "return 0;" at the end of main;
228    it allows the program to use the return value to signal success or failure.
229  */
230 int MTestReturnValue(int errors)
231 {
232     if (SMPI_VARGET_GLOBAL(returnWithVal))
233         return errors ? 1 : 0;
234     return 0;
235 }
236
237 /* ------------------------------------------------------------------------ */
238
239 /*
240  * Miscellaneous utilities, particularly to eliminate OS dependencies
241  * from the tests.
242  * MTestSleep(seconds)
243  */
244 #ifdef HAVE_WINDOWS_H
245 #include <windows.h>
246 void MTestSleep(int sec)
247 {
248     Sleep(1000 * sec);
249 }
250 #else
251 #include <unistd.h>
252 void MTestSleep(int sec)
253 {
254     sleep(sec);
255 }
256 #endif
257
258 /* Other mtest subfiles read debug setting using this function. */
259 void MTestGetDbgInfo(int *_dbgflag, int *_verbose)
260 {
261     *_dbgflag = SMPI_VARGET_GLOBAL(dbgflag);
262     *_verbose = SMPI_VARGET_GLOBAL(verbose);
263 }
264
265 /* ----------------------------------------------------------------------- */
266
267 /*
268  * Create communicators.  Use separate routines for inter and intra
269  * communicators (there is a routine to give both)
270  * Note that the routines may return MPI_COMM_NULL, so code should test for
271  * that return value as well.
272  *
273  */
274 static int interCommIdx = 0;
275 static int intraCommIdx = 0;
276 static const char *intraCommName = 0;
277 static const char *interCommName = 0;
278
279 /*
280  * Get an intracommunicator with at least min_size members.  If "allowSmaller"
281  * is true, allow the communicator to be smaller than MPI_COMM_WORLD and
282  * for this routine to return MPI_COMM_NULL for some values.  Returns 0 if
283  * no more communicators are available.
284  */
285 int MTestGetIntracommGeneral(MPI_Comm * comm, int min_size, int allowSmaller)
286 {
287     int size, rank, merr;
288     int done = 0;
289     int isBasic = 0;
290
291     /* The while loop allows us to skip communicators that are too small.
292      * MPI_COMM_NULL is always considered large enough */
293     while (!done) {
294         isBasic = 0;
295         intraCommName = "";
296         switch (intraCommIdx) {
297         case 0:
298             *comm = MPI_COMM_WORLD;
299             isBasic = 1;
300             intraCommName = "MPI_COMM_WORLD";
301             break;
302         case 1:
303             /* dup of world */
304             merr = MPI_Comm_dup(MPI_COMM_WORLD, comm);
305             if (merr)
306                 MTestPrintError(merr);
307             intraCommName = "Dup of MPI_COMM_WORLD";
308             break;
309         case 2:
310             /* reverse ranks */
311             merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
312             if (merr)
313                 MTestPrintError(merr);
314             merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
315             if (merr)
316                 MTestPrintError(merr);
317             merr = MPI_Comm_split(MPI_COMM_WORLD, 0, size - rank, comm);
318             if (merr)
319                 MTestPrintError(merr);
320             intraCommName = "Rank reverse of MPI_COMM_WORLD";
321             break;
322         case 3:
323             /* subset of world, with reversed ranks */
324             merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
325             if (merr)
326                 MTestPrintError(merr);
327             merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
328             if (merr)
329                 MTestPrintError(merr);
330             merr = MPI_Comm_split(MPI_COMM_WORLD, ((rank < size / 2) ? 1 : MPI_UNDEFINED),
331                                   size - rank, comm);
332             if (merr)
333                 MTestPrintError(merr);
334             intraCommName = "Rank reverse of half of MPI_COMM_WORLD";
335             break;
336         case 4:
337             *comm = MPI_COMM_SELF;
338             isBasic = 1;
339             intraCommName = "MPI_COMM_SELF";
340             break;
341         case 5:
342             {
343 #if MTEST_HAVE_MIN_MPI_VERSION(3,0)
344                 /* Dup of the world using MPI_Intercomm_merge */
345                 int rleader, isLeft;
346                 MPI_Comm local_comm, inter_comm;
347                 MPI_Comm_size(MPI_COMM_WORLD, &size);
348                 MPI_Comm_rank(MPI_COMM_WORLD, &rank);
349                 if (size > 1) {
350                     merr = MPI_Comm_split(MPI_COMM_WORLD, (rank < size / 2), rank, &local_comm);
351                     if (merr)
352                         MTestPrintError(merr);
353                     if (rank == 0) {
354                         rleader = size / 2;
355                     }
356                     else if (rank == size / 2) {
357                         rleader = 0;
358                     }
359                     else {
360                         rleader = -1;
361                     }
362                     isLeft = rank < size / 2;
363                     merr =
364                         MPI_Intercomm_create(local_comm, 0, MPI_COMM_WORLD, rleader, 99,
365                                              &inter_comm);
366                     if (merr)
367                         MTestPrintError(merr);
368                     merr = MPI_Intercomm_merge(inter_comm, isLeft, comm);
369                     if (merr)
370                         MTestPrintError(merr);
371                     MPI_Comm_free(&inter_comm);
372                     MPI_Comm_free(&local_comm);
373                     intraCommName = "Dup of WORLD created by MPI_Intercomm_merge";
374                 }
375                 else {
376                     *comm = MPI_COMM_NULL;
377                 }
378             }
379             break;
380         case 6:
381             {
382                 /* Even of the world using MPI_Comm_create_group */
383                 int i;
384                 MPI_Group world_group, even_group;
385                 int *excl = NULL;
386
387                 MPI_Comm_size(MPI_COMM_WORLD, &size);
388                 MPI_Comm_rank(MPI_COMM_WORLD, &rank);
389                 if (allowSmaller && (size + 1) / 2 >= min_size) {
390                     /* exclude the odd ranks */
391                     excl = malloc((size / 2) * sizeof(int));
392                     for (i = 0; i < size / 2; i++)
393                         excl[i] = (2 * i) + 1;
394
395                     MPI_Comm_group(MPI_COMM_WORLD, &world_group);
396                     MPI_Group_excl(world_group, size / 2, excl, &even_group);
397                     MPI_Group_free(&world_group);
398                     free(excl);
399
400                     if (rank % 2 == 0) {
401                         /* Even processes create a comm. for themselves */
402                         MPI_Comm_create_group(MPI_COMM_WORLD, even_group, 0, comm);
403                         intraCommName = "Even of WORLD created by MPI_Comm_create_group";
404                     }
405                     else {
406                         *comm = MPI_COMM_NULL;
407                     }
408
409                     MPI_Group_free(&even_group);
410                 }
411                 else {
412                     *comm = MPI_COMM_NULL;
413                 }
414 #else
415                 *comm = MPI_COMM_NULL;
416 #endif
417             }
418             break;
419         case 7:
420             {
421                 /* High half of the world using MPI_Comm_create */
422                 int ranges[1][3];
423                 MPI_Group world_group, high_group;
424                 MPI_Comm_size(MPI_COMM_WORLD, &size);
425                 MPI_Comm_rank(MPI_COMM_WORLD, &rank);
426                 ranges[0][0] = size / 2;
427                 ranges[0][1] = size - 1;
428                 ranges[0][2] = 1;
429
430                 if (allowSmaller && (size + 1) / 2 >= min_size) {
431                     MPI_Comm_group(MPI_COMM_WORLD, &world_group);
432                     merr = MPI_Group_range_incl(world_group, 1, ranges, &high_group);
433                     if (merr)
434                         MTestPrintError(merr);
435                     merr = MPI_Comm_create(MPI_COMM_WORLD, high_group, comm);
436                     if (merr)
437                         MTestPrintError(merr);
438                     MPI_Group_free(&world_group);
439                     MPI_Group_free(&high_group);
440                     intraCommName = "High half of WORLD created by MPI_Comm_create";
441                 }
442                 else {
443                     *comm = MPI_COMM_NULL;
444                 }
445             }
446             break;
447             /* These next cases are communicators that include some
448              * but not all of the processes */
449         case 8:
450         case 9:
451         case 10:
452         case 11:
453             {
454                 int newsize;
455                 merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
456                 if (merr)
457                     MTestPrintError(merr);
458                 newsize = size - (intraCommIdx - 7);
459
460                 if (allowSmaller && newsize >= min_size) {
461                     merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
462                     if (merr)
463                         MTestPrintError(merr);
464                     merr = MPI_Comm_split(MPI_COMM_WORLD, rank < newsize, rank, comm);
465                     if (merr)
466                         MTestPrintError(merr);
467                     if (rank >= newsize) {
468                         merr = MPI_Comm_free(comm);
469                         if (merr)
470                             MTestPrintError(merr);
471                         *comm = MPI_COMM_NULL;
472                     }
473                     else {
474                         intraCommName = "Split of WORLD";
475                     }
476                 }
477                 else {
478                     /* Act like default */
479                     *comm = MPI_COMM_NULL;
480                     intraCommIdx = -1;
481                 }
482             }
483             break;
484
485             /* Other ideas: dup of self, cart comm, graph comm */
486         default:
487             *comm = MPI_COMM_NULL;
488             intraCommIdx = -1;
489             break;
490         }
491
492         if (*comm != MPI_COMM_NULL) {
493             merr = MPI_Comm_size(*comm, &size);
494             if (merr)
495                 MTestPrintError(merr);
496             if (size >= min_size)
497                 done = 1;
498         }
499         else {
500             intraCommName = "MPI_COMM_NULL";
501             isBasic = 1;
502             done = 1;
503         }
504
505         /* we are only done if all processes are done */
506         MPI_Allreduce(MPI_IN_PLACE, &done, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD);
507
508         /* Advance the comm index whether we are done or not, otherwise we could
509          * spin forever trying to allocate a too-small communicator over and
510          * over again. */
511         intraCommIdx++;
512
513         if (!done && !isBasic && *comm != MPI_COMM_NULL) {
514             /* avoid leaking communicators */
515             merr = MPI_Comm_free(comm);
516             if (merr)
517                 MTestPrintError(merr);
518         }
519     }
520
521     return intraCommIdx;
522 }
523
524 /*
525  * Get an intracommunicator with at least min_size members.
526  */
527 int MTestGetIntracomm(MPI_Comm * comm, int min_size)
528 {
529     return MTestGetIntracommGeneral(comm, min_size, 0);
530 }
531
532 /* Return the name of an intra communicator */
533 const char *MTestGetIntracommName(void)
534 {
535     return intraCommName;
536 }
537
538 /*
539  * Return an intercomm; set isLeftGroup to 1 if the calling process is
540  * a member of the "left" group.
541  */
542 int MTestGetIntercomm(MPI_Comm * comm, int *isLeftGroup, int min_size)
543 {
544     int size, rank, remsize, merr;
545     int done = 0;
546     MPI_Comm mcomm = MPI_COMM_NULL;
547     MPI_Comm mcomm2 = MPI_COMM_NULL;
548     int rleader;
549
550     /* The while loop allows us to skip communicators that are too small.
551      * MPI_COMM_NULL is always considered large enough.  The size is
552      * the sum of the sizes of the local and remote groups */
553     while (!done) {
554         *comm = MPI_COMM_NULL;
555         *isLeftGroup = 0;
556         interCommName = "MPI_COMM_NULL";
557
558         switch (interCommIdx) {
559         case 0:
560             /* Split comm world in half */
561             merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
562             if (merr)
563                 MTestPrintError(merr);
564             merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
565             if (merr)
566                 MTestPrintError(merr);
567             if (size > 1) {
568                 merr = MPI_Comm_split(MPI_COMM_WORLD, (rank < size / 2), rank, &mcomm);
569                 if (merr)
570                     MTestPrintError(merr);
571                 if (rank == 0) {
572                     rleader = size / 2;
573                 }
574                 else if (rank == size / 2) {
575                     rleader = 0;
576                 }
577                 else {
578                     /* Remote leader is signficant only for the processes
579                      * designated local leaders */
580                     rleader = -1;
581                 }
582                 *isLeftGroup = rank < size / 2;
583                 merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12345, comm);
584                 if (merr)
585                     MTestPrintError(merr);
586                 interCommName = "Intercomm by splitting MPI_COMM_WORLD";
587             }
588             else
589                 *comm = MPI_COMM_NULL;
590             break;
591         case 1:
592             /* Split comm world in to 1 and the rest */
593             merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
594             if (merr)
595                 MTestPrintError(merr);
596             merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
597             if (merr)
598                 MTestPrintError(merr);
599             if (size > 1) {
600                 merr = MPI_Comm_split(MPI_COMM_WORLD, rank == 0, rank, &mcomm);
601                 if (merr)
602                     MTestPrintError(merr);
603                 if (rank == 0) {
604                     rleader = 1;
605                 }
606                 else if (rank == 1) {
607                     rleader = 0;
608                 }
609                 else {
610                     /* Remote leader is signficant only for the processes
611                      * designated local leaders */
612                     rleader = -1;
613                 }
614                 *isLeftGroup = rank == 0;
615                 merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12346, comm);
616                 if (merr)
617                     MTestPrintError(merr);
618                 interCommName = "Intercomm by splitting MPI_COMM_WORLD into 1, rest";
619             }
620             else
621                 *comm = MPI_COMM_NULL;
622             break;
623
624         case 2:
625             /* Split comm world in to 2 and the rest */
626             merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
627             if (merr)
628                 MTestPrintError(merr);
629             merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
630             if (merr)
631                 MTestPrintError(merr);
632             if (size > 3) {
633                 merr = MPI_Comm_split(MPI_COMM_WORLD, rank < 2, rank, &mcomm);
634                 if (merr)
635                     MTestPrintError(merr);
636                 if (rank == 0) {
637                     rleader = 2;
638                 }
639                 else if (rank == 2) {
640                     rleader = 0;
641                 }
642                 else {
643                     /* Remote leader is signficant only for the processes
644                      * designated local leaders */
645                     rleader = -1;
646                 }
647                 *isLeftGroup = rank < 2;
648                 merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12347, comm);
649                 if (merr)
650                     MTestPrintError(merr);
651                 interCommName = "Intercomm by splitting MPI_COMM_WORLD into 2, rest";
652             }
653             else
654                 *comm = MPI_COMM_NULL;
655             break;
656
657         case 3:
658             /* Split comm world in half, then dup */
659             merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
660             if (merr)
661                 MTestPrintError(merr);
662             merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
663             if (merr)
664                 MTestPrintError(merr);
665             if (size > 1) {
666                 merr = MPI_Comm_split(MPI_COMM_WORLD, (rank < size / 2), rank, &mcomm);
667                 if (merr)
668                     MTestPrintError(merr);
669                 if (rank == 0) {
670                     rleader = size / 2;
671                 }
672                 else if (rank == size / 2) {
673                     rleader = 0;
674                 }
675                 else {
676                     /* Remote leader is signficant only for the processes
677                      * designated local leaders */
678                     rleader = -1;
679                 }
680                 *isLeftGroup = rank < size / 2;
681                 merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12345, comm);
682                 if (merr)
683                     MTestPrintError(merr);
684                 /* avoid leaking after assignment below */
685                 merr = MPI_Comm_free(&mcomm);
686                 if (merr)
687                     MTestPrintError(merr);
688
689                 /* now dup, some bugs only occur for dup's of intercomms */
690                 mcomm = *comm;
691                 merr = MPI_Comm_dup(mcomm, comm);
692                 if (merr)
693                     MTestPrintError(merr);
694                 interCommName = "Intercomm by splitting MPI_COMM_WORLD then dup'ing";
695             }
696             else
697                 *comm = MPI_COMM_NULL;
698             break;
699
700         case 4:
701             /* Split comm world in half, form intercomm, then split that intercomm */
702             merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
703             if (merr)
704                 MTestPrintError(merr);
705             merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
706             if (merr)
707                 MTestPrintError(merr);
708             if (size > 1) {
709                 merr = MPI_Comm_split(MPI_COMM_WORLD, (rank < size / 2), rank, &mcomm);
710                 if (merr)
711                     MTestPrintError(merr);
712                 if (rank == 0) {
713                     rleader = size / 2;
714                 }
715                 else if (rank == size / 2) {
716                     rleader = 0;
717                 }
718                 else {
719                     /* Remote leader is signficant only for the processes
720                      * designated local leaders */
721                     rleader = -1;
722                 }
723                 *isLeftGroup = rank < size / 2;
724                 merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12345, comm);
725                 if (merr)
726                     MTestPrintError(merr);
727                 /* avoid leaking after assignment below */
728                 merr = MPI_Comm_free(&mcomm);
729                 if (merr)
730                     MTestPrintError(merr);
731
732                 /* now split, some bugs only occur for splits of intercomms */
733                 mcomm = *comm;
734                 merr = MPI_Comm_rank(mcomm, &rank);
735                 if (merr)
736                     MTestPrintError(merr);
737                 /* this split is effectively a dup but tests the split code paths */
738                 merr = MPI_Comm_split(mcomm, 0, rank, comm);
739                 if (merr)
740                     MTestPrintError(merr);
741                 interCommName = "Intercomm by splitting MPI_COMM_WORLD then then splitting again";
742             }
743             else
744                 *comm = MPI_COMM_NULL;
745             break;
746
747         case 5:
748             /* split comm world in half discarding rank 0 on the "left"
749              * communicator, then form them into an intercommunicator */
750             merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
751             if (merr)
752                 MTestPrintError(merr);
753             merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
754             if (merr)
755                 MTestPrintError(merr);
756             if (size >= 4) {
757                 int color = (rank < size / 2 ? 0 : 1);
758                 if (rank == 0)
759                     color = MPI_UNDEFINED;
760
761                 merr = MPI_Comm_split(MPI_COMM_WORLD, color, rank, &mcomm);
762                 if (merr)
763                     MTestPrintError(merr);
764
765                 if (rank == 1) {
766                     rleader = size / 2;
767                 }
768                 else if (rank == (size / 2)) {
769                     rleader = 1;
770                 }
771                 else {
772                     /* Remote leader is signficant only for the processes
773                      * designated local leaders */
774                     rleader = -1;
775                 }
776                 *isLeftGroup = rank < size / 2;
777                 if (rank != 0) {        /* 0's mcomm is MPI_COMM_NULL */
778                     merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12345, comm);
779                     if (merr)
780                         MTestPrintError(merr);
781                 }
782                 interCommName =
783                     "Intercomm by splitting MPI_COMM_WORLD (discarding rank 0 in the left group) then MPI_Intercomm_create'ing";
784             }
785             else {
786                 *comm = MPI_COMM_NULL;
787             }
788             break;
789
790         case 6:
791             /* Split comm world in half then form them into an
792              * intercommunicator.  Then discard rank 0 from each group of the
793              * intercomm via MPI_Comm_create. */
794             merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
795             if (merr)
796                 MTestPrintError(merr);
797             merr = MPI_Comm_size(MPI_COMM_WORLD, &size);
798             if (merr)
799                 MTestPrintError(merr);
800             if (size >= 4) {
801                 MPI_Group oldgroup, newgroup;
802                 int ranks[1];
803                 int color = (rank < size / 2 ? 0 : 1);
804
805                 merr = MPI_Comm_split(MPI_COMM_WORLD, color, rank, &mcomm);
806                 if (merr)
807                     MTestPrintError(merr);
808
809                 if (rank == 0) {
810                     rleader = size / 2;
811                 }
812                 else if (rank == (size / 2)) {
813                     rleader = 0;
814                 }
815                 else {
816                     /* Remote leader is signficant only for the processes
817                      * designated local leaders */
818                     rleader = -1;
819                 }
820                 *isLeftGroup = rank < size / 2;
821                 merr = MPI_Intercomm_create(mcomm, 0, MPI_COMM_WORLD, rleader, 12345, &mcomm2);
822                 if (merr)
823                     MTestPrintError(merr);
824
825                 /* We have an intercomm between the two halves of comm world. Now create
826                  * a new intercomm that removes rank 0 on each side. */
827                 merr = MPI_Comm_group(mcomm2, &oldgroup);
828                 if (merr)
829                     MTestPrintError(merr);
830                 ranks[0] = 0;
831                 merr = MPI_Group_excl(oldgroup, 1, ranks, &newgroup);
832                 if (merr)
833                     MTestPrintError(merr);
834                 merr = MPI_Comm_create(mcomm2, newgroup, comm);
835                 if (merr)
836                     MTestPrintError(merr);
837
838                 merr = MPI_Group_free(&oldgroup);
839                 if (merr)
840                     MTestPrintError(merr);
841                 merr = MPI_Group_free(&newgroup);
842                 if (merr)
843                     MTestPrintError(merr);
844
845                 interCommName =
846                     "Intercomm by splitting MPI_COMM_WORLD then discarding 0 ranks with MPI_Comm_create";
847             }
848             else {
849                 *comm = MPI_COMM_NULL;
850             }
851             break;
852
853         default:
854             *comm = MPI_COMM_NULL;
855             interCommIdx = -1;
856             break;
857         }
858
859         if (*comm != MPI_COMM_NULL) {
860             merr = MPI_Comm_size(*comm, &size);
861             if (merr)
862                 MTestPrintError(merr);
863             merr = MPI_Comm_remote_size(*comm, &remsize);
864             if (merr)
865                 MTestPrintError(merr);
866             if (size + remsize >= min_size)
867                 done = 1;
868         }
869         else {
870             interCommName = "MPI_COMM_NULL";
871             done = 1;
872         }
873
874         /* we are only done if all processes are done */
875         MPI_Allreduce(MPI_IN_PLACE, &done, 1, MPI_INT, MPI_LAND, MPI_COMM_WORLD);
876
877         /* Advance the comm index whether we are done or not, otherwise we could
878          * spin forever trying to allocate a too-small communicator over and
879          * over again. */
880         interCommIdx++;
881
882         if (!done && *comm != MPI_COMM_NULL) {
883             /* avoid leaking communicators */
884             merr = MPI_Comm_free(comm);
885             if (merr)
886                 MTestPrintError(merr);
887         }
888
889         /* cleanup for common temp objects */
890         if (mcomm != MPI_COMM_NULL) {
891             merr = MPI_Comm_free(&mcomm);
892             if (merr)
893                 MTestPrintError(merr);
894         }
895         if (mcomm2 != MPI_COMM_NULL) {
896             merr = MPI_Comm_free(&mcomm2);
897             if (merr)
898                 MTestPrintError(merr);
899         }
900     }
901
902     return interCommIdx;
903 }
904
905 int MTestTestIntercomm(MPI_Comm comm)
906 {
907     int local_size, remote_size, rank, **bufs, *bufmem, rbuf[2], j;
908     int errs = 0, wrank, nsize;
909     char commname[MPI_MAX_OBJECT_NAME + 1];
910     MPI_Request *reqs;
911
912     MPI_Comm_rank(MPI_COMM_WORLD, &wrank);
913     MPI_Comm_size(comm, &local_size);
914     MPI_Comm_remote_size(comm, &remote_size);
915     MPI_Comm_rank(comm, &rank);
916     MPI_Comm_get_name(comm, commname, &nsize);
917
918     MTestPrintfMsg(1, "Testing communication on intercomm '%s', remote_size=%d\n",
919                    commname, remote_size);
920
921     reqs = (MPI_Request *) malloc(remote_size * sizeof(MPI_Request));
922     if (!reqs) {
923         printf("[%d] Unable to allocated %d requests for testing intercomm %s\n",
924                wrank, remote_size, commname);
925         errs++;
926         return errs;
927     }
928     bufs = (int **) malloc(remote_size * sizeof(int *));
929     if (!bufs) {
930         printf("[%d] Unable to allocated %d int pointers for testing intercomm %s\n",
931                wrank, remote_size, commname);
932         errs++;
933         return errs;
934     }
935     bufmem = (int *) malloc(remote_size * 2 * sizeof(int));
936     if (!bufmem) {
937         printf("[%d] Unable to allocated %d int data for testing intercomm %s\n",
938                wrank, 2 * remote_size, commname);
939         errs++;
940         return errs;
941     }
942
943     /* Each process sends a message containing its own rank and the
944      * rank of the destination with a nonblocking send.  Because we're using
945      * nonblocking sends, we need to use different buffers for each isend */
946     /* NOTE: the send buffer access restriction was relaxed in MPI-2.2, although
947      * it doesn't really hurt to keep separate buffers for our purposes */
948     for (j = 0; j < remote_size; j++) {
949         bufs[j] = &bufmem[2 * j];
950         bufs[j][0] = rank;
951         bufs[j][1] = j;
952         MPI_Isend(bufs[j], 2, MPI_INT, j, 0, comm, &reqs[j]);
953     }
954     MTestPrintfMsg(2, "isends posted, about to recv\n");
955
956     for (j = 0; j < remote_size; j++) {
957         MPI_Recv(rbuf, 2, MPI_INT, j, 0, comm, MPI_STATUS_IGNORE);
958         if (rbuf[0] != j) {
959             printf("[%d] Expected rank %d but saw %d in %s\n", wrank, j, rbuf[0], commname);
960             errs++;
961         }
962         if (rbuf[1] != rank) {
963             printf("[%d] Expected target rank %d but saw %d from %d in %s\n",
964                    wrank, rank, rbuf[1], j, commname);
965             errs++;
966         }
967     }
968     if (errs)
969         fflush(stdout);
970
971     MTestPrintfMsg(2, "my recvs completed, about to waitall\n");
972     MPI_Waitall(remote_size, reqs, MPI_STATUSES_IGNORE);
973
974     free(reqs);
975     free(bufs);
976     free(bufmem);
977
978     return errs;
979 }
980
981 int MTestTestIntracomm(MPI_Comm comm)
982 {
983     int i, errs = 0;
984     int size;
985     int in[16], out[16], sol[16];
986
987     MPI_Comm_size(comm, &size);
988
989     /* Set input, output and sol-values */
990     for (i = 0; i < 16; i++) {
991         in[i] = i;
992         out[i] = 0;
993         sol[i] = i * size;
994     }
995     MPI_Allreduce(in, out, 16, MPI_INT, MPI_SUM, comm);
996
997     /* Test results */
998     for (i = 0; i < 16; i++) {
999         if (sol[i] != out[i])
1000             errs++;
1001     }
1002
1003     return errs;
1004 }
1005
1006 int MTestTestComm(MPI_Comm comm)
1007 {
1008     int is_inter;
1009
1010     if (comm == MPI_COMM_NULL)
1011         return 0;
1012
1013     MPI_Comm_test_inter(comm, &is_inter);
1014
1015     if (is_inter)
1016         return MTestTestIntercomm(comm);
1017     else
1018         return MTestTestIntracomm(comm);
1019 }
1020
1021 /* Return the name of an intercommunicator */
1022 const char *MTestGetIntercommName(void)
1023 {
1024     return interCommName;
1025 }
1026
1027 /* Get a communicator of a given minimum size.  Both intra and inter
1028    communicators are provided */
1029 int MTestGetComm(MPI_Comm * comm, int min_size)
1030 {
1031     int idx = 0;
1032     static int getinter = 0;
1033
1034     if (!getinter) {
1035         idx = MTestGetIntracomm(comm, min_size);
1036         if (idx == 0) {
1037             getinter = 1;
1038         }
1039     }
1040     if (getinter) {
1041         int isLeft;
1042         idx = MTestGetIntercomm(comm, &isLeft, min_size);
1043         if (idx == 0) {
1044             getinter = 0;
1045         }
1046     }
1047
1048     return idx;
1049 }
1050
1051 /* Free a communicator.  It may be called with a predefined communicator
1052  or MPI_COMM_NULL */
1053 void MTestFreeComm(MPI_Comm * comm)
1054 {
1055     int merr;
1056     if (*comm != MPI_COMM_WORLD && *comm != MPI_COMM_SELF && *comm != MPI_COMM_NULL) {
1057         merr = MPI_Comm_free(comm);
1058         if (merr)
1059             MTestPrintError(merr);
1060     }
1061 }
1062
1063 /* ------------------------------------------------------------------------ */
1064 void MTestPrintError(int errcode)
1065 {
1066     int errclass, slen;
1067     char string[MPI_MAX_ERROR_STRING];
1068
1069     MPI_Error_class(errcode, &errclass);
1070     MPI_Error_string(errcode, string, &slen);
1071     printf("Error class %d (%s)\n", errclass, string);
1072     fflush(stdout);
1073 }
1074
1075 void MTestPrintErrorMsg(const char msg[], int errcode)
1076 {
1077     int errclass, slen;
1078     char string[MPI_MAX_ERROR_STRING];
1079
1080     MPI_Error_class(errcode, &errclass);
1081     MPI_Error_string(errcode, string, &slen);
1082     printf("%s: Error class %d (%s)\n", msg, errclass, string);
1083     fflush(stdout);
1084 }
1085
1086 /* ------------------------------------------------------------------------ */
1087 /*
1088  If verbose output is selected and the level is at least that of the
1089  value of the verbose flag, then perform printf(format, ...);
1090  */
1091 void MTestPrintfMsg(int level, const char format[], ...)
1092 {
1093     va_list list;
1094
1095     if (SMPI_VARGET_GLOBAL(verbose) && level <= SMPI_VARGET_GLOBAL(verbose)) {
1096         va_start(list, format);
1097         vprintf(format, list);
1098         va_end(list);
1099         fflush(stdout);
1100     }
1101 }
1102
1103 /* Fatal error.  Report and exit */
1104 void MTestError(const char *msg)
1105 {
1106     fprintf(stderr, "%s\n", msg);
1107     fflush(stderr);
1108     MPI_Abort(MPI_COMM_WORLD, 1);
1109 }
1110
1111 /* ------------------------------------------------------------------------ */
1112 static void MTestResourceSummary(FILE * fp)
1113 {
1114 #ifdef HAVE_GETRUSAGE
1115     struct rusage ru;
1116     static int pfThreshold = -2;
1117     int doOutput = 1;
1118     if (getrusage(RUSAGE_SELF, &ru) == 0) {
1119         /* There is an option to generate output only when a resource
1120          * exceeds a threshold.  To date, only page faults supported. */
1121         if (pfThreshold == -2) {
1122             char *p = getenv("MPITEST_RUSAGE_PF");
1123             pfThreshold = -1;
1124             if (p) {
1125                 pfThreshold = strtol(p, 0, 0);
1126             }
1127         }
1128         if (pfThreshold > 0) {
1129             doOutput = ru.ru_minflt > pfThreshold;
1130         }
1131         if (doOutput) {
1132             /* Cast values to long in case some system has defined them
1133              * as another integer type */
1134             fprintf(fp, "RUSAGE: max resident set = %ldKB\n", (long) ru.ru_maxrss);
1135             fprintf(fp, "RUSAGE: page faults = %ld : %ld\n",
1136                     (long) ru.ru_minflt, (long) ru.ru_majflt);
1137             /* Not every Unix provides useful information for the xxrss fields */
1138             fprintf(fp, "RUSAGE: memory in text/data/stack = %ld : %ld : %ld\n",
1139                     (long) ru.ru_ixrss, (long) ru.ru_idrss, (long) ru.ru_isrss);
1140             fprintf(fp, "RUSAGE: I/O in and out = %ld : %ld\n",
1141                     (long) ru.ru_inblock, (long) ru.ru_oublock);
1142             fprintf(fp, "RUSAGE: context switch = %ld : %ld\n",
1143                     (long) ru.ru_nvcsw, (long) ru.ru_nivcsw);
1144         }
1145     }
1146     else {
1147         fprintf(fp, "RUSAGE: return error %d\n", errno);
1148     }
1149 #endif
1150 }
1151
1152 /* ------------------------------------------------------------------------ */
1153 #ifdef HAVE_MPI_WIN_CREATE
1154 /*
1155  * Create MPI Windows
1156  */
1157 static int win_index = 0;
1158 static const char *winName;
1159 /* Use an attribute to remember the type of memory allocation (static,
1160    malloc, or MPI_Alloc_mem) */
1161 static int mem_keyval = MPI_KEYVAL_INVALID;
1162 int MTestGetWin(MPI_Win * win, int mustBePassive)
1163 {
1164     static char actbuf[1024];
1165     static char *pasbuf;
1166     char *buf;
1167     int n, rank, merr;
1168     MPI_Info info;
1169
1170     if (mem_keyval == MPI_KEYVAL_INVALID) {
1171         /* Create the keyval */
1172         merr = MPI_Win_create_keyval(MPI_WIN_NULL_COPY_FN, MPI_WIN_NULL_DELETE_FN, &mem_keyval, 0);
1173         if (merr)
1174             MTestPrintError(merr);
1175
1176     }
1177
1178     switch (win_index) {
1179     case 0:
1180         /* Active target window */
1181         merr = MPI_Win_create(actbuf, 1024, 1, MPI_INFO_NULL, MPI_COMM_WORLD, win);
1182         if (merr)
1183             MTestPrintError(merr);
1184         winName = "active-window";
1185         merr = MPI_Win_set_attr(*win, mem_keyval, (void *) 0);
1186         if (merr)
1187             MTestPrintError(merr);
1188         break;
1189     case 1:
1190         /* Passive target window */
1191         merr = MPI_Alloc_mem(1024, MPI_INFO_NULL, &pasbuf);
1192         if (merr)
1193             MTestPrintError(merr);
1194         merr = MPI_Win_create(pasbuf, 1024, 1, MPI_INFO_NULL, MPI_COMM_WORLD, win);
1195         if (merr)
1196             MTestPrintError(merr);
1197         winName = "passive-window";
1198         merr = MPI_Win_set_attr(*win, mem_keyval, (void *) 2);
1199         if (merr)
1200             MTestPrintError(merr);
1201         break;
1202     case 2:
1203         /* Active target; all windows different sizes */
1204         merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
1205         if (merr)
1206             MTestPrintError(merr);
1207         n = rank * 64;
1208         if (n)
1209             buf = (char *) malloc(n);
1210         else
1211             buf = 0;
1212         merr = MPI_Win_create(buf, n, 1, MPI_INFO_NULL, MPI_COMM_WORLD, win);
1213         if (merr)
1214             MTestPrintError(merr);
1215         winName = "active-all-different-win";
1216         merr = MPI_Win_set_attr(*win, mem_keyval, (void *) 1);
1217         if (merr)
1218             MTestPrintError(merr);
1219         break;
1220     case 3:
1221         /* Active target, no locks set */
1222         merr = MPI_Comm_rank(MPI_COMM_WORLD, &rank);
1223         if (merr)
1224             MTestPrintError(merr);
1225         n = rank * 64;
1226         if (n)
1227             buf = (char *) malloc(n);
1228         else
1229             buf = 0;
1230         merr = MPI_Info_create(&info);
1231         if (merr)
1232             MTestPrintError(merr);
1233         merr = MPI_Info_set(info, (char *) "nolocks", (char *) "true");
1234         if (merr)
1235             MTestPrintError(merr);
1236         merr = MPI_Win_create(buf, n, 1, info, MPI_COMM_WORLD, win);
1237         if (merr)
1238             MTestPrintError(merr);
1239         merr = MPI_Info_free(&info);
1240         if (merr)
1241             MTestPrintError(merr);
1242         winName = "active-nolocks-all-different-win";
1243         merr = MPI_Win_set_attr(*win, mem_keyval, (void *) 1);
1244         if (merr)
1245             MTestPrintError(merr);
1246         break;
1247     default:
1248         win_index = -1;
1249     }
1250     win_index++;
1251     return win_index;
1252 }
1253
1254 /* Return a pointer to the name associated with a window object */
1255 const char *MTestGetWinName(void)
1256 {
1257     return winName;
1258 }
1259
1260 /* Free the storage associated with a window object */
1261 void MTestFreeWin(MPI_Win * win)
1262 {
1263     void *addr;
1264     int flag, merr;
1265
1266     merr = MPI_Win_get_attr(*win, MPI_WIN_BASE, &addr, &flag);
1267     if (merr)
1268         MTestPrintError(merr);
1269     if (!flag) {
1270         MTestError("Could not get WIN_BASE from window");
1271     }
1272     if (addr) {
1273         void *val;
1274         merr = MPI_Win_get_attr(*win, mem_keyval, &val, &flag);
1275         if (merr)
1276             MTestPrintError(merr);
1277         if (flag) {
1278             if (val == (void *) 1) {
1279                 free(addr);
1280             }
1281             else if (val == (void *) 2) {
1282                 merr = MPI_Free_mem(addr);
1283                 if (merr)
1284                     MTestPrintError(merr);
1285             }
1286             /* if val == (void *)0, then static data that must not be freed */
1287         }
1288     }
1289     merr = MPI_Win_free(win);
1290     if (merr)
1291         MTestPrintError(merr);
1292 }
1293
1294 static void MTestRMACleanup(void)
1295 {
1296     if (mem_keyval != MPI_KEYVAL_INVALID) {
1297         MPI_Win_free_keyval(&mem_keyval);
1298     }
1299 }
1300 #else
1301 static void MTestRMACleanup(void)
1302 {
1303 }
1304 #endif
1305
1306 /* ------------------------------------------------------------------------ */
1307 /* This function determines if it is possible to spawn addition MPI
1308  * processes using MPI_COMM_SPAWN and MPI_COMM_SPAWN_MULTIPLE.
1309  *
1310  * It sets the can_spawn value to one of the following:
1311  * 1  = yes, additional processes can be spawned
1312  * 0  = no, MPI_UNIVERSE_SIZE <= the size of MPI_COMM_WORLD
1313  * -1 = it is unknown whether or not processes can be spawned
1314  *      due to errors in the necessary query functions
1315  *
1316  */
1317 int MTestSpawnPossible(int *can_spawn)
1318 {
1319     int errs = 0;
1320
1321     void *v = NULL;
1322     int flag = -1;
1323     int vval = -1;
1324     int rc;
1325
1326     rc = MPI_Comm_get_attr(MPI_COMM_WORLD, MPI_UNIVERSE_SIZE, &v, &flag);
1327     if (rc != MPI_SUCCESS) {
1328         /* MPI_UNIVERSE_SIZE keyval missing from MPI_COMM_WORLD attributes */
1329         *can_spawn = -1;
1330         errs++;
1331     }
1332     else {
1333         /* MPI_UNIVERSE_SIZE need not be set */
1334         if (flag) {
1335
1336             int size = -1;
1337             rc = MPI_Comm_size(MPI_COMM_WORLD, &size);
1338             if (rc != MPI_SUCCESS) {
1339                 /* MPI_Comm_size failed for MPI_COMM_WORLD */
1340                 *can_spawn = -1;
1341                 errs++;
1342             }
1343
1344             vval = *(int *) v;
1345             if (vval <= size) {
1346                 /* no additional processes can be spawned */
1347                 *can_spawn = 0;
1348             }
1349             else {
1350                 *can_spawn = 1;
1351             }
1352         }
1353         else {
1354             /* No attribute associated with key MPI_UNIVERSE_SIZE of MPI_COMM_WORLD */
1355             *can_spawn = -1;
1356         }
1357     }
1358     return errs;
1359 }
1360
1361 /* ------------------------------------------------------------------------ */