Actual source code: comm.c

      1: /***********************************comm.c*************************************

      3: Author: Henry M. Tufo III

      5: e-mail: hmt@cs.brown.edu

      7: snail-mail:
      8: Division of Applied Mathematics
      9: Brown University
     10: Providence, RI 02912

     12: Last Modification:
     13: 11.21.97
     14: ***********************************comm.c*************************************/
     15: #include <../src/ksp/pc/impls/tfs/tfs.h>

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    222:   PetscFunctionBegin;
    223:   /* ok ... should have some data, work, and operator(s) */
    224:   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);

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    335:   PetscFunctionBegin;
    336:   /* ok ... should have some data, work, and operator(s) */
    337:   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);

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

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

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

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

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

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

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

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

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

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

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

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