Actual source code: mpimesg.c

      1: #include <petscsys.h>

      3: PETSC_SINGLE_LIBRARY_INTERN PetscErrorCode PetscGatherNumberOfMessages_Private(MPI_Comm, const PetscMPIInt[], const PetscInt[], PetscMPIInt *);
      4: PETSC_SINGLE_LIBRARY_INTERN PetscErrorCode PetscGatherMessageLengths_Private(MPI_Comm, PetscMPIInt, PetscMPIInt, const PetscInt[], PetscMPIInt **, PetscInt **);

      6: /*@C
      7:   PetscGatherNumberOfMessages -  Computes the number of messages an MPI rank expects to receive during a neighbor communication

      9:   Collective, No Fortran Support

     11:   Input Parameters:
     12: + comm     - Communicator
     13: . iflags   - an array of integers of length sizeof(comm). A '1' in `ilengths`[i] represent a
     14:              message from current node to ith node. Optionally `NULL`
     15: - ilengths - Non zero ilengths[i] represent a message to i of length `ilengths`[i].
     16:              Optionally `NULL`.

     18:   Output Parameter:
     19: . nrecvs - number of messages received

     21:   Level: developer

     23:   Notes:
     24:   With this info, the correct message lengths can be determined using
     25:   `PetscGatherMessageLengths()`

     27:   Either `iflags` or `ilengths` should be provided.  If `iflags` is not
     28:   provided (`NULL`) it can be computed from `ilengths`. If `iflags` is
     29:   provided, `ilengths` is not required.

     31: .seealso: `PetscGatherMessageLengths()`, `PetscGatherMessageLengths2()`, `PetscCommBuildTwoSided()`
     32: @*/
     33: PetscErrorCode PetscGatherNumberOfMessages(MPI_Comm comm, const PetscMPIInt iflags[], const PetscMPIInt ilengths[], PetscMPIInt *nrecvs)
     34: {
     35:   PetscMPIInt size, rank, *recv_buf, i, *iflags_local = NULL, *iflags_localm;

     37:   PetscFunctionBegin;
     38:   PetscCallMPI(MPI_Comm_size(comm, &size));
     39:   PetscCallMPI(MPI_Comm_rank(comm, &rank));

     41:   PetscCall(PetscMalloc2(size, &recv_buf, size, &iflags_localm));

     43:   /* If iflags not provided, compute iflags from ilengths */
     44:   if (!iflags) {
     45:     PetscCheck(ilengths, PETSC_COMM_SELF, PETSC_ERR_ARG_WRONGSTATE, "Either iflags or ilengths should be provided");
     46:     iflags_local = iflags_localm;
     47:     for (i = 0; i < size; i++) {
     48:       if (ilengths[i]) iflags_local[i] = 1;
     49:       else iflags_local[i] = 0;
     50:     }
     51:   } else iflags_local = (PetscMPIInt *)iflags;

     53:   /* Post an allreduce to determine the number of messages the current MPI rank will receive */
     54:   PetscCallMPI(MPIU_Allreduce(iflags_local, recv_buf, size, MPI_INT, MPI_SUM, comm));
     55:   *nrecvs = recv_buf[rank];

     57:   PetscCall(PetscFree2(recv_buf, iflags_localm));
     58:   PetscFunctionReturn(PETSC_SUCCESS);
     59: }

     61: /*@C
     62:   PetscGatherMessageLengths - Computes information about messages that an MPI rank will receive,
     63:   including (from-id,length) pairs for each message.

     65:   Collective, No Fortran Support

     67:   Input Parameters:
     68: + comm     - Communicator
     69: . nsends   - number of messages that are to be sent.
     70: . nrecvs   - number of messages being received
     71: - ilengths - an array of integers of length sizeof(comm)
     72:               a non zero `ilengths`[i] represent a message to i of length `ilengths`[i]

     74:   Output Parameters:
     75: + onodes   - list of ranks from which messages are expected
     76: - olengths - corresponding message lengths

     78:   Level: developer

     80:   Notes:
     81:   With this info, the correct `MPIU_Irecv()` can be posted with the correct
     82:   from-id, with a buffer with the right amount of memory required.

     84:   The calling function deallocates the memory in onodes and olengths

     86:   To determine `nrecvs`, one can use `PetscGatherNumberOfMessages()`

     88: .seealso: `PetscGatherNumberOfMessages()`, `PetscGatherMessageLengths2()`, `PetscCommBuildTwoSided()`
     89: @*/
     90: PetscErrorCode PetscGatherMessageLengths(MPI_Comm comm, PetscMPIInt nsends, PetscMPIInt nrecvs, const PetscMPIInt ilengths[], PetscMPIInt **onodes, PetscMPIInt **olengths)
     91: {
     92:   PetscMPIInt  size, rank, tag, i, j;
     93:   MPI_Request *s_waits, *r_waits;
     94:   MPI_Status  *w_status;

     96:   PetscFunctionBegin;
     97:   PetscCallMPI(MPI_Comm_size(comm, &size));
     98:   PetscCallMPI(MPI_Comm_rank(comm, &rank));
     99:   PetscCall(PetscCommGetNewTag(comm, &tag));

    101:   /* cannot use PetscMalloc3() here because in the call to MPI_Waitall() they MUST be contiguous */
    102:   PetscCall(PetscMalloc2(nrecvs + nsends, &r_waits, nrecvs + nsends, &w_status));
    103:   s_waits = PetscSafePointerPlusOffset(r_waits, nrecvs);

    105:   /* Post the Irecv to get the message length-info */
    106:   PetscCall(PetscMalloc1(nrecvs, olengths));
    107:   for (i = 0; i < nrecvs; i++) PetscCallMPI(MPIU_Irecv((*olengths) + i, 1, MPI_INT, MPI_ANY_SOURCE, tag, comm, r_waits + i));

    109:   /* Post the Isends with the message length-info */
    110:   for (i = 0, j = 0; i < size; ++i) {
    111:     if (ilengths[i]) {
    112:       PetscCallMPI(MPIU_Isend((void *)(ilengths + i), 1, MPI_INT, i, tag, comm, s_waits + j));
    113:       j++;
    114:     }
    115:   }

    117:   /* Post waits on sends and receives */
    118:   if (nrecvs + nsends) PetscCallMPI(MPI_Waitall(nrecvs + nsends, r_waits, w_status));

    120:   /* Pack up the received data */
    121:   PetscCall(PetscMalloc1(nrecvs, onodes));
    122:   for (i = 0; i < nrecvs; ++i) {
    123:     (*onodes)[i] = w_status[i].MPI_SOURCE;
    124: #if defined(PETSC_HAVE_OPENMPI)
    125:     /* This line is a workaround for a bug in Open MPI 2.1.1 distributed by Ubuntu-18.04.2 LTS.
    126:        It happens in self-to-self MPI_Send/Recv using MPI_ANY_SOURCE for message matching. Open MPI
    127:        does not put correct value in recv buffer. See also
    128:        https://lists.mcs.anl.gov/pipermail/petsc-dev/2019-July/024803.html
    129:        https://www.mail-archive.com/users@lists.open-mpi.org//msg33383.html
    130:      */
    131:     if (w_status[i].MPI_SOURCE == rank) (*olengths)[i] = ilengths[rank];
    132: #endif
    133:   }
    134:   PetscCall(PetscFree2(r_waits, w_status));
    135:   PetscFunctionReturn(PETSC_SUCCESS);
    136: }

    138: /* Same as PetscGatherNumberOfMessages(), except using PetscInt for ilengths[] */
    139: PetscErrorCode PetscGatherNumberOfMessages_Private(MPI_Comm comm, const PetscMPIInt iflags[], const PetscInt ilengths[], PetscMPIInt *nrecvs)
    140: {
    141:   PetscMPIInt size, rank, *recv_buf, i, *iflags_local = NULL, *iflags_localm;

    143:   PetscFunctionBegin;
    144:   PetscCallMPI(MPI_Comm_size(comm, &size));
    145:   PetscCallMPI(MPI_Comm_rank(comm, &rank));

    147:   PetscCall(PetscMalloc2(size, &recv_buf, size, &iflags_localm));

    149:   /* If iflags not provided, compute iflags from ilengths */
    150:   if (!iflags) {
    151:     PetscCheck(ilengths, PETSC_COMM_SELF, PETSC_ERR_ARG_WRONGSTATE, "Either iflags or ilengths should be provided");
    152:     iflags_local = iflags_localm;
    153:     for (i = 0; i < size; i++) {
    154:       if (ilengths[i]) iflags_local[i] = 1;
    155:       else iflags_local[i] = 0;
    156:     }
    157:   } else iflags_local = (PetscMPIInt *)iflags;

    159:   /* Post an allreduce to determine the number of messages the current MPI rank will receive */
    160:   PetscCallMPI(MPIU_Allreduce(iflags_local, recv_buf, size, MPI_INT, MPI_SUM, comm));
    161:   *nrecvs = recv_buf[rank];

    163:   PetscCall(PetscFree2(recv_buf, iflags_localm));
    164:   PetscFunctionReturn(PETSC_SUCCESS);
    165: }

    167: /* Same as PetscGatherMessageLengths(), except using PetscInt for message lengths */
    168: PetscErrorCode PetscGatherMessageLengths_Private(MPI_Comm comm, PetscMPIInt nsends, PetscMPIInt nrecvs, const PetscInt ilengths[], PetscMPIInt **onodes, PetscInt **olengths)
    169: {
    170:   PetscMPIInt  size, rank, tag, i, j;
    171:   MPI_Request *s_waits, *r_waits;
    172:   MPI_Status  *w_status;

    174:   PetscFunctionBegin;
    175:   PetscCallMPI(MPI_Comm_size(comm, &size));
    176:   PetscCallMPI(MPI_Comm_rank(comm, &rank));
    177:   PetscCall(PetscCommGetNewTag(comm, &tag));

    179:   /* cannot use PetscMalloc3() here because in the call to MPI_Waitall() they MUST be contiguous */
    180:   PetscCall(PetscMalloc2(nrecvs + nsends, &r_waits, nrecvs + nsends, &w_status));
    181:   s_waits = PetscSafePointerPlusOffset(r_waits, nrecvs);

    183:   /* Post the Irecv to get the message length-info */
    184:   PetscCall(PetscMalloc1(nrecvs, olengths));
    185:   for (i = 0; i < nrecvs; i++) PetscCallMPI(MPIU_Irecv((*olengths) + i, 1, MPIU_INT, MPI_ANY_SOURCE, tag, comm, r_waits + i));

    187:   /* Post the Isends with the message length-info */
    188:   for (i = 0, j = 0; i < size; ++i) {
    189:     if (ilengths[i]) {
    190:       PetscCallMPI(MPIU_Isend((void *)(ilengths + i), 1, MPIU_INT, i, tag, comm, s_waits + j));
    191:       j++;
    192:     }
    193:   }

    195:   /* Post waits on sends and receives */
    196:   if (nrecvs + nsends) PetscCallMPI(MPI_Waitall(nrecvs + nsends, r_waits, w_status));

    198:   /* Pack up the received data */
    199:   PetscCall(PetscMalloc1(nrecvs, onodes));
    200:   for (i = 0; i < nrecvs; ++i) {
    201:     (*onodes)[i] = w_status[i].MPI_SOURCE;
    202:     if (w_status[i].MPI_SOURCE == rank) (*olengths)[i] = ilengths[rank]; /* See comments in PetscGatherMessageLengths */
    203:   }
    204:   PetscCall(PetscFree2(r_waits, w_status));
    205:   PetscFunctionReturn(PETSC_SUCCESS);
    206: }

    208: /*@C
    209:   PetscGatherMessageLengths2 - Computes info about messages that a MPI rank will receive,
    210:   including (from-id,length) pairs for each message. Same functionality as `PetscGatherMessageLengths()`
    211:   except it takes TWO ilenths and output TWO olengths.

    213:   Collective, No Fortran Support

    215:   Input Parameters:
    216: + comm      - Communicator
    217: . nsends    - number of messages that are to be sent.
    218: . nrecvs    - number of messages being received
    219: . ilengths1 - first array of integers of length sizeof(comm)
    220: - ilengths2 - second array of integers of length sizeof(comm)

    222:   Output Parameters:
    223: + onodes    - list of ranks from which messages are expected
    224: . olengths1 - first corresponding message lengths
    225: - olengths2 - second  message lengths

    227:   Level: developer

    229:   Notes:
    230:   With this info, the correct `MPIU_Irecv()` can be posted with the correct
    231:   from-id, with a buffer with the right amount of memory required.

    233:   The calling function should `PetscFree()` the memory in `onodes` and `olengths`

    235:   To determine `nrecvs`, one can use `PetscGatherNumberOfMessages()`

    237: .seealso: `PetscGatherMessageLengths()`, `PetscGatherNumberOfMessages()`, `PetscCommBuildTwoSided()`
    238: @*/
    239: PetscErrorCode PetscGatherMessageLengths2(MPI_Comm comm, PetscMPIInt nsends, PetscMPIInt nrecvs, const PetscMPIInt ilengths1[], const PetscMPIInt ilengths2[], PetscMPIInt **onodes, PetscMPIInt **olengths1, PetscMPIInt **olengths2)
    240: {
    241:   PetscMPIInt  size, tag, i, j, *buf_s, *buf_r, *buf_j = NULL;
    242:   MPI_Request *s_waits, *r_waits;
    243:   MPI_Status  *w_status;

    245:   PetscFunctionBegin;
    246:   PetscCallMPI(MPI_Comm_size(comm, &size));
    247:   PetscCall(PetscCommGetNewTag(comm, &tag));

    249:   /* cannot use PetscMalloc5() because r_waits and s_waits must be contiguous for the call to MPI_Waitall() */
    250:   PetscCall(PetscMalloc4(nrecvs + nsends, &r_waits, 2 * nrecvs, &buf_r, 2 * nsends, &buf_s, nrecvs + nsends, &w_status));
    251:   s_waits = PetscSafePointerPlusOffset(r_waits, nrecvs);

    253:   /* Post the Irecv to get the message length-info */
    254:   PetscCall(PetscMalloc1(nrecvs, olengths1));
    255:   PetscCall(PetscMalloc1(nrecvs, olengths2));
    256:   for (i = 0; i < nrecvs; i++) {
    257:     buf_j = buf_r + (2 * i);
    258:     PetscCallMPI(MPIU_Irecv(buf_j, 2, MPI_INT, MPI_ANY_SOURCE, tag, comm, r_waits + i));
    259:   }

    261:   /* Post the Isends with the message length-info */
    262:   for (i = 0, j = 0; i < size; ++i) {
    263:     if (ilengths1[i]) {
    264:       buf_j    = buf_s + (2 * j);
    265:       buf_j[0] = *(ilengths1 + i);
    266:       buf_j[1] = *(ilengths2 + i);
    267:       PetscCallMPI(MPIU_Isend(buf_j, 2, MPI_INT, i, tag, comm, s_waits + j));
    268:       j++;
    269:     }
    270:   }
    271:   PetscCheck(j == nsends, PETSC_COMM_SELF, PETSC_ERR_PLIB, "j %d not equal to expected number of sends %d", j, nsends);

    273:   /* Post waits on sends and receives */
    274:   if (nrecvs + nsends) PetscCallMPI(MPI_Waitall(nrecvs + nsends, r_waits, w_status));

    276:   /* Pack up the received data */
    277:   PetscCall(PetscMalloc1(nrecvs, onodes));
    278:   for (i = 0; i < nrecvs; ++i) {
    279:     (*onodes)[i]    = w_status[i].MPI_SOURCE;
    280:     buf_j           = buf_r + (2 * i);
    281:     (*olengths1)[i] = buf_j[0];
    282:     (*olengths2)[i] = buf_j[1];
    283:   }

    285:   PetscCall(PetscFree4(r_waits, buf_r, buf_s, w_status));
    286:   PetscFunctionReturn(PETSC_SUCCESS);
    287: }

    289: /*
    290:   Allocate a buffer sufficient to hold messages of size specified in olengths.
    291:   And post Irecvs on these buffers using node info from onodes
    292:  */
    293: PetscErrorCode PetscPostIrecvInt(MPI_Comm comm, PetscMPIInt tag, PetscMPIInt nrecvs, const PetscMPIInt onodes[], const PetscMPIInt olengths[], PetscInt ***rbuf, MPI_Request **r_waits)
    294: {
    295:   PetscInt   **rbuf_t, i, len = 0;
    296:   MPI_Request *r_waits_t;

    298:   PetscFunctionBegin;
    299:   /* compute memory required for recv buffers */
    300:   for (i = 0; i < nrecvs; i++) len += olengths[i]; /* each message length */

    302:   /* allocate memory for recv buffers */
    303:   PetscCall(PetscMalloc1(nrecvs + 1, &rbuf_t));
    304:   PetscCall(PetscMalloc1(len, &rbuf_t[0]));
    305:   for (i = 1; i < nrecvs; ++i) rbuf_t[i] = rbuf_t[i - 1] + olengths[i - 1];

    307:   /* Post the receives */
    308:   PetscCall(PetscMalloc1(nrecvs, &r_waits_t));
    309:   for (i = 0; i < nrecvs; ++i) PetscCallMPI(MPIU_Irecv(rbuf_t[i], olengths[i], MPIU_INT, onodes[i], tag, comm, r_waits_t + i));

    311:   *rbuf    = rbuf_t;
    312:   *r_waits = r_waits_t;
    313:   PetscFunctionReturn(PETSC_SUCCESS);
    314: }

    316: PetscErrorCode PetscPostIrecvScalar(MPI_Comm comm, PetscMPIInt tag, PetscMPIInt nrecvs, const PetscMPIInt onodes[], const PetscMPIInt olengths[], PetscScalar ***rbuf, MPI_Request **r_waits)
    317: {
    318:   PetscMPIInt   i;
    319:   PetscScalar **rbuf_t;
    320:   MPI_Request  *r_waits_t;
    321:   PetscInt      len = 0;

    323:   PetscFunctionBegin;
    324:   /* compute memory required for recv buffers */
    325:   for (i = 0; i < nrecvs; i++) len += olengths[i]; /* each message length */

    327:   /* allocate memory for recv buffers */
    328:   PetscCall(PetscMalloc1(nrecvs + 1, &rbuf_t));
    329:   PetscCall(PetscMalloc1(len, &rbuf_t[0]));
    330:   for (i = 1; i < nrecvs; ++i) rbuf_t[i] = rbuf_t[i - 1] + olengths[i - 1];

    332:   /* Post the receives */
    333:   PetscCall(PetscMalloc1(nrecvs, &r_waits_t));
    334:   for (i = 0; i < nrecvs; ++i) PetscCallMPI(MPIU_Irecv(rbuf_t[i], olengths[i], MPIU_SCALAR, onodes[i], tag, comm, r_waits_t + i));

    336:   *rbuf    = rbuf_t;
    337:   *r_waits = r_waits_t;
    338:   PetscFunctionReturn(PETSC_SUCCESS);
    339: }