Actual source code: comm.c
2: /***********************************comm.c*************************************
4: Author: Henry M. Tufo III
6: e-mail: hmt@cs.brown.edu
8: snail-mail:
9: Division of Applied Mathematics
10: Brown University
11: Providence, RI 02912
13: Last Modification:
14: 11.21.97
15: ***********************************comm.c*************************************/
16: #include <../src/ksp/pc/impls/tfs/tfs.h>
19: /* global program control variables - explicitly exported */
20: PetscMPIInt my_id = 0;
21: PetscMPIInt num_nodes = 1;
22: PetscMPIInt floor_num_nodes = 0;
23: PetscMPIInt i_log2_num_nodes = 0;
25: /* global program control variables */
26: static PetscInt p_init = 0;
27: static PetscInt modfl_num_nodes;
28: static PetscInt edge_not_pow_2;
30: static PetscInt edge_node[sizeof(PetscInt)*32];
32: /***********************************comm.c*************************************/
33: PetscErrorCode comm_init (void)
34: {
36: if (p_init++) return(0);
38: MPI_Comm_size(MPI_COMM_WORLD,&num_nodes);
39: MPI_Comm_rank(MPI_COMM_WORLD,&my_id);
41: if (num_nodes> (INT_MAX >> 1)) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"Can't have more then MAX_INT/2 nodes!!!");
43: ivec_zero((PetscInt*)edge_node,sizeof(PetscInt)*32);
45: floor_num_nodes = 1;
46: i_log2_num_nodes = modfl_num_nodes = 0;
47: while (floor_num_nodes <= num_nodes)
48: {
49: edge_node[i_log2_num_nodes] = my_id ^ floor_num_nodes;
50: floor_num_nodes <<= 1;
51: i_log2_num_nodes++;
52: }
54: i_log2_num_nodes--;
55: floor_num_nodes >>= 1;
56: modfl_num_nodes = (num_nodes - floor_num_nodes);
58: if ((my_id > 0) && (my_id <= modfl_num_nodes))
59: {edge_not_pow_2=((my_id|floor_num_nodes)-1);}
60: else if (my_id >= floor_num_nodes)
61: {edge_not_pow_2=((my_id^floor_num_nodes)+1);
62: }
63: else
64: {edge_not_pow_2 = 0;}
65: return(0);
66: }
68: /***********************************comm.c*************************************/
69: PetscErrorCode giop(PetscInt *vals, PetscInt *work, PetscInt n, PetscInt *oprs)
70: {
71: PetscInt mask, edge;
72: PetscInt type, dest;
73: vfp fp;
74: MPI_Status status;
75: PetscInt ierr;
78: /* ok ... should have some data, work, and operator(s) */
79: if (!vals||!work||!oprs) SETERRQ3(PETSC_COMM_SELF,PETSC_ERR_PLIB,"giop() :: vals=%D, work=%D, oprs=%D",vals,work,oprs);
81: /* non-uniform should have at least two entries */
82: if ((oprs[0] == NON_UNIFORM)&&(n<2)) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"giop() :: non_uniform and n=0,1?");
84: /* check to make sure comm package has been initialized */
85: if (!p_init)
86: {comm_init();}
88: /* if there's nothing to do return */
89: if ((num_nodes<2)||(!n))
90: {
91: return(0);
92: }
95: /* a negative number if items to send ==> fatal */
96: if (n<0) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_PLIB,"giop() :: n=%D<0?",n);
98: /* advance to list of n operations for custom */
99: if ((type=oprs[0])==NON_UNIFORM)
100: {oprs++;}
102: /* major league hack */
103: if (!(fp = (vfp) ivec_fct_addr(type))) {
104: PetscInfo(0,"giop() :: hope you passed in a rbfp!\n");
105: fp = (vfp) oprs;
106: }
108: /* all msgs will be of the same length */
109: /* if not a hypercube must colapse partial dim */
110: if (edge_not_pow_2)
111: {
112: if (my_id >= floor_num_nodes)
113: {MPI_Send(vals,n,MPIU_INT,edge_not_pow_2,MSGTAG0+my_id,MPI_COMM_WORLD);}
114: else
115: {
116: MPI_Recv(work,n,MPIU_INT,MPI_ANY_SOURCE,MSGTAG0+edge_not_pow_2, MPI_COMM_WORLD,&status);
117: (*fp)(vals,work,n,oprs);
118: }
119: }
121: /* implement the mesh fan in/out exchange algorithm */
122: if (my_id<floor_num_nodes)
123: {
124: for (mask=1,edge=0; edge<i_log2_num_nodes; edge++,mask<<=1)
125: {
126: dest = my_id^mask;
127: if (my_id > dest)
128: {MPI_Send(vals,n,MPIU_INT,dest,MSGTAG2+my_id,MPI_COMM_WORLD);}
129: else
130: {
131: MPI_Recv(work,n,MPIU_INT,MPI_ANY_SOURCE,MSGTAG2+dest,MPI_COMM_WORLD, &status);
132: (*fp)(vals, work, n, oprs);
133: }
134: }
136: mask=floor_num_nodes>>1;
137: for (edge=0; edge<i_log2_num_nodes; edge++,mask>>=1)
138: {
139: if (my_id%mask)
140: {continue;}
141:
142: dest = my_id^mask;
143: if (my_id < dest)
144: {MPI_Send(vals,n,MPIU_INT,dest,MSGTAG4+my_id,MPI_COMM_WORLD);}
145: else
146: {
147: MPI_Recv(vals,n,MPIU_INT,MPI_ANY_SOURCE,MSGTAG4+dest,MPI_COMM_WORLD, &status);
148: }
149: }
150: }
152: /* if not a hypercube must expand to partial dim */
153: if (edge_not_pow_2)
154: {
155: if (my_id >= floor_num_nodes)
156: {
157: MPI_Recv(vals,n,MPIU_INT,MPI_ANY_SOURCE,MSGTAG5+edge_not_pow_2,MPI_COMM_WORLD,&status);
158: }
159: else
160: {MPI_Send(vals,n,MPIU_INT,edge_not_pow_2,MSGTAG5+my_id,MPI_COMM_WORLD);}
161: }
162: return(0);
163: }
165: /***********************************comm.c*************************************/
166: PetscErrorCode grop(PetscScalar *vals, PetscScalar *work, PetscInt n, PetscInt *oprs)
167: {
168: PetscInt mask, edge;
169: PetscInt type, dest;
170: vfp fp;
171: MPI_Status status;
175: /* ok ... should have some data, work, and operator(s) */
176: if (!vals||!work||!oprs) SETERRQ3(PETSC_COMM_SELF,PETSC_ERR_PLIB,"grop() :: vals=%D, work=%D, oprs=%D",vals,work,oprs);
178: /* non-uniform should have at least two entries */
179: if ((oprs[0] == NON_UNIFORM)&&(n<2)) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"grop() :: non_uniform and n=0,1?");
181: /* check to make sure comm package has been initialized */
182: if (!p_init)
183: {comm_init();}
185: /* if there's nothing to do return */
186: if ((num_nodes<2)||(!n))
187: { return(0);}
189: /* a negative number of items to send ==> fatal */
190: if (n<0) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_PLIB,"gdop() :: n=%D<0?",n);
192: /* advance to list of n operations for custom */
193: if ((type=oprs[0])==NON_UNIFORM)
194: {oprs++;}
196: if (!(fp = (vfp) rvec_fct_addr(type))) {
197: PetscInfo(0,"grop() :: hope you passed in a rbfp!\n");
198: fp = (vfp) oprs;
199: }
201: /* all msgs will be of the same length */
202: /* if not a hypercube must colapse partial dim */
203: if (edge_not_pow_2)
204: {
205: if (my_id >= floor_num_nodes)
206: {MPI_Send(vals,n,MPIU_SCALAR,edge_not_pow_2,MSGTAG0+my_id,MPI_COMM_WORLD);}
207: else
208: {
209: MPI_Recv(work,n,MPIU_SCALAR,MPI_ANY_SOURCE,MSGTAG0+edge_not_pow_2,MPI_COMM_WORLD,&status);
210: (*fp)(vals,work,n,oprs);
211: }
212: }
214: /* implement the mesh fan in/out exchange algorithm */
215: if (my_id<floor_num_nodes)
216: {
217: for (mask=1,edge=0; edge<i_log2_num_nodes; edge++,mask<<=1)
218: {
219: dest = my_id^mask;
220: if (my_id > dest)
221: {MPI_Send(vals,n,MPIU_SCALAR,dest,MSGTAG2+my_id,MPI_COMM_WORLD);}
222: else
223: {
224: MPI_Recv(work,n,MPIU_SCALAR,MPI_ANY_SOURCE,MSGTAG2+dest,MPI_COMM_WORLD, &status);
225: (*fp)(vals, work, n, oprs);
226: }
227: }
229: mask=floor_num_nodes>>1;
230: for (edge=0; edge<i_log2_num_nodes; edge++,mask>>=1)
231: {
232: if (my_id%mask)
233: {continue;}
234:
235: dest = my_id^mask;
236: if (my_id < dest)
237: {MPI_Send(vals,n,MPIU_SCALAR,dest,MSGTAG4+my_id,MPI_COMM_WORLD);}
238: else
239: {
240: MPI_Recv(vals,n,MPIU_SCALAR,MPI_ANY_SOURCE,MSGTAG4+dest,MPI_COMM_WORLD, &status);
241: }
242: }
243: }
245: /* if not a hypercube must expand to partial dim */
246: if (edge_not_pow_2)
247: {
248: if (my_id >= floor_num_nodes)
249: {
250: MPI_Recv(vals,n,MPIU_SCALAR,MPI_ANY_SOURCE,MSGTAG5+edge_not_pow_2, MPI_COMM_WORLD,&status);
251: }
252: else
253: {MPI_Send(vals,n,MPIU_SCALAR,edge_not_pow_2,MSGTAG5+my_id,MPI_COMM_WORLD);}
254: }
255: return(0);
256: }
258: /***********************************comm.c*************************************/
259: PetscErrorCode grop_hc(PetscScalar *vals, PetscScalar *work, PetscInt n, PetscInt *oprs, PetscInt dim)
260: {
261: PetscInt mask, edge;
262: PetscInt type, dest;
263: vfp fp;
264: MPI_Status status;
268: /* ok ... should have some data, work, and operator(s) */
269: if (!vals||!work||!oprs) SETERRQ3(PETSC_COMM_SELF,PETSC_ERR_PLIB,"grop_hc() :: vals=%D, work=%D, oprs=%D",vals,work,oprs);
271: /* non-uniform should have at least two entries */
272: if ((oprs[0] == NON_UNIFORM)&&(n<2)) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"grop_hc() :: non_uniform and n=0,1?");
274: /* check to make sure comm package has been initialized */
275: if (!p_init)
276: {comm_init();}
278: /* if there's nothing to do return */
279: if ((num_nodes<2)||(!n)||(dim<=0))
280: {return(0);}
282: /* the error msg says it all!!! */
283: if (modfl_num_nodes) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"grop_hc() :: num_nodes not a power of 2!?!");
285: /* a negative number of items to send ==> fatal */
286: if (n<0) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_PLIB,"grop_hc() :: n=%D<0?",n);
288: /* can't do more dimensions then exist */
289: dim = PetscMin(dim,i_log2_num_nodes);
291: /* advance to list of n operations for custom */
292: if ((type=oprs[0])==NON_UNIFORM)
293: {oprs++;}
295: if (!(fp = (vfp) rvec_fct_addr(type))) {
296: PetscInfo(0,"grop_hc() :: hope you passed in a rbfp!\n");
297: fp = (vfp) oprs;
298: }
300: for (mask=1,edge=0; edge<dim; edge++,mask<<=1)
301: {
302: dest = my_id^mask;
303: if (my_id > dest)
304: {MPI_Send(vals,n,MPIU_SCALAR,dest,MSGTAG2+my_id,MPI_COMM_WORLD);}
305: else
306: {
307: MPI_Recv(work,n,MPIU_SCALAR,MPI_ANY_SOURCE,MSGTAG2+dest,MPI_COMM_WORLD,&status);
308: (*fp)(vals, work, n, oprs);
309: }
310: }
312: if (edge==dim)
313: {mask>>=1;}
314: else
315: {while (++edge<dim) {mask<<=1;}}
317: for (edge=0; edge<dim; edge++,mask>>=1)
318: {
319: if (my_id%mask)
320: {continue;}
321:
322: dest = my_id^mask;
323: if (my_id < dest)
324: {MPI_Send(vals,n,MPIU_SCALAR,dest,MSGTAG4+my_id,MPI_COMM_WORLD);}
325: else
326: {
327: MPI_Recv(vals,n,MPIU_SCALAR,MPI_ANY_SOURCE,MSGTAG4+dest,MPI_COMM_WORLD,&status);
328: }
329: }
330: return(0);
331: }
333: /******************************************************************************/
334: PetscErrorCode ssgl_radd( PetscScalar *vals, PetscScalar *work, PetscInt level, PetscInt *segs)
335: {
336: PetscInt edge, type, dest, mask;
337: PetscInt stage_n;
338: MPI_Status status;
342: /* check to make sure comm package has been initialized */
343: if (!p_init)
344: {comm_init();}
347: /* all msgs are *NOT* the same length */
348: /* implement the mesh fan in/out exchange algorithm */
349: for (mask=0, edge=0; edge<level; edge++, mask++)
350: {
351: stage_n = (segs[level] - segs[edge]);
352: if (stage_n && !(my_id & mask))
353: {
354: dest = edge_node[edge];
355: type = MSGTAG3 + my_id + (num_nodes*edge);
356: if (my_id>dest)
357: {MPI_Send(vals+segs[edge],stage_n,MPIU_SCALAR,dest,type, MPI_COMM_WORLD);}
358: else
359: {
360: type = type - my_id + dest;
361: MPI_Recv(work,stage_n,MPIU_SCALAR,MPI_ANY_SOURCE,type,MPI_COMM_WORLD,&status);
362: rvec_add(vals+segs[edge], work, stage_n);
363: }
364: }
365: mask <<= 1;
366: }
367: mask>>=1;
368: for (edge=0; edge<level; edge++)
369: {
370: stage_n = (segs[level] - segs[level-1-edge]);
371: if (stage_n && !(my_id & mask))
372: {
373: dest = edge_node[level-edge-1];
374: type = MSGTAG6 + my_id + (num_nodes*edge);
375: if (my_id<dest)
376: {MPI_Send(vals+segs[level-1-edge],stage_n,MPIU_SCALAR,dest,type,MPI_COMM_WORLD);}
377: else
378: {
379: type = type - my_id + dest;
380: MPI_Recv(vals+segs[level-1-edge],stage_n,MPIU_SCALAR, MPI_ANY_SOURCE,type,MPI_COMM_WORLD,&status);
381: }
382: }
383: mask >>= 1;
384: }
385: return(0);
386: }
388: /******************************************************************************/
389: PetscErrorCode new_ssgl_radd( PetscScalar *vals, PetscScalar *work, PetscInt level, PetscInt *segs)
390: {
391: PetscInt edge, type, dest, mask;
392: PetscInt stage_n;
393: MPI_Status status;
397: /* check to make sure comm package has been initialized */
398: if (!p_init)
399: {comm_init();}
401: /* all msgs are *NOT* the same length */
402: /* implement the mesh fan in/out exchange algorithm */
403: for (mask=0, edge=0; edge<level; edge++, mask++)
404: {
405: stage_n = (segs[level] - segs[edge]);
406: if (stage_n && !(my_id & mask))
407: {
408: dest = edge_node[edge];
409: type = MSGTAG3 + my_id + (num_nodes*edge);
410: if (my_id>dest)
411: {MPI_Send(vals+segs[edge],stage_n,MPIU_SCALAR,dest,type, MPI_COMM_WORLD);}
412: else
413: {
414: type = type - my_id + dest;
415: MPI_Recv(work,stage_n,MPIU_SCALAR,MPI_ANY_SOURCE,type, MPI_COMM_WORLD,&status);
416: rvec_add(vals+segs[edge], work, stage_n);
417: }
418: }
419: mask <<= 1;
420: }
421: mask>>=1;
422: for (edge=0; edge<level; edge++)
423: {
424: stage_n = (segs[level] - segs[level-1-edge]);
425: if (stage_n && !(my_id & mask))
426: {
427: dest = edge_node[level-edge-1];
428: type = MSGTAG6 + my_id + (num_nodes*edge);
429: if (my_id<dest)
430: {MPI_Send(vals+segs[level-1-edge],stage_n,MPIU_SCALAR,dest,type,MPI_COMM_WORLD);}
431: else
432: {
433: type = type - my_id + dest;
434: MPI_Recv(vals+segs[level-1-edge],stage_n,MPIU_SCALAR, MPI_ANY_SOURCE,type,MPI_COMM_WORLD,&status);
435: }
436: }
437: mask >>= 1;
438: }
439: return(0);
440: }
442: /***********************************comm.c*************************************/
443: PetscErrorCode giop_hc(PetscInt *vals, PetscInt *work, PetscInt n, PetscInt *oprs, PetscInt dim)
444: {
445: PetscInt mask, edge;
446: PetscInt type, dest;
447: vfp fp;
448: MPI_Status status;
452: /* ok ... should have some data, work, and operator(s) */
453: if (!vals||!work||!oprs) SETERRQ3(PETSC_COMM_SELF,PETSC_ERR_PLIB,"giop_hc() :: vals=%D, work=%D, oprs=%D",vals,work,oprs);
455: /* non-uniform should have at least two entries */
456: if ((oprs[0] == NON_UNIFORM)&&(n<2)) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"giop_hc() :: non_uniform and n=0,1?");
458: /* check to make sure comm package has been initialized */
459: if (!p_init)
460: {comm_init();}
462: /* if there's nothing to do return */
463: if ((num_nodes<2)||(!n)||(dim<=0))
464: { return(0);}
466: /* the error msg says it all!!! */
467: if (modfl_num_nodes) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"giop_hc() :: num_nodes not a power of 2!?!");
469: /* a negative number of items to send ==> fatal */
470: if (n<0) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_PLIB,"giop_hc() :: n=%D<0?",n);
472: /* can't do more dimensions then exist */
473: dim = PetscMin(dim,i_log2_num_nodes);
475: /* advance to list of n operations for custom */
476: if ((type=oprs[0])==NON_UNIFORM)
477: {oprs++;}
479: if (!(fp = (vfp) ivec_fct_addr(type))){
480: PetscInfo(0,"giop_hc() :: hope you passed in a rbfp!\n");
481: fp = (vfp) oprs;
482: }
484: for (mask=1,edge=0; edge<dim; edge++,mask<<=1)
485: {
486: dest = my_id^mask;
487: if (my_id > dest)
488: {MPI_Send(vals,n,MPIU_INT,dest,MSGTAG2+my_id,MPI_COMM_WORLD);}
489: else
490: {
491: MPI_Recv(work,n,MPIU_INT,MPI_ANY_SOURCE,MSGTAG2+dest,MPI_COMM_WORLD, &status);
492: (*fp)(vals, work, n, oprs);
493: }
494: }
496: if (edge==dim)
497: {mask>>=1;}
498: else
499: {while (++edge<dim) {mask<<=1;}}
501: for (edge=0; edge<dim; edge++,mask>>=1)
502: {
503: if (my_id%mask)
504: {continue;}
505:
506: dest = my_id^mask;
507: if (my_id < dest)
508: {MPI_Send(vals,n,MPIU_INT,dest,MSGTAG4+my_id,MPI_COMM_WORLD);}
509: else
510: {
511: MPI_Recv(vals,n,MPIU_INT,MPI_ANY_SOURCE,MSGTAG4+dest,MPI_COMM_WORLD,&status);
512: }
513: }
514: return(0);
515: }