1 2 #include <petscsys.h> /*I "petscsys.h" I*/ 3 4 5 #undef __FUNCT__ 6 #define __FUNCT__ "PetscGatherNumberOfMessages" 7 /*@C 8 PetscGatherNumberOfMessages - Computes the number of messages a node expects to receive 9 10 Collective on MPI_Comm 11 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 PETSC_NULL 16 - ilengths - Non zero ilengths[i] represent a message to i of length ilengths[i]. 17 Optionally PETSC_NULL. 18 19 Output Parameters: 20 . nrecvs - number of messages received 21 22 Level: developer 23 24 Concepts: mpi utility 25 26 Notes: 27 With this info, the correct message lengths can be determined using 28 PetscGatherMessageLengths() 29 30 Either iflags or ilengths should be provided. If iflags is not 31 provided (PETSC_NULL) it can be computed from ilengths. If iflags is 32 provided, ilengths is not required. 33 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 = PETSC_NULL,*iflags_localm = PETSC_NULL; 39 PetscErrorCode ierr; 40 41 PetscFunctionBegin; 42 43 ierr = MPI_Comm_size(comm,&size);CHKERRQ(ierr); 44 ierr = MPI_Comm_rank(comm,&rank);CHKERRQ(ierr); 45 46 ierr = PetscMalloc2(size,PetscMPIInt,&recv_buf,size,PetscMPIInt,&iflags_localm);CHKERRQ(ierr); 47 48 /* If iflags not provided, compute iflags from ilengths */ 49 if (!iflags) { 50 if (!ilengths) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_WRONGSTATE,"Either iflags or ilengths should be provided"); 51 iflags_local = iflags_localm; 52 for (i=0; i<size; i++) { 53 if (ilengths[i]) iflags_local[i] = 1; 54 else iflags_local[i] = 0; 55 } 56 } else { 57 iflags_local = (PetscMPIInt *) iflags; 58 } 59 60 /* Post an allreduce to determine the numer of messages the current node will receive */ 61 ierr = MPI_Allreduce(iflags_local,recv_buf,size,MPI_INT,MPI_SUM,comm);CHKERRQ(ierr); 62 *nrecvs = recv_buf[rank]; 63 64 ierr = PetscFree2(recv_buf,iflags_localm);CHKERRQ(ierr); 65 PetscFunctionReturn(0); 66 } 67 68 69 #undef __FUNCT__ 70 #define __FUNCT__ "PetscGatherMessageLengths" 71 /*@C 72 PetscGatherMessageLengths - Computes info about messages that a MPI-node will receive, 73 including (from-id,length) pairs for each message. 74 75 Collective on MPI_Comm 76 77 Input Parameters: 78 + comm - Communicator 79 . nsends - number of messages that are to be sent. 80 . nrecvs - number of messages being received 81 - ilengths - an array of integers of length sizeof(comm) 82 a non zero ilengths[i] represent a message to i of length ilengths[i] 83 84 85 Output Parameters: 86 + onodes - list of node-ids from which messages are expected 87 - olengths - corresponding message lengths 88 89 Level: developer 90 91 Concepts: mpi utility 92 93 Notes: 94 With this info, the correct MPI_Irecv() can be posted with the correct 95 from-id, with a buffer with the right amount of memory required. 96 97 The calling function deallocates the memory in onodes and olengths 98 99 To determine nrecevs, one can use PetscGatherNumberOfMessages() 100 101 .seealso: PetscGatherNumberOfMessages() 102 @*/ 103 PetscErrorCode PetscGatherMessageLengths(MPI_Comm comm,PetscMPIInt nsends,PetscMPIInt nrecvs,const PetscMPIInt ilengths[],PetscMPIInt **onodes,PetscMPIInt **olengths) 104 { 105 PetscErrorCode ierr; 106 PetscMPIInt size,tag,i,j; 107 MPI_Request *s_waits = PETSC_NULL,*r_waits = PETSC_NULL; 108 MPI_Status *w_status = PETSC_NULL; 109 110 PetscFunctionBegin; 111 ierr = MPI_Comm_size(comm,&size);CHKERRQ(ierr); 112 ierr = PetscCommGetNewTag(comm,&tag);CHKERRQ(ierr); 113 114 /* cannot use PetscMalloc3() here because in the call to MPI_Waitall() they MUST be contiguous */ 115 ierr = PetscMalloc2(nrecvs+nsends,MPI_Request,&r_waits,nrecvs+nsends,MPI_Status,&w_status);CHKERRQ(ierr); 116 s_waits = r_waits+nrecvs; 117 118 /* Post the Irecv to get the message length-info */ 119 ierr = PetscMalloc(nrecvs*sizeof(PetscMPIInt),olengths);CHKERRQ(ierr); 120 for (i=0; i<nrecvs; i++) { 121 ierr = MPI_Irecv((*olengths)+i,1,MPI_INT,MPI_ANY_SOURCE,tag,comm,r_waits+i);CHKERRQ(ierr); 122 } 123 124 /* Post the Isends with the message length-info */ 125 for (i=0,j=0; i<size; ++i) { 126 if (ilengths[i]) { 127 ierr = MPI_Isend((void*)(ilengths+i),1,MPI_INT,i,tag,comm,s_waits+j);CHKERRQ(ierr); 128 j++; 129 } 130 } 131 132 /* Post waits on sends and receivs */ 133 if (nrecvs+nsends) {ierr = MPI_Waitall(nrecvs+nsends,r_waits,w_status);CHKERRQ(ierr);} 134 135 /* Pack up the received data */ 136 ierr = PetscMalloc(nrecvs*sizeof(PetscMPIInt),onodes);CHKERRQ(ierr); 137 for (i=0; i<nrecvs; ++i) { 138 (*onodes)[i] = w_status[i].MPI_SOURCE; 139 } 140 ierr = PetscFree2(r_waits,w_status);CHKERRQ(ierr); 141 PetscFunctionReturn(0); 142 } 143 144 #undef __FUNCT__ 145 #define __FUNCT__ "PetscGatherMessageLengths2" 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. 150 151 Collective on MPI_Comm 152 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] 159 160 Output Parameters: 161 + onodes - list of node-ids from which messages are expected 162 - olengths1, olengths2 - corresponding message lengths 163 164 Level: developer 165 166 Concepts: mpi utility 167 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. 171 172 The calling function deallocates the memory in onodes and olengths 173 174 To determine nrecevs, one can use PetscGatherNumberOfMessages() 175 176 .seealso: PetscGatherMessageLengths() and PetscGatherNumberOfMessages() 177 @*/ 178 PetscErrorCode PetscGatherMessageLengths2(MPI_Comm comm,PetscMPIInt nsends,PetscMPIInt nrecvs,const PetscMPIInt ilengths1[],const PetscMPIInt ilengths2[],PetscMPIInt **onodes,PetscMPIInt **olengths1,PetscMPIInt **olengths2) 179 { 180 PetscErrorCode ierr; 181 PetscMPIInt size,tag,i,j,*buf_s = PETSC_NULL,*buf_r = PETSC_NULL,*buf_j = PETSC_NULL; 182 MPI_Request *s_waits = PETSC_NULL,*r_waits = PETSC_NULL; 183 MPI_Status *w_status = PETSC_NULL; 184 185 PetscFunctionBegin; 186 ierr = MPI_Comm_size(comm,&size);CHKERRQ(ierr); 187 ierr = PetscCommGetNewTag(comm,&tag);CHKERRQ(ierr); 188 189 /* cannot use PetscMalloc5() because r_waits and s_waits must be contiquous for the call to MPI_Waitall() */ 190 ierr = PetscMalloc4(nrecvs+nsends,MPI_Request,&r_waits,2*nrecvs,PetscMPIInt,&buf_r,2*nsends,PetscMPIInt,&buf_s,nrecvs+nsends,MPI_Status,&w_status);CHKERRQ(ierr); 191 s_waits = r_waits + nrecvs; 192 193 /* Post the Irecv to get the message length-info */ 194 ierr = PetscMalloc((nrecvs+1)*sizeof(PetscMPIInt),olengths1);CHKERRQ(ierr); 195 ierr = PetscMalloc((nrecvs+1)*sizeof(PetscMPIInt),olengths2);CHKERRQ(ierr); 196 for (i=0; i<nrecvs; i++) { 197 buf_j = buf_r + (2*i); 198 ierr = MPI_Irecv(buf_j,2,MPI_INT,MPI_ANY_SOURCE,tag,comm,r_waits+i);CHKERRQ(ierr); 199 } 200 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 ierr = MPI_Isend(buf_j,2,MPI_INT,i,tag,comm,s_waits+j);CHKERRQ(ierr); 208 j++; 209 } 210 } 211 212 /* Post waits on sends and receivs */ 213 if (nrecvs+nsends) {ierr = MPI_Waitall(nrecvs+nsends,r_waits,w_status);CHKERRQ(ierr);} 214 215 216 /* Pack up the received data */ 217 ierr = PetscMalloc((nrecvs+1)*sizeof(PetscMPIInt),onodes);CHKERRQ(ierr); 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 } 224 225 ierr = PetscFree4(r_waits,buf_r,buf_s,w_status);CHKERRQ(ierr); 226 PetscFunctionReturn(0); 227 } 228 229 /* 230 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 */ 235 #undef __FUNCT__ 236 #define __FUNCT__ "PetscPostIrecvInt" 237 PetscErrorCode PetscPostIrecvInt(MPI_Comm comm,PetscMPIInt tag,PetscMPIInt nrecvs,const PetscMPIInt onodes[],const PetscMPIInt olengths[],PetscInt ***rbuf,MPI_Request **r_waits) 238 { 239 PetscErrorCode ierr; 240 PetscInt **rbuf_t,i,len = 0; 241 MPI_Request *r_waits_t; 242 243 PetscFunctionBegin; 244 /* compute memory required for recv buffers */ 245 for (i=0; i<nrecvs; i++) len += olengths[i]; /* each message length */ 246 247 /* allocate memory for recv buffers */ 248 ierr = PetscMalloc((nrecvs+1)*sizeof(PetscInt*),&rbuf_t);CHKERRQ(ierr); 249 ierr = PetscMalloc(len*sizeof(PetscInt),&rbuf_t[0]);CHKERRQ(ierr); 250 for (i=1; i<nrecvs; ++i) rbuf_t[i] = rbuf_t[i-1] + olengths[i-1]; 251 252 /* Post the receives */ 253 ierr = PetscMalloc(nrecvs*sizeof(MPI_Request),&r_waits_t);CHKERRQ(ierr); 254 for (i=0; i<nrecvs; ++i) { 255 ierr = MPI_Irecv(rbuf_t[i],olengths[i],MPIU_INT,onodes[i],tag,comm,r_waits_t+i);CHKERRQ(ierr); 256 } 257 258 *rbuf = rbuf_t; 259 *r_waits = r_waits_t; 260 PetscFunctionReturn(0); 261 } 262 263 #undef __FUNCT__ 264 #define __FUNCT__ "PetscPostIrecvScalar" 265 PetscErrorCode PetscPostIrecvScalar(MPI_Comm comm,PetscMPIInt tag,PetscMPIInt nrecvs,const PetscMPIInt onodes[],const PetscMPIInt olengths[],PetscScalar ***rbuf,MPI_Request **r_waits) 266 { 267 PetscErrorCode ierr; 268 PetscMPIInt i; 269 PetscScalar **rbuf_t; 270 MPI_Request *r_waits_t; 271 PetscInt len = 0; 272 273 PetscFunctionBegin; 274 /* compute memory required for recv buffers */ 275 for (i=0; i<nrecvs; i++) len += olengths[i]; /* each message length */ 276 277 /* allocate memory for recv buffers */ 278 ierr = PetscMalloc((nrecvs+1)*sizeof(PetscScalar*),&rbuf_t);CHKERRQ(ierr); 279 ierr = PetscMalloc(len*sizeof(PetscScalar),&rbuf_t[0]);CHKERRQ(ierr); 280 for (i=1; i<nrecvs; ++i) rbuf_t[i] = rbuf_t[i-1] + olengths[i-1]; 281 282 /* Post the receives */ 283 ierr = PetscMalloc(nrecvs*sizeof(MPI_Request),&r_waits_t);CHKERRQ(ierr); 284 for (i=0; i<nrecvs; ++i) { 285 ierr = MPI_Irecv(rbuf_t[i],olengths[i],MPIU_SCALAR,onodes[i],tag,comm,r_waits_t+i);CHKERRQ(ierr); 286 } 287 288 *rbuf = rbuf_t; 289 *r_waits = r_waits_t; 290 PetscFunctionReturn(0); 291 } 292