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>

 18: /* global program control variables - explicitly exported */
 19: PetscMPIInt PCTFS_my_id            = 0;
 20: PetscMPIInt PCTFS_num_nodes        = 1;
 21: PetscMPIInt PCTFS_floor_num_nodes  = 0;
 22: PetscMPIInt PCTFS_i_log2_num_nodes = 0;

 24: /* global program control variables */
 25: static PetscInt p_init = 0;
 26: static PetscInt modfl_num_nodes;
 27: static PetscInt edge_not_pow_2;

 29: static PetscInt edge_node[sizeof(PetscInt) * 32];

 31: /***********************************comm.c*************************************/
 32: PetscErrorCode PCTFS_comm_init(void)
 33: {
 34:   PetscFunctionBegin;
 35:   if (p_init++) PetscFunctionReturn(PETSC_SUCCESS);

 37:   PetscCallMPI(MPI_Comm_size(MPI_COMM_WORLD, &PCTFS_num_nodes));
 38:   PetscCallMPI(MPI_Comm_rank(MPI_COMM_WORLD, &PCTFS_my_id));

 40:   PetscCheck(PCTFS_num_nodes <= (INT_MAX >> 1), PETSC_COMM_SELF, PETSC_ERR_PLIB, "Can't have more then MAX_INT/2 nodes!!!");

 42:   PetscCall(PCTFS_ivec_zero((PetscInt *)edge_node, sizeof(PetscInt) * 32));

 44:   PCTFS_floor_num_nodes  = 1;
 45:   PCTFS_i_log2_num_nodes = modfl_num_nodes = 0;
 46:   while (PCTFS_floor_num_nodes <= PCTFS_num_nodes) {
 47:     edge_node[PCTFS_i_log2_num_nodes] = PCTFS_my_id ^ PCTFS_floor_num_nodes;
 48:     PCTFS_floor_num_nodes <<= 1;
 49:     PCTFS_i_log2_num_nodes++;
 50:   }

 52:   PCTFS_i_log2_num_nodes--;
 53:   PCTFS_floor_num_nodes >>= 1;
 54:   modfl_num_nodes = (PCTFS_num_nodes - PCTFS_floor_num_nodes);

 56:   if ((PCTFS_my_id > 0) && (PCTFS_my_id <= modfl_num_nodes)) edge_not_pow_2 = ((PCTFS_my_id | PCTFS_floor_num_nodes) - 1);
 57:   else if (PCTFS_my_id >= PCTFS_floor_num_nodes) edge_not_pow_2 = ((PCTFS_my_id ^ PCTFS_floor_num_nodes) + 1);
 58:   else edge_not_pow_2 = 0;
 59:   PetscFunctionReturn(PETSC_SUCCESS);
 60: }

 62: /***********************************comm.c*************************************/
 63: PetscErrorCode PCTFS_giop(PetscInt *vals, PetscInt *work, PetscInt n, PetscInt *oprs)
 64: {
 65:   PetscInt   mask, edge;
 66:   PetscInt   type, dest;
 67:   vfp        fp;
 68:   MPI_Status status;

 70:   PetscFunctionBegin;
 71:   /* ok ... should have some data, work, and operator(s) */
 72:   PetscCheck(vals && work && oprs, PETSC_COMM_SELF, PETSC_ERR_PLIB, "PCTFS_giop() :: vals=%p, work=%p, oprs=%p", (void *)vals, (void *)work, (void *)oprs);

 74:   /* non-uniform should have at least two entries */
 75:   PetscCheck(!(oprs[0] == NON_UNIFORM) || !(n < 2), PETSC_COMM_SELF, PETSC_ERR_PLIB, "PCTFS_giop() :: non_uniform and n=0,1?");

 77:   /* check to make sure comm package has been initialized */
 78:   if (!p_init) PetscCall(PCTFS_comm_init());

 80:   /* if there's nothing to do return */
 81:   if ((PCTFS_num_nodes < 2) || (!n)) PetscFunctionReturn(PETSC_SUCCESS);

 83:   /* a negative number if items to send ==> fatal */
 84:   PetscCheck(n >= 0, PETSC_COMM_SELF, PETSC_ERR_PLIB, "PCTFS_giop() :: n=%" PetscInt_FMT "<0?", n);

 86:   /* advance to list of n operations for custom */
 87:   if ((type = oprs[0]) == NON_UNIFORM) oprs++;

 89:   /* major league hack */
 90:   PetscCheck(fp = (vfp)PCTFS_ivec_fct_addr(type), PETSC_COMM_SELF, PETSC_ERR_PLIB, "PCTFS_giop() :: Could not retrieve function pointer!");

 92:   /* all msgs will be of the same length */
 93:   /* if not a hypercube must colapse partial dim */
 94:   if (edge_not_pow_2) {
 95:     if (PCTFS_my_id >= PCTFS_floor_num_nodes) {
 96:       PetscCallMPI(MPI_Send(vals, n, MPIU_INT, edge_not_pow_2, MSGTAG0 + PCTFS_my_id, MPI_COMM_WORLD));
 97:     } else {
 98:       PetscCallMPI(MPI_Recv(work, n, MPIU_INT, MPI_ANY_SOURCE, MSGTAG0 + edge_not_pow_2, MPI_COMM_WORLD, &status));
 99:       PetscCall((*fp)(vals, work, n, oprs));
100:     }
101:   }

103:   /* implement the mesh fan in/out exchange algorithm */
104:   if (PCTFS_my_id < PCTFS_floor_num_nodes) {
105:     for (mask = 1, edge = 0; edge < PCTFS_i_log2_num_nodes; edge++, mask <<= 1) {
106:       dest = PCTFS_my_id ^ mask;
107:       if (PCTFS_my_id > dest) {
108:         PetscCallMPI(MPI_Send(vals, n, MPIU_INT, dest, MSGTAG2 + PCTFS_my_id, MPI_COMM_WORLD));
109:       } else {
110:         PetscCallMPI(MPI_Recv(work, n, MPIU_INT, MPI_ANY_SOURCE, MSGTAG2 + dest, MPI_COMM_WORLD, &status));
111:         PetscCall((*fp)(vals, work, n, oprs));
112:       }
113:     }

115:     mask = PCTFS_floor_num_nodes >> 1;
116:     for (edge = 0; edge < PCTFS_i_log2_num_nodes; edge++, mask >>= 1) {
117:       if (PCTFS_my_id % mask) continue;

119:       dest = PCTFS_my_id ^ mask;
120:       if (PCTFS_my_id < dest) {
121:         PetscCallMPI(MPI_Send(vals, n, MPIU_INT, dest, MSGTAG4 + PCTFS_my_id, MPI_COMM_WORLD));
122:       } else {
123:         PetscCallMPI(MPI_Recv(vals, n, MPIU_INT, MPI_ANY_SOURCE, MSGTAG4 + dest, MPI_COMM_WORLD, &status));
124:       }
125:     }
126:   }

128:   /* if not a hypercube must expand to partial dim */
129:   if (edge_not_pow_2) {
130:     if (PCTFS_my_id >= PCTFS_floor_num_nodes) {
131:       PetscCallMPI(MPI_Recv(vals, n, MPIU_INT, MPI_ANY_SOURCE, MSGTAG5 + edge_not_pow_2, MPI_COMM_WORLD, &status));
132:     } else {
133:       PetscCallMPI(MPI_Send(vals, n, MPIU_INT, edge_not_pow_2, MSGTAG5 + PCTFS_my_id, MPI_COMM_WORLD));
134:     }
135:   }
136:   PetscFunctionReturn(PETSC_SUCCESS);
137: }

139: /***********************************comm.c*************************************/
140: PetscErrorCode PCTFS_grop(PetscScalar *vals, PetscScalar *work, PetscInt n, PetscInt *oprs)
141: {
142:   PetscInt   mask, edge;
143:   PetscInt   type, dest;
144:   vfp        fp;
145:   MPI_Status status;

147:   PetscFunctionBegin;
148:   /* ok ... should have some data, work, and operator(s) */
149:   PetscCheck(vals && work && oprs, PETSC_COMM_SELF, PETSC_ERR_PLIB, "PCTFS_grop() :: vals=%p, work=%p, oprs=%p", (void *)vals, (void *)work, (void *)oprs);

151:   /* non-uniform should have at least two entries */
152:   PetscCheck(!(oprs[0] == NON_UNIFORM) || !(n < 2), PETSC_COMM_SELF, PETSC_ERR_PLIB, "PCTFS_grop() :: non_uniform and n=0,1?");

154:   /* check to make sure comm package has been initialized */
155:   if (!p_init) PetscCall(PCTFS_comm_init());

157:   /* if there's nothing to do return */
158:   if ((PCTFS_num_nodes < 2) || (!n)) PetscFunctionReturn(PETSC_SUCCESS);

160:   /* a negative number of items to send ==> fatal */
161:   PetscCheck(n >= 0, PETSC_COMM_SELF, PETSC_ERR_PLIB, "gdop() :: n=%" PetscInt_FMT "<0?", n);

163:   /* advance to list of n operations for custom */
164:   if ((type = oprs[0]) == NON_UNIFORM) oprs++;

166:   PetscCheck((fp = (vfp)PCTFS_rvec_fct_addr(type)), PETSC_COMM_SELF, PETSC_ERR_PLIB, "PCTFS_grop() :: Could not retrieve function pointer!");

168:   /* all msgs will be of the same length */
169:   /* if not a hypercube must colapse partial dim */
170:   if (edge_not_pow_2) {
171:     if (PCTFS_my_id >= PCTFS_floor_num_nodes) {
172:       PetscCallMPI(MPI_Send(vals, n, MPIU_SCALAR, edge_not_pow_2, MSGTAG0 + PCTFS_my_id, MPI_COMM_WORLD));
173:     } else {
174:       PetscCallMPI(MPI_Recv(work, n, MPIU_SCALAR, MPI_ANY_SOURCE, MSGTAG0 + edge_not_pow_2, MPI_COMM_WORLD, &status));
175:       PetscCall((*fp)(vals, work, n, oprs));
176:     }
177:   }

179:   /* implement the mesh fan in/out exchange algorithm */
180:   if (PCTFS_my_id < PCTFS_floor_num_nodes) {
181:     for (mask = 1, edge = 0; edge < PCTFS_i_log2_num_nodes; edge++, mask <<= 1) {
182:       dest = PCTFS_my_id ^ mask;
183:       if (PCTFS_my_id > dest) {
184:         PetscCallMPI(MPI_Send(vals, n, MPIU_SCALAR, dest, MSGTAG2 + PCTFS_my_id, MPI_COMM_WORLD));
185:       } else {
186:         PetscCallMPI(MPI_Recv(work, n, MPIU_SCALAR, MPI_ANY_SOURCE, MSGTAG2 + dest, MPI_COMM_WORLD, &status));
187:         PetscCall((*fp)(vals, work, n, oprs));
188:       }
189:     }

191:     mask = PCTFS_floor_num_nodes >> 1;
192:     for (edge = 0; edge < PCTFS_i_log2_num_nodes; edge++, mask >>= 1) {
193:       if (PCTFS_my_id % mask) continue;

195:       dest = PCTFS_my_id ^ mask;
196:       if (PCTFS_my_id < dest) {
197:         PetscCallMPI(MPI_Send(vals, n, MPIU_SCALAR, dest, MSGTAG4 + PCTFS_my_id, MPI_COMM_WORLD));
198:       } else {
199:         PetscCallMPI(MPI_Recv(vals, n, MPIU_SCALAR, MPI_ANY_SOURCE, MSGTAG4 + dest, MPI_COMM_WORLD, &status));
200:       }
201:     }
202:   }

204:   /* if not a hypercube must expand to partial dim */
205:   if (edge_not_pow_2) {
206:     if (PCTFS_my_id >= PCTFS_floor_num_nodes) {
207:       PetscCallMPI(MPI_Recv(vals, n, MPIU_SCALAR, MPI_ANY_SOURCE, MSGTAG5 + edge_not_pow_2, MPI_COMM_WORLD, &status));
208:     } else {
209:       PetscCallMPI(MPI_Send(vals, n, MPIU_SCALAR, edge_not_pow_2, MSGTAG5 + PCTFS_my_id, MPI_COMM_WORLD));
210:     }
211:   }
212:   PetscFunctionReturn(PETSC_SUCCESS);
213: }

215: /***********************************comm.c*************************************/
216: PetscErrorCode PCTFS_grop_hc(PetscScalar *vals, PetscScalar *work, PetscInt n, PetscInt *oprs, PetscInt dim)
217: {
218:   PetscInt   mask, edge;
219:   PetscInt   type, dest;
220:   vfp        fp;
221:   MPI_Status status;

223:   PetscFunctionBegin;
224:   /* ok ... should have some data, work, and operator(s) */
225:   PetscCheck(vals && work && oprs, PETSC_COMM_SELF, PETSC_ERR_PLIB, "PCTFS_grop_hc() :: vals=%p, work=%p, oprs=%p", (void *)vals, (void *)work, (void *)oprs);

227:   /* non-uniform should have at least two entries */
228:   PetscCheck(!(oprs[0] == NON_UNIFORM) || !(n < 2), PETSC_COMM_SELF, PETSC_ERR_PLIB, "PCTFS_grop_hc() :: non_uniform and n=0,1?");

230:   /* check to make sure comm package has been initialized */
231:   if (!p_init) PetscCall(PCTFS_comm_init());

233:   /* if there's nothing to do return */
234:   if ((PCTFS_num_nodes < 2) || (!n) || (dim <= 0)) PetscFunctionReturn(PETSC_SUCCESS);

236:   /* the error msg says it all!!! */
237:   PetscCheck(!modfl_num_nodes, PETSC_COMM_SELF, PETSC_ERR_PLIB, "PCTFS_grop_hc() :: PCTFS_num_nodes not a power of 2!?!");

239:   /* a negative number of items to send ==> fatal */
240:   PetscCheck(n >= 0, PETSC_COMM_SELF, PETSC_ERR_PLIB, "PCTFS_grop_hc() :: n=%" PetscInt_FMT "<0?", n);

242:   /* can't do more dimensions then exist */
243:   dim = PetscMin(dim, PCTFS_i_log2_num_nodes);

245:   /* advance to list of n operations for custom */
246:   if ((type = oprs[0]) == NON_UNIFORM) oprs++;

248:   PetscCheck(fp = (vfp)PCTFS_rvec_fct_addr(type), PETSC_COMM_SELF, PETSC_ERR_PLIB, "PCTFS_grop_hc() :: Could not retrieve function pointer!");

250:   for (mask = 1, edge = 0; edge < dim; edge++, mask <<= 1) {
251:     dest = PCTFS_my_id ^ mask;
252:     if (PCTFS_my_id > dest) {
253:       PetscCallMPI(MPI_Send(vals, n, MPIU_SCALAR, dest, MSGTAG2 + PCTFS_my_id, MPI_COMM_WORLD));
254:     } else {
255:       PetscCallMPI(MPI_Recv(work, n, MPIU_SCALAR, MPI_ANY_SOURCE, MSGTAG2 + dest, MPI_COMM_WORLD, &status));
256:       PetscCall((*fp)(vals, work, n, oprs));
257:     }
258:   }

260:   if (edge == dim) mask >>= 1;
261:   else {
262:     while (++edge < dim) mask <<= 1;
263:   }

265:   for (edge = 0; edge < dim; edge++, mask >>= 1) {
266:     if (PCTFS_my_id % mask) continue;

268:     dest = PCTFS_my_id ^ mask;
269:     if (PCTFS_my_id < dest) {
270:       PetscCallMPI(MPI_Send(vals, n, MPIU_SCALAR, dest, MSGTAG4 + PCTFS_my_id, MPI_COMM_WORLD));
271:     } else {
272:       PetscCallMPI(MPI_Recv(vals, n, MPIU_SCALAR, MPI_ANY_SOURCE, MSGTAG4 + dest, MPI_COMM_WORLD, &status));
273:     }
274:   }
275:   PetscFunctionReturn(PETSC_SUCCESS);
276: }

278: /******************************************************************************/
279: PetscErrorCode PCTFS_ssgl_radd(PetscScalar *vals, PetscScalar *work, PetscInt level, PetscInt *segs)
280: {
281:   PetscInt     edge, type, dest, mask;
282:   PetscInt     stage_n;
283:   MPI_Status   status;
284:   PetscMPIInt *maxval, flg;

286:   PetscFunctionBegin;
287:   /* check to make sure comm package has been initialized */
288:   if (!p_init) PetscCall(PCTFS_comm_init());

290:   /* all msgs are *NOT* the same length */
291:   /* implement the mesh fan in/out exchange algorithm */
292:   for (mask = 0, edge = 0; edge < level; edge++, mask++) {
293:     stage_n = (segs[level] - segs[edge]);
294:     if (stage_n && !(PCTFS_my_id & mask)) {
295:       dest = edge_node[edge];
296:       type = MSGTAG3 + PCTFS_my_id + (PCTFS_num_nodes * edge);
297:       if (PCTFS_my_id > dest) {
298:         PetscCallMPI(MPI_Send(vals + segs[edge], stage_n, MPIU_SCALAR, dest, type, MPI_COMM_WORLD));
299:       } else {
300:         type = type - PCTFS_my_id + dest;
301:         PetscCallMPI(MPI_Recv(work, stage_n, MPIU_SCALAR, MPI_ANY_SOURCE, type, MPI_COMM_WORLD, &status));
302:         PetscCall(PCTFS_rvec_add(vals + segs[edge], work, stage_n));
303:       }
304:     }
305:     mask <<= 1;
306:   }
307:   mask >>= 1;
308:   for (edge = 0; edge < level; edge++) {
309:     stage_n = (segs[level] - segs[level - 1 - edge]);
310:     if (stage_n && !(PCTFS_my_id & mask)) {
311:       dest = edge_node[level - edge - 1];
312:       type = MSGTAG6 + PCTFS_my_id + (PCTFS_num_nodes * edge);
313:       PetscCallMPI(MPI_Comm_get_attr(MPI_COMM_WORLD, MPI_TAG_UB, &maxval, &flg));
314:       PetscCheck(flg, PETSC_COMM_SELF, PETSC_ERR_LIB, "MPI error: MPI_Comm_get_attr() is not returning a MPI_TAG_UB");
315:       PetscCheck(*maxval > type, PETSC_COMM_SELF, PETSC_ERR_PLIB, "MPI_TAG_UB for your current MPI implementation is not large enough to use PCTFS");
316:       if (PCTFS_my_id < dest) {
317:         PetscCallMPI(MPI_Send(vals + segs[level - 1 - edge], stage_n, MPIU_SCALAR, dest, type, MPI_COMM_WORLD));
318:       } else {
319:         type = type - PCTFS_my_id + dest;
320:         PetscCallMPI(MPI_Recv(vals + segs[level - 1 - edge], stage_n, MPIU_SCALAR, MPI_ANY_SOURCE, type, MPI_COMM_WORLD, &status));
321:       }
322:     }
323:     mask >>= 1;
324:   }
325:   PetscFunctionReturn(PETSC_SUCCESS);
326: }

328: /***********************************comm.c*************************************/
329: PetscErrorCode PCTFS_giop_hc(PetscInt *vals, PetscInt *work, PetscInt n, PetscInt *oprs, PetscInt dim)
330: {
331:   PetscInt   mask, edge;
332:   PetscInt   type, dest;
333:   vfp        fp;
334:   MPI_Status status;

336:   PetscFunctionBegin;
337:   /* ok ... should have some data, work, and operator(s) */
338:   PetscCheck(vals && work && oprs, PETSC_COMM_SELF, PETSC_ERR_PLIB, "PCTFS_giop_hc() :: vals=%p, work=%p, oprs=%p", (void *)vals, (void *)work, (void *)oprs);

340:   /* non-uniform should have at least two entries */
341:   PetscCheck(!(oprs[0] == NON_UNIFORM) || !(n < 2), PETSC_COMM_SELF, PETSC_ERR_PLIB, "PCTFS_giop_hc() :: non_uniform and n=0,1?");

343:   /* check to make sure comm package has been initialized */
344:   if (!p_init) PetscCall(PCTFS_comm_init());

346:   /* if there's nothing to do return */
347:   if ((PCTFS_num_nodes < 2) || (!n) || (dim <= 0)) PetscFunctionReturn(PETSC_SUCCESS);

349:   /* the error msg says it all!!! */
350:   PetscCheck(!modfl_num_nodes, PETSC_COMM_SELF, PETSC_ERR_PLIB, "PCTFS_giop_hc() :: PCTFS_num_nodes not a power of 2!?!");

352:   /* a negative number of items to send ==> fatal */
353:   PetscCheck(n >= 0, PETSC_COMM_SELF, PETSC_ERR_PLIB, "PCTFS_giop_hc() :: n=%" PetscInt_FMT "<0?", n);

355:   /* can't do more dimensions then exist */
356:   dim = PetscMin(dim, PCTFS_i_log2_num_nodes);

358:   /* advance to list of n operations for custom */
359:   if ((type = oprs[0]) == NON_UNIFORM) oprs++;

361:   PetscCheck(fp = (vfp)PCTFS_ivec_fct_addr(type), PETSC_COMM_SELF, PETSC_ERR_PLIB, "PCTFS_giop_hc() :: Could not retrieve function pointer!");

363:   for (mask = 1, edge = 0; edge < dim; edge++, mask <<= 1) {
364:     dest = PCTFS_my_id ^ mask;
365:     if (PCTFS_my_id > dest) {
366:       PetscCallMPI(MPI_Send(vals, n, MPIU_INT, dest, MSGTAG2 + PCTFS_my_id, MPI_COMM_WORLD));
367:     } else {
368:       PetscCallMPI(MPI_Recv(work, n, MPIU_INT, MPI_ANY_SOURCE, MSGTAG2 + dest, MPI_COMM_WORLD, &status));
369:       PetscCall((*fp)(vals, work, n, oprs));
370:     }
371:   }

373:   if (edge == dim) mask >>= 1;
374:   else {
375:     while (++edge < dim) mask <<= 1;
376:   }

378:   for (edge = 0; edge < dim; edge++, mask >>= 1) {
379:     if (PCTFS_my_id % mask) continue;

381:     dest = PCTFS_my_id ^ mask;
382:     if (PCTFS_my_id < dest) {
383:       PetscCallMPI(MPI_Send(vals, n, MPIU_INT, dest, MSGTAG4 + PCTFS_my_id, MPI_COMM_WORLD));
384:     } else {
385:       PetscCallMPI(MPI_Recv(vals, n, MPIU_INT, MPI_ANY_SOURCE, MSGTAG4 + dest, MPI_COMM_WORLD, &status));
386:     }
387:   }
388:   PetscFunctionReturn(PETSC_SUCCESS);
389: }