1 /*
2 $Id$
3 *======================================================================
4 *
5 * DISCLAIMER
6 *
7 * This material was prepared as an account of work sponsored by an
8 * agency of the United States Government. Neither the United States
9 * Government nor the United States Department of Energy, nor Battelle,
10 * nor any of their employees, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR
11 * ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY,
12 * COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, PRODUCT,
13 * SOFTWARE, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD NOT
14 * INFRINGE PRIVATELY OWNED RIGHTS.
15 *
16 * ACKNOWLEDGMENT
17 *
18 * This software and its documentation were produced with Government
19 * support under Contract Number DE-AC06-76RLO-1830 awarded by the United
20 * States Department of Energy. The Government retains a paid-up
21 * non-exclusive, irrevocable worldwide license to reproduce, prepare
22 * derivative works, perform publicly and display publicly by or for the
23 * Government, including the right to distribute to other Government
24 * contractors.
25 *
26 *======================================================================
27 *
28 * -- PEIGS routine (version 2.1) --
29 * Pacific Northwest Laboratory
30 * July 28, 1995
31 *
32 *======================================================================
33 */
34 /* *****************************************
35
36 PeIGS internal utility
37
38 g_exit_
39
40 global list error exit check
41
42 */
43
44
45 #include <stdio.h>
46 #include <memory.h>
47 #include <math.h>
48 #include <stdlib.h>
49
50 #include "globalp.c.h"
51
52
g_exit2_(n,array,procmap,len,iwork)53 void g_exit2_( n, array, procmap, len, iwork )
54 char *array;
55 Integer *n, *procmap, *len, *iwork;
56 {
57 /*
58
59 An old, out of date version of g_exit_.
60
61 This routine should never be called, use g_exit_ instead. To use
62 g_exit2_ in place og g_exit2_ you just need change the name
63 of g_exit2 to g_exit, and add a DoublePrecision workspace containing
64 at least bufsiz bytes (see cmbbrf.h) to the end of the argument list.
65
66
67 If this routine is called then it prints an error
68 message and aborts program execution.
69
70 */
71
72 Integer me;
73 extern void mxpend_ ();
74 extern Integer mxmynd_();
75
76 me = mxmynd_ ();
77
78 fprintf(stderr, "G_EXIT2: Node %d Error. A routine called g_exit2_, \n", me);
79 fprintf(stderr, "Message from calling routine: %s node id = %d \n", array, me);
80
81 mxpend_ ();
82
83 exit(-1);
84
85 return;
86 }
87
88
g_exit_(n,array,procmap,len,iwork,work)89 void g_exit_( n, array, procmap, len, iwork, work )
90 char *array;
91 Integer *n, *procmap, *len, *iwork;
92 DoublePrecision *work; /* workspace containing at least bufsiz bytes (see cmbbrf.h) */
93 {
94 /*
95 This routine performs a global check on an integer n: if n is negative
96 on any processor in procmap the routine exits with a message from array.
97 n should be less than or equal to 0 on all processors in procmap.
98
99 a global combine is performed on n.
100 if n is less than 0 upon return, a exit is called.
101
102 It is assumed that values in the array map[0:len-1] form the same set
103 of processors (User Beware); for this routine, the ordering in map[0:len-1]
104 is not important.
105
106 if n is not 0 after a global combine then all processors in procmap
107 set *n = -51, print the error message in "array", plus a statement
108 indicating that info = -51 and exits.
109
110 n = integer
111 array = character string for messages
112 procmap = array of processors on which to check n
113 len = length of the array procmap
114
115 WORKSPACE
116 let nproc = Number of unique processor ids in procmap, i.e.,
117 nprocs = reduce_list( *len, procmap, proclist).
118
119 Then:
120
121 iwork = scratch array of length ( *len )
122
123
124 */
125
126 static Integer TYPE = 10;
127 Integer nprocs, me, maxprocs;
128 Integer *iscrat, *proclist;
129
130 extern Integer reduce_list2();
131 extern Integer indxL ();
132 extern Integer mxwrit_ (), mxread_ ();
133 extern Integer qqsort();
134 extern void gi_sum();
135 extern void xerbl2_ ();
136 extern Integer mxcmp();
137 extern void mxpend_ ();
138 extern Integer mxmynd_();
139 extern Integer mxnprc_();
140
141 me = mxmynd_ ();
142 maxprocs = mxnprc_ (); /* the maximum number of processors allocated */
143
144 iscrat = iwork;
145 proclist = iscrat;
146 nprocs = reduce_list2( *len, procmap, proclist);
147 iscrat += nprocs;
148 qqsort( proclist, 0, nprocs-1);
149
150 if ( nprocs > maxprocs ) {
151 fprintf(stderr, "G_EXIT: Node %d Error: Number of processors in Proc List exceeds number allocated \n", me);
152 xerbl2_ ( );
153 return;
154 }
155
156 /*
157 i am actually in the list participating in this check
158 */
159
160 gi_sum( n, 1, TYPE, proclist[0], nprocs, proclist, work);
161
162 if ( *n < 0 ) {
163 *n = -51;
164 fprintf(stderr, " %s My node id = %d info = %d (g_exit_) \n", array, me, *n);
165 /*
166 xerbl2_ ( );
167 */
168 mxpend_ ();
169 exit(-1);
170 }
171 return;
172 }
173
174
gi_sum(buf,items,msgtype,root,snumprocs,plist,work)175 void gi_sum(buf, items, msgtype, root, snumprocs, plist, work)
176 /*
177 this is a integer global sum on buf
178 */
179 Integer *buf;
180 Integer items;
181 Integer msgtype;
182 Integer root;
183 Integer *plist, snumprocs;
184 DoublePrecision *work; /* workspace containing at least bufsiz bytes (see cmbbrf.h) */
185 {
186 Integer isize;
187 extern Integer sumiv_();
188 extern Integer mxcombv1_();
189
190 isize = sizeof(Integer);
191
192 mxcombv1_ ( (char *) buf, sumiv_ , &isize, &items, &snumprocs, plist, &msgtype, (char *)work);
193
194 return;
195 }
196
197
198
199