Actual source code: mpimesg.c

petsc-3.6.4 2016-04-12
Report Typos and Errors
  2: #include <petscsys.h>        /*I  "petscsys.h"  I*/


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

 10:   Collective on MPI_Comm

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

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

 22:   Level: developer

 24:   Concepts: mpi utility

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

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

 34: .seealso: PetscGatherMessageLengths()
 35: @*/
 36: PetscErrorCode  PetscGatherNumberOfMessages(MPI_Comm comm,const PetscMPIInt iflags[],const PetscMPIInt ilengths[],PetscMPIInt *nrecvs)
 37: {
 38:   PetscMPIInt    size,rank,*recv_buf,i,*iflags_local = NULL,*iflags_localm = NULL;

 42:   MPI_Comm_size(comm,&size);
 43:   MPI_Comm_rank(comm,&rank);

 45:   PetscMalloc2(size,&recv_buf,size,&iflags_localm);

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

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

 61:   PetscFree2(recv_buf,iflags_localm);
 62:   return(0);
 63: }


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

 72:   Collective on MPI_Comm

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


 82:   Output Parameters:
 83: + onodes    - list of node-ids from which messages are expected
 84: - olengths  - corresponding message lengths

 86:   Level: developer

 88:   Concepts: mpi utility

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

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

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

 98: .seealso: PetscGatherNumberOfMessages()
 99: @*/
100: PetscErrorCode  PetscGatherMessageLengths(MPI_Comm comm,PetscMPIInt nsends,PetscMPIInt nrecvs,const PetscMPIInt ilengths[],PetscMPIInt **onodes,PetscMPIInt **olengths)
101: {
103:   PetscMPIInt    size,tag,i,j;
104:   MPI_Request    *s_waits  = NULL,*r_waits = NULL;
105:   MPI_Status     *w_status = NULL;

108:   MPI_Comm_size(comm,&size);
109:   PetscCommGetNewTag(comm,&tag);

111:   /* cannot use PetscMalloc3() here because in the call to MPI_Waitall() they MUST be contiguous */
112:   PetscMalloc2(nrecvs+nsends,&r_waits,nrecvs+nsends,&w_status);
113:   s_waits = r_waits+nrecvs;

115:   /* Post the Irecv to get the message length-info */
116:   PetscMalloc1(nrecvs,olengths);
117:   for (i=0; i<nrecvs; i++) {
118:     MPI_Irecv((*olengths)+i,1,MPI_INT,MPI_ANY_SOURCE,tag,comm,r_waits+i);
119:   }

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

129:   /* Post waits on sends and receivs */
130:   if (nrecvs+nsends) {MPI_Waitall(nrecvs+nsends,r_waits,w_status);}

132:   /* Pack up the received data */
133:   PetscMalloc1(nrecvs,onodes);
134:   for (i=0; i<nrecvs; ++i) (*onodes)[i] = w_status[i].MPI_SOURCE;
135:   PetscFree2(r_waits,w_status);
136:   return(0);
137: }

141: /*@C
142:   PetscGatherMessageLengths2 - Computes info about messages that a MPI-node will receive,
143:   including (from-id,length) pairs for each message. Same functionality as PetscGatherMessageLengths()
144:   except it takes TWO ilenths and output TWO olengths.

146:   Collective on MPI_Comm

148:   Input Parameters:
149: + comm      - Communicator
150: . nsends    - number of messages that are to be sent.
151: . nrecvs    - number of messages being received
152: - ilengths1, ilengths2 - array of integers of length sizeof(comm)
153:               a non zero ilengths[i] represent a message to i of length ilengths[i]

155:   Output Parameters:
156: + onodes    - list of node-ids from which messages are expected
157: - olengths1, olengths2 - corresponding message lengths

159:   Level: developer

161:   Concepts: mpi utility

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

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

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

171: .seealso: PetscGatherMessageLengths() and PetscGatherNumberOfMessages()
172: @*/
173: PetscErrorCode  PetscGatherMessageLengths2(MPI_Comm comm,PetscMPIInt nsends,PetscMPIInt nrecvs,const PetscMPIInt ilengths1[],const PetscMPIInt ilengths2[],PetscMPIInt **onodes,PetscMPIInt **olengths1,PetscMPIInt **olengths2)
174: {
176:   PetscMPIInt    size,tag,i,j,*buf_s = NULL,*buf_r = NULL,*buf_j = NULL;
177:   MPI_Request    *s_waits  = NULL,*r_waits = NULL;
178:   MPI_Status     *w_status = NULL;

181:   MPI_Comm_size(comm,&size);
182:   PetscCommGetNewTag(comm,&tag);

184:   /* cannot use PetscMalloc5() because r_waits and s_waits must be contiquous for the call to MPI_Waitall() */
185:   PetscMalloc4(nrecvs+nsends,&r_waits,2*nrecvs,&buf_r,2*nsends,&buf_s,nrecvs+nsends,&w_status);
186:   s_waits = r_waits + nrecvs;

188:   /* Post the Irecv to get the message length-info */
189:   PetscMalloc1(nrecvs+1,olengths1);
190:   PetscMalloc1(nrecvs+1,olengths2);
191:   for (i=0; i<nrecvs; i++) {
192:     buf_j = buf_r + (2*i);
193:     MPI_Irecv(buf_j,2,MPI_INT,MPI_ANY_SOURCE,tag,comm,r_waits+i);
194:   }

196:   /* Post the Isends with the message length-info */
197:   for (i=0,j=0; i<size; ++i) {
198:     if (ilengths1[i]) {
199:       buf_j    = buf_s + (2*j);
200:       buf_j[0] = *(ilengths1+i);
201:       buf_j[1] = *(ilengths2+i);
202:       MPI_Isend(buf_j,2,MPI_INT,i,tag,comm,s_waits+j);
203:       j++;
204:     }
205:   }
206:   if (j != nsends) SETERRQ2(PETSC_COMM_SELF,PETSC_ERR_PLIB,"j %d not equal to expected number of sends %d\n",j,nsends);

208:   /* Post waits on sends and receivs */
209:   if (nrecvs+nsends) {MPI_Waitall(nrecvs+nsends,r_waits,w_status);}


212:   /* Pack up the received data */
213:   PetscMalloc1(nrecvs+1,onodes);
214:   for (i=0; i<nrecvs; ++i) {
215:     (*onodes)[i]    = w_status[i].MPI_SOURCE;
216:     buf_j           = buf_r + (2*i);
217:     (*olengths1)[i] = buf_j[0];
218:     (*olengths2)[i] = buf_j[1];
219:   }

221:   PetscFree4(r_waits,buf_r,buf_s,w_status);
222:   return(0);
223: }

225: /*

227:   Allocate a bufffer sufficient to hold messages of size specified in olengths.
228:   And post Irecvs on these buffers using node info from onodes

230:  */
233: PetscErrorCode  PetscPostIrecvInt(MPI_Comm comm,PetscMPIInt tag,PetscMPIInt nrecvs,const PetscMPIInt onodes[],const PetscMPIInt olengths[],PetscInt ***rbuf,MPI_Request **r_waits)
234: {
236:   PetscInt       **rbuf_t,i,len = 0;
237:   MPI_Request    *r_waits_t;

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

243:   /* allocate memory for recv buffers */
244:   PetscMalloc1(nrecvs+1,&rbuf_t);
245:   PetscMalloc1(len,&rbuf_t[0]);
246:   for (i=1; i<nrecvs; ++i) rbuf_t[i] = rbuf_t[i-1] + olengths[i-1];

248:   /* Post the receives */
249:   PetscMalloc1(nrecvs,&r_waits_t);
250:   for (i=0; i<nrecvs; ++i) {
251:     MPI_Irecv(rbuf_t[i],olengths[i],MPIU_INT,onodes[i],tag,comm,r_waits_t+i);
252:   }

254:   *rbuf    = rbuf_t;
255:   *r_waits = r_waits_t;
256:   return(0);
257: }

261: PetscErrorCode  PetscPostIrecvScalar(MPI_Comm comm,PetscMPIInt tag,PetscMPIInt nrecvs,const PetscMPIInt onodes[],const PetscMPIInt olengths[],PetscScalar ***rbuf,MPI_Request **r_waits)
262: {
264:   PetscMPIInt    i;
265:   PetscScalar    **rbuf_t;
266:   MPI_Request    *r_waits_t;
267:   PetscInt       len = 0;

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

273:   /* allocate memory for recv buffers */
274:   PetscMalloc1(nrecvs+1,&rbuf_t);
275:   PetscMalloc1(len,&rbuf_t[0]);
276:   for (i=1; i<nrecvs; ++i) rbuf_t[i] = rbuf_t[i-1] + olengths[i-1];

278:   /* Post the receives */
279:   PetscMalloc1(nrecvs,&r_waits_t);
280:   for (i=0; i<nrecvs; ++i) {
281:     MPI_Irecv(rbuf_t[i],olengths[i],MPIU_SCALAR,onodes[i],tag,comm,r_waits_t+i);
282:   }

284:   *rbuf    = rbuf_t;
285:   *r_waits = r_waits_t;
286:   return(0);
287: }