Actual source code: comm.c

petsc-master 2020-10-26
Report Typos and Errors

  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 PCTFS_my_id            = 0;
 21: PetscMPIInt PCTFS_num_nodes        = 1;
 22: PetscMPIInt PCTFS_floor_num_nodes  = 0;
 23: PetscMPIInt PCTFS_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 PCTFS_comm_init(void)
 34: {

 36:   if (p_init++) return(0);

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

 41:   if (PCTFS_num_nodes> (INT_MAX >> 1)) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"Can't have more then MAX_INT/2 nodes!!!");

 43:   PCTFS_ivec_zero((PetscInt*)edge_node,sizeof(PetscInt)*32);

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

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

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

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

 73:   /* ok ... should have some data, work, and operator(s) */
 74:   if (!vals||!work||!oprs) SETERRQ3(PETSC_COMM_SELF,PETSC_ERR_PLIB,"PCTFS_giop() :: vals=%D, work=%D, oprs=%D",vals,work,oprs);

 76:   /* non-uniform should have at least two entries */
 77:   if ((oprs[0] == NON_UNIFORM)&&(n<2)) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"PCTFS_giop() :: non_uniform and n=0,1?");

 79:   /* check to make sure comm package has been initialized */
 80:   if (!p_init) PCTFS_comm_init();

 82:   /* if there's nothing to do return */
 83:   if ((PCTFS_num_nodes<2)||(!n)) return(0);

 85:   /* a negative number if items to send ==> fatal */
 86:   if (n<0) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_PLIB,"PCTFS_giop() :: n=%D<0?",n);

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

 91:   /* major league hack */
 92:   if (!(fp = (vfp) PCTFS_ivec_fct_addr(type))) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"PCTFS_giop() :: Could not retrieve function pointer!\n");

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

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

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

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

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

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

151:   /* ok ... should have some data, work, and operator(s) */
152:   if (!vals||!work||!oprs) SETERRQ3(PETSC_COMM_SELF,PETSC_ERR_PLIB,"PCTFS_grop() :: vals=%D, work=%D, oprs=%D",vals,work,oprs);

154:   /* non-uniform should have at least two entries */
155:   if ((oprs[0] == NON_UNIFORM)&&(n<2)) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"PCTFS_grop() :: non_uniform and n=0,1?");

157:   /* check to make sure comm package has been initialized */
158:   if (!p_init) PCTFS_comm_init();

160:   /* if there's nothing to do return */
161:   if ((PCTFS_num_nodes<2)||(!n)) return(0);

163:   /* a negative number of items to send ==> fatal */
164:   if (n<0) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_PLIB,"gdop() :: n=%D<0?",n);

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

169:   if (!(fp = (vfp) PCTFS_rvec_fct_addr(type))) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"PCTFS_grop() :: Could not retrieve function pointer!\n");

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

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

194:     mask=PCTFS_floor_num_nodes>>1;
195:     for (edge=0; edge<PCTFS_i_log2_num_nodes; edge++,mask>>=1) {
196:       if (PCTFS_my_id%mask) continue;

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

207:   /* if not a hypercube must expand to partial dim */
208:   if (edge_not_pow_2) {
209:     if (PCTFS_my_id >= PCTFS_floor_num_nodes) {
210:       MPI_Recv(vals,n,MPIU_SCALAR,MPI_ANY_SOURCE,MSGTAG5+edge_not_pow_2, MPI_COMM_WORLD,&status);
211:     } else {
212:       MPI_Send(vals,n,MPIU_SCALAR,edge_not_pow_2,MSGTAG5+PCTFS_my_id,MPI_COMM_WORLD);
213:     }
214:   }
215:   return(0);
216: }

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

228:   /* ok ... should have some data, work, and operator(s) */
229:   if (!vals||!work||!oprs) SETERRQ3(PETSC_COMM_SELF,PETSC_ERR_PLIB,"PCTFS_grop_hc() :: vals=%D, work=%D, oprs=%D",vals,work,oprs);

231:   /* non-uniform should have at least two entries */
232:   if ((oprs[0] == NON_UNIFORM)&&(n<2)) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"PCTFS_grop_hc() :: non_uniform and n=0,1?");

234:   /* check to make sure comm package has been initialized */
235:   if (!p_init) PCTFS_comm_init();

237:   /* if there's nothing to do return */
238:   if ((PCTFS_num_nodes<2)||(!n)||(dim<=0)) return(0);

240:   /* the error msg says it all!!! */
241:   if (modfl_num_nodes) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"PCTFS_grop_hc() :: PCTFS_num_nodes not a power of 2!?!");

243:   /* a negative number of items to send ==> fatal */
244:   if (n<0) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_PLIB,"PCTFS_grop_hc() :: n=%D<0?",n);

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

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

252:   if (!(fp = (vfp) PCTFS_rvec_fct_addr(type))) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"PCTFS_grop_hc() :: Could not retrieve function pointer!\n");

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

264:   if (edge==dim) mask>>=1;
265:   else {
266:     while (++edge<dim) mask<<=1;
267:   }

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

272:     dest = PCTFS_my_id^mask;
273:     if (PCTFS_my_id < dest) {
274:       MPI_Send(vals,n,MPIU_SCALAR,dest,MSGTAG4+PCTFS_my_id,MPI_COMM_WORLD);
275:     } else {
276:       MPI_Recv(vals,n,MPIU_SCALAR,MPI_ANY_SOURCE,MSGTAG4+dest,MPI_COMM_WORLD,&status);
277:     }
278:   }
279:   return(0);
280: }

282: /******************************************************************************/
283: PetscErrorCode PCTFS_ssgl_radd(PetscScalar *vals,  PetscScalar *work,  PetscInt level, PetscInt *segs)
284: {
285:   PetscInt       edge, type, dest, mask;
286:   PetscInt       stage_n;
287:   MPI_Status     status;

291:   /* check to make sure comm package has been initialized */
292:   if (!p_init) PCTFS_comm_init();

294:   /* all msgs are *NOT* the same length */
295:   /* implement the mesh fan in/out exchange algorithm */
296:   for (mask=0, edge=0; edge<level; edge++, mask++) {
297:     stage_n = (segs[level] - segs[edge]);
298:     if (stage_n && !(PCTFS_my_id & mask)) {
299:       dest = edge_node[edge];
300:       type = MSGTAG3 + PCTFS_my_id + (PCTFS_num_nodes*edge);
301:       if (PCTFS_my_id>dest) {
302:         MPI_Send(vals+segs[edge],stage_n,MPIU_SCALAR,dest,type, MPI_COMM_WORLD);
303:       } else {
304:         type =  type - PCTFS_my_id + dest;
305:         MPI_Recv(work,stage_n,MPIU_SCALAR,MPI_ANY_SOURCE,type,MPI_COMM_WORLD,&status);
306:         PCTFS_rvec_add(vals+segs[edge], work, stage_n);
307:       }
308:     }
309:     mask <<= 1;
310:   }
311:   mask>>=1;
312:   for (edge=0; edge<level; edge++) {
313:     stage_n = (segs[level] - segs[level-1-edge]);
314:     if (stage_n && !(PCTFS_my_id & mask)) {
315:       dest = edge_node[level-edge-1];
316:       type = MSGTAG6 + PCTFS_my_id + (PCTFS_num_nodes*edge);
317:       if (PCTFS_my_id<dest) {
318:         MPI_Send(vals+segs[level-1-edge],stage_n,MPIU_SCALAR,dest,type,MPI_COMM_WORLD);
319:       } else {
320:         type =  type - PCTFS_my_id + dest;
321:         MPI_Recv(vals+segs[level-1-edge],stage_n,MPIU_SCALAR, MPI_ANY_SOURCE,type,MPI_COMM_WORLD,&status);
322:       }
323:     }
324:     mask >>= 1;
325:   }
326:   return(0);
327: }

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

339:   /* ok ... should have some data, work, and operator(s) */
340:   if (!vals||!work||!oprs) SETERRQ3(PETSC_COMM_SELF,PETSC_ERR_PLIB,"PCTFS_giop_hc() :: vals=%D, work=%D, oprs=%D",vals,work,oprs);

342:   /* non-uniform should have at least two entries */
343:   if ((oprs[0] == NON_UNIFORM)&&(n<2)) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"PCTFS_giop_hc() :: non_uniform and n=0,1?");

345:   /* check to make sure comm package has been initialized */
346:   if (!p_init) PCTFS_comm_init();

348:   /* if there's nothing to do return */
349:   if ((PCTFS_num_nodes<2)||(!n)||(dim<=0)) return(0);

351:   /* the error msg says it all!!! */
352:   if (modfl_num_nodes) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"PCTFS_giop_hc() :: PCTFS_num_nodes not a power of 2!?!");

354:   /* a negative number of items to send ==> fatal */
355:   if (n<0) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_PLIB,"PCTFS_giop_hc() :: n=%D<0?",n);

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

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

363:   if (!(fp = (vfp) PCTFS_ivec_fct_addr(type))) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"PCTFS_giop_hc() :: Could not retrieve function pointer!\n");

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

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

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

383:     dest = PCTFS_my_id^mask;
384:     if (PCTFS_my_id < dest) {
385:       MPI_Send(vals,n,MPIU_INT,dest,MSGTAG4+PCTFS_my_id,MPI_COMM_WORLD);
386:     } else {
387:       MPI_Recv(vals,n,MPIU_INT,MPI_ANY_SOURCE,MSGTAG4+dest,MPI_COMM_WORLD,&status);
388:     }
389:   }
390:   return(0);
391: }