Actual source code: mpimesg.c

      1: #define PETSC_DLL

     3:  #include petsc.h

      8: /*@C
      9:   PetscGatherNumberOfMessages -  Computes the number of messages a node expects to receive

     11:   Collective on MPI_Comm

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

     20:   Output Parameters:
     21: . nrecvs    - number of messages received

     23:   Level: developer

     25:   Concepts: mpi utility

     27:   Notes:
     28:   With this info, the correct message lengths can be determined using
     29:   PetscGatherMessageLengths()

     31:   Either iflags or ilengths should be provided.  If iflags is not
     32:   provided (PETSC_NULL) it can be computed from ilengths. If iflags is
     33:   provided, ilengths is not required.

     35: .seealso: PetscGatherMessageLengths()
     36: @*/
     37: PetscErrorCode PETSC_DLLEXPORT PetscGatherNumberOfMessages(MPI_Comm comm,PetscMPIInt *iflags,PetscMPIInt *ilengths,PetscMPIInt *nrecvs)
     38: {
     39:   PetscMPIInt    size,rank,*recv_buf,i,*iflags_local,*iflags_localm;

     44:   MPI_Comm_size(comm,&size);
     45:   MPI_Comm_rank(comm,&rank);

     47:   PetscMalloc2(size,PetscMPIInt,&recv_buf,size,PetscMPIInt,&iflags_localm);

     49:   /* If iflags not provided, compute iflags from ilengths */
     50:   if (!iflags) {
     51:     if (!ilengths) SETERRQ(PETSC_ERR_ARG_WRONGSTATE,"Either iflags or ilengths should be provided");
     52:     iflags_local = iflags_localm;
     53:     for (i=0; i<size; i++) {
     54:       if (ilengths[i])  iflags_local[i] = 1;
     55:       else iflags_local[i] = 0;
     56:     }
     57:   } else {
     58:     iflags_local = iflags;
     59:   }

     61:   /* Post an allreduce to determine the numer of messages the current node will receive */
     62:   MPI_Allreduce(iflags_local,recv_buf,size,MPI_INT,MPI_SUM,comm);
     63:   *nrecvs = recv_buf[rank];

     65:   PetscFree2(recv_buf,iflags_localm);
     66:   return(0);
     67: }

     72: /*@C
     73:   PetscGatherMessageLengths - Computes info about messages that a MPI-node will receive,
     74:   including (from-id,length) pairs for each message.

     76:   Collective on MPI_Comm

     78:   Input Parameters:
     79: + comm      - Communicator
     80: . nsends    - number of messages that are to be sent.
     81: . nrecvs    - number of messages being received
     82: - ilengths  - an array of integers of length sizeof(comm)
     83:               a non zero ilengths[i] represent a message to i of length ilengths[i]

     86:   Output Parameters:
     87: + onodes    - list of node-ids from which messages are expected
     88: - olengths  - corresponding message lengths

     90:   Level: developer

     92:   Concepts: mpi utility

     94:   Notes:
     95:   With this info, the correct MPI_Irecv() can be posted with the correct
     96:   from-id, with a buffer with the right amount of memory required.

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

    100:   To determine nrecevs, one can use PetscGatherNumberOfMessages()

    102: .seealso: PetscGatherNumberOfMessages()
    103: @*/
    104: PetscErrorCode PETSC_DLLEXPORT PetscGatherMessageLengths(MPI_Comm comm,PetscMPIInt nsends,PetscMPIInt nrecvs,PetscMPIInt *ilengths,PetscMPIInt **onodes,PetscMPIInt **olengths)
    105: {
    107:   PetscMPIInt    size,tag,i,j;
    108:   MPI_Request    *s_waits,*r_waits;
    109:   MPI_Status     *w_status;

    112:   MPI_Comm_size(comm,&size);
    113:   PetscCommGetNewTag(comm,&tag);

    115:   /* cannot use PetscMalloc3() here because in the call to MPI_Waitall() they MUST be contiguous */
    116:   PetscMalloc2(nrecvs+nsends,MPI_Request,&r_waits,nrecvs+nsends,MPI_Status,&w_status);
    117:   s_waits = r_waits+nrecvs;

    119:   /* Post the Irecv to get the message length-info */
    120:   PetscMalloc(nrecvs*sizeof(PetscMPIInt),olengths);
    121:   for (i=0; i<nrecvs; i++) {
    122:     MPI_Irecv((*olengths)+i,1,MPI_INT,MPI_ANY_SOURCE,tag,comm,r_waits+i);
    123:   }

    125:   /* Post the Isends with the message length-info */
    126:   for (i=0,j=0; i<size; ++i) {
    127:     if (ilengths[i]) {
    128:       MPI_Isend(ilengths+i,1,MPI_INT,i,tag,comm,s_waits+j);
    129:       j++;
    130:     }
    131:   }

    133:   /* Post waits on sends and receivs */
    134:   if (nrecvs+nsends) {MPI_Waitall(nrecvs+nsends,r_waits,w_status);}
    135:
    136:   /* Pack up the received data */
    137:   PetscMalloc(nrecvs*sizeof(PetscMPIInt),onodes);
    138:   for (i=0; i<nrecvs; ++i) {
    139:     (*onodes)[i] = w_status[i].MPI_SOURCE;
    140:   }
    141:   PetscFree2(r_waits,w_status);
    142:   return(0);
    143: }
    146: /*@C
    147:   PetscGatherMessageLengths2 - Computes info about messages that a MPI-node will receive,
    148:   including (from-id,length) pairs for each message. Same functionality as PetscGatherMessageLengths()
    149:   except it takes TWO ilenths and output TWO olengths.

    151:   Collective on MPI_Comm

    153:   Input Parameters:
    154: + comm      - Communicator
    155: . nsends    - number of messages that are to be sent.
    156: . nrecvs    - number of messages being received
    157: - ilengths1, ilengths2 - array of integers of length sizeof(comm)
    158:               a non zero ilengths[i] represent a message to i of length ilengths[i]

    160:   Output Parameters:
    161: + onodes    - list of node-ids from which messages are expected
    162: - olengths1, olengths2 - corresponding message lengths

    164:   Level: developer

    166:   Concepts: mpi utility

    168:   Notes:
    169:   With this info, the correct MPI_Irecv() can be posted with the correct
    170:   from-id, with a buffer with the right amount of memory required.

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

    174:   To determine nrecevs, one can use PetscGatherNumberOfMessages()

    176: .seealso: PetscGatherMessageLengths() and PetscGatherNumberOfMessages()
    177: @*/
    178: PetscErrorCode PETSC_DLLEXPORT PetscGatherMessageLengths2(MPI_Comm comm,PetscMPIInt nsends,PetscMPIInt nrecvs,PetscMPIInt *ilengths1,PetscMPIInt *ilengths2,PetscMPIInt **onodes,PetscMPIInt **olengths1,PetscMPIInt **olengths2)
    179: {
    181:   PetscMPIInt    size,tag,i,j,*buf_s,*buf_r,*buf_j;
    182:   MPI_Request    *s_waits,*r_waits;
    183:   MPI_Status     *w_status;

    186:   MPI_Comm_size(comm,&size);
    187:   PetscCommGetNewTag(comm,&tag);

    189:   /* cannot use PetscMalloc5() because r_waits and s_waits must be contiquous for the call to MPI_Waitall() */
    190:   PetscMalloc4(nrecvs+nsends,MPI_Request,&r_waits,2*nrecvs,PetscMPIInt,&buf_r,2*nsends,PetscMPIInt,&buf_s,nrecvs+nsends,MPI_Status,&w_status);
    191:   s_waits = r_waits + nrecvs;

    193:   /* Post the Irecv to get the message length-info */
    194:   PetscMalloc((nrecvs+1)*sizeof(PetscMPIInt),olengths1);
    195:   PetscMalloc((nrecvs+1)*sizeof(PetscMPIInt),olengths2);
    196:   for (i=0; i<nrecvs; i++) {
    197:     buf_j = buf_r + (2*i);
    198:     MPI_Irecv(buf_j,2,MPI_INT,MPI_ANY_SOURCE,tag,comm,r_waits+i);
    199:   }

    201:   /* Post the Isends with the message length-info */
    202:   for (i=0,j=0; i<size; ++i) {
    203:     if (ilengths1[i]) {
    204:       buf_j = buf_s + (2*j);
    205:       buf_j[0] = *(ilengths1+i);
    206:       buf_j[1] = *(ilengths2+i);
    207:       MPI_Isend(buf_j,2,MPI_INT,i,tag,comm,s_waits+j);
    208:       j++;
    209:     }
    210:   }
    211:
    212:   /* Post waits on sends and receivs */
    213:   if (nrecvs+nsends) {MPI_Waitall(nrecvs+nsends,r_waits,w_status);}

    215:
    216:   /* Pack up the received data */
    217:   PetscMalloc((nrecvs+1)*sizeof(PetscMPIInt),onodes);
    218:   for (i=0; i<nrecvs; ++i) {
    219:     (*onodes)[i] = w_status[i].MPI_SOURCE;
    220:     buf_j = buf_r + (2*i);
    221:     (*olengths1)[i] = buf_j[0];
    222:     (*olengths2)[i] = buf_j[1];
    223:   }

    225:   PetscFree4(r_waits,buf_r,buf_s,w_status);
    226:   return(0);
    227: }

    229: /*

    231:   Allocate a bufffer sufficient to hold messages of size specified in olengths.
    232:   And post Irecvs on these buffers using node info from onodes
    233:
    234:  */
    237: PetscErrorCode PETSC_DLLEXPORT PetscPostIrecvInt(MPI_Comm comm,PetscMPIInt tag,PetscMPIInt nrecvs,PetscMPIInt *onodes,PetscMPIInt *olengths,PetscInt ***rbuf,MPI_Request **r_waits)
    238: {
    240:   PetscInt       len=0,**rbuf_t,i;
    241:   MPI_Request    *r_waits_t;

    245:   /* compute memory required for recv buffers */
    246:   for (i=0; i<nrecvs; i++) len += olengths[i];  /* each message length */
    247:   len *= sizeof(PetscInt);
    248:   len += (nrecvs+1)*sizeof(PetscInt*); /* Array of pointers for each message */

    250:   /* allocate memory for recv buffers */
    251:   PetscMalloc(len,&rbuf_t);
    252:   rbuf_t[0] = (PetscInt*)(rbuf_t + nrecvs);
    253:   for (i=1; i<nrecvs; ++i) rbuf_t[i] = rbuf_t[i-1] + olengths[i-1];

    255:   /* Post the receives */
    256:   PetscMalloc((nrecvs+1)*sizeof(MPI_Request),&r_waits_t);
    257:   for (i=0; i<nrecvs; ++i) {
    258:     MPI_Irecv(rbuf_t[i],olengths[i],MPIU_INT,onodes[i],tag,comm,r_waits_t+i);
    259:   }

    261:   *rbuf    = rbuf_t;
    262:   *r_waits = r_waits_t;
    263:   return(0);
    264: }

    268: PetscErrorCode PETSC_DLLEXPORT PetscPostIrecvScalar(MPI_Comm comm,PetscMPIInt tag,PetscMPIInt nrecvs,PetscMPIInt *onodes,PetscMPIInt *olengths,PetscScalar ***rbuf,MPI_Request **r_waits)
    269: {
    271:   PetscMPIInt    len=0,i;
    272:   PetscScalar    **rbuf_t;
    273:   MPI_Request    *r_waits_t;

    277:   /* compute memory required for recv buffers */
    278:   for (i=0; i<nrecvs; i++) len += olengths[i];  /* each message length */
    279:   len *= sizeof(PetscScalar);
    280:   len += (nrecvs+1)*sizeof(PetscScalar*); /* Array of pointers for each message */

    283:   /* allocate memory for recv buffers */
    284:   PetscMalloc(len,&rbuf_t);
    285:   rbuf_t[0] = (PetscScalar*)(rbuf_t + nrecvs);
    286:   for (i=1; i<nrecvs; ++i) rbuf_t[i] = rbuf_t[i-1] + olengths[i-1];

    288:   /* Post the receives */
    289:   PetscMalloc((nrecvs+1)*sizeof(MPI_Request),&r_waits_t);
    290:   for (i=0; i<nrecvs; ++i) {
    291:     MPI_Irecv(rbuf_t[i],olengths[i],MPIU_SCALAR,onodes[i],tag,comm,r_waits_t+i);
    292:   }

    294:   *rbuf    = rbuf_t;
    295:   *r_waits = r_waits_t;
    296:   return(0);
    297: }