1 2 /* 3 Some PETSc utilites 4 */ 5 #include <petscsys.h> /*I "petscsys.h" I*/ 6 #if defined(PETSC_HAVE_STDLIB_H) 7 #include <stdlib.h> 8 #endif 9 10 #include <petsc-private/threadcommimpl.h> 11 /* ---------------------------------------------------------------- */ 12 /* 13 A simple way to manage tags inside a communicator. 14 15 It uses the attributes to determine if a new communicator 16 is needed and to store the available tags. 17 18 */ 19 20 21 #undef __FUNCT__ 22 #define __FUNCT__ "PetscObjectGetNewTag" 23 /*@C 24 PetscObjectGetNewTag - Gets a unique new tag from a PETSc object. All 25 processors that share the object MUST call this routine EXACTLY the same 26 number of times. This tag should only be used with the current objects 27 communicator; do NOT use it with any other MPI communicator. 28 29 Collective on PetscObject 30 31 Input Parameter: 32 . obj - the PETSc object; this must be cast with a (PetscObject), for example, 33 PetscObjectGetNewTag((PetscObject)mat,&tag); 34 35 Output Parameter: 36 . tag - the new tag 37 38 Level: developer 39 40 Concepts: tag^getting 41 Concepts: message tag^getting 42 Concepts: MPI message tag^getting 43 44 .seealso: PetscCommGetNewTag() 45 @*/ 46 PetscErrorCode PetscObjectGetNewTag(PetscObject obj,PetscMPIInt *tag) 47 { 48 PetscErrorCode ierr; 49 50 PetscFunctionBegin; 51 ierr = PetscCommGetNewTag(obj->comm,tag);CHKERRQ(ierr); 52 PetscFunctionReturn(0); 53 } 54 55 #undef __FUNCT__ 56 #define __FUNCT__ "PetscCommGetNewTag" 57 /*@ 58 PetscCommGetNewTag - Gets a unique new tag from a PETSc communicator. All 59 processors that share the communicator MUST call this routine EXACTLY the same 60 number of times. This tag should only be used with the current objects 61 communicator; do NOT use it with any other MPI communicator. 62 63 Collective on comm 64 65 Input Parameter: 66 . comm - the MPI communicator 67 68 Output Parameter: 69 . tag - the new tag 70 71 Level: developer 72 73 Concepts: tag^getting 74 Concepts: message tag^getting 75 Concepts: MPI message tag^getting 76 77 .seealso: PetscObjectGetNewTag(), PetscCommDuplicate() 78 @*/ 79 PetscErrorCode PetscCommGetNewTag(MPI_Comm comm,PetscMPIInt *tag) 80 { 81 PetscErrorCode ierr; 82 PetscCommCounter *counter; 83 PetscMPIInt *maxval,flg; 84 85 PetscFunctionBegin; 86 PetscValidIntPointer(tag,2); 87 88 ierr = MPI_Attr_get(comm,Petsc_Counter_keyval,&counter,&flg);CHKERRQ(ierr); 89 if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"Bad MPI communicator supplied; must be a PETSc communicator"); 90 91 if (counter->tag < 1) { 92 ierr = PetscInfo1(0,"Out of tags for object, starting to recycle. Comm reference count %d\n",counter->refcount);CHKERRQ(ierr); 93 ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);CHKERRQ(ierr); 94 if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB"); 95 counter->tag = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */ 96 } 97 98 *tag = counter->tag--; 99 #if defined(PETSC_USE_DEBUG) 100 /* 101 Hanging here means that some processes have called PetscCommGetNewTag() and others have not. 102 */ 103 ierr = MPI_Barrier(comm);CHKERRQ(ierr); 104 #endif 105 PetscFunctionReturn(0); 106 } 107 108 #undef __FUNCT__ 109 #define __FUNCT__ "PetscCommDuplicate" 110 /*@C 111 PetscCommDuplicate - Duplicates the communicator only if it is not already a PETSc communicator. 112 113 Collective on MPI_Comm 114 115 Input Parameters: 116 . comm_in - Input communicator 117 118 Output Parameters: 119 + comm_out - Output communicator. May be comm_in. 120 - first_tag - Tag available that has not already been used with this communicator (you may 121 pass in PETSC_NULL if you do not need a tag) 122 123 PETSc communicators are just regular MPI communicators that keep track of which 124 tags have been used to prevent tag conflict. If you pass a non-PETSc communicator into 125 a PETSc creation routine it will attach a private communicator for use in the objects communications. 126 The internal MPI_Comm is used to perform all the MPI calls for PETSc, the outer MPI_Comm is a user 127 level MPI_Comm that may be performing communication for the user or other library and so IS NOT used by PETSc. 128 129 Level: developer 130 131 Concepts: communicator^duplicate 132 133 .seealso: PetscObjectGetNewTag(), PetscCommGetNewTag(), PetscCommDestroy() 134 @*/ 135 PetscErrorCode PetscCommDuplicate(MPI_Comm comm_in,MPI_Comm *comm_out,PetscMPIInt* first_tag) 136 { 137 PetscErrorCode ierr; 138 PetscCommCounter *counter; 139 PetscMPIInt *maxval,flg; 140 PetscThreadComm tcomm; 141 142 PetscFunctionBegin; 143 ierr = MPI_Attr_get(comm_in,Petsc_Counter_keyval,&counter,&flg);CHKERRQ(ierr); 144 145 if (!flg) { /* this is NOT a PETSc comm */ 146 void *ptr; 147 /* check if this communicator has a PETSc communicator imbedded in it */ 148 ierr = MPI_Attr_get(comm_in,Petsc_InnerComm_keyval,&ptr,&flg);CHKERRQ(ierr); 149 if (!flg) { 150 /* This communicator is not yet known to this system, so we duplicate it and make an internal communicator */ 151 ierr = MPI_Comm_dup(comm_in,comm_out);CHKERRQ(ierr); 152 ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);CHKERRQ(ierr); 153 if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB"); 154 ierr = PetscMalloc(sizeof(PetscCommCounter),&counter);CHKERRQ(ierr); 155 counter->tag = *maxval; 156 counter->refcount = 0; 157 counter->namecount = 0; 158 ierr = MPI_Attr_put(*comm_out,Petsc_Counter_keyval,counter);CHKERRQ(ierr); 159 ierr = PetscInfo3(0,"Duplicating a communicator %ld %ld max tags = %d\n",(long)comm_in,(long)*comm_out,*maxval);CHKERRQ(ierr); 160 161 /* save PETSc communicator inside user communicator, so we can get it next time */ 162 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 163 ierr = PetscMemcpy(&ptr,comm_out,sizeof(MPI_Comm));CHKERRQ(ierr); 164 ierr = MPI_Attr_put(comm_in,Petsc_InnerComm_keyval,ptr);CHKERRQ(ierr); 165 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 166 ierr = PetscMemcpy(&ptr,&comm_in,sizeof(MPI_Comm));CHKERRQ(ierr); 167 ierr = MPI_Attr_put(*comm_out,Petsc_OuterComm_keyval,ptr);CHKERRQ(ierr); 168 } else { 169 /* pull out the inner MPI_Comm and hand it back to the caller */ 170 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 171 ierr = PetscMemcpy(comm_out,&ptr,sizeof(MPI_Comm));CHKERRQ(ierr); 172 ierr = MPI_Attr_get(*comm_out,Petsc_Counter_keyval,&counter,&flg);CHKERRQ(ierr); 173 if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"Inner PETSc communicator does not have its tag/name counter attribute set"); 174 ierr = PetscInfo2(0,"Using internal PETSc communicator %ld %ld\n",(long)comm_in,(long)*comm_out);CHKERRQ(ierr); 175 } 176 } else { 177 *comm_out = comm_in; 178 } 179 180 #if defined(PETSC_USE_DEBUG) 181 /* 182 Hanging here means that some processes have called PetscCommDuplicate() and others have not. 183 This likley means that a subset of processes in a MPI_Comm have attempted to create a PetscObject! 184 ALL processes that share a communicator MUST shared objects created from that communicator. 185 */ 186 ierr = MPI_Barrier(comm_in);CHKERRQ(ierr); 187 #endif 188 189 if (counter->tag < 1) { 190 ierr = PetscInfo1(0,"Out of tags for object, starting to recycle. Comm reference count %d\n",counter->refcount);CHKERRQ(ierr); 191 ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);CHKERRQ(ierr); 192 if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB"); 193 counter->tag = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */ 194 } 195 196 if (first_tag) { 197 *first_tag = counter->tag--; 198 } 199 200 #if defined(PETSC_THREADCOMM_ACTIVE) 201 /* Only the main thread updates counter->refcount */ 202 ierr = MPI_Attr_get(*comm_out,Petsc_ThreadComm_keyval,(PetscThreadComm*)&tcomm,&flg);CHKERRQ(ierr); 203 if (flg) { 204 PetscInt trank; 205 trank = PetscThreadCommGetRank(tcomm); 206 if (!trank) counter->refcount++; /* number of references to this comm */ 207 } else counter->refcount++; 208 #else 209 counter->refcount++; 210 #endif 211 212 PetscFunctionReturn(0); 213 } 214 215 #undef __FUNCT__ 216 #define __FUNCT__ "PetscCommDestroy" 217 /*@C 218 PetscCommDestroy - Frees communicator. Use in conjunction with PetscCommDuplicate(). 219 220 Collective on MPI_Comm 221 222 Input Parameter: 223 . comm - the communicator to free 224 225 Level: developer 226 227 Concepts: communicator^destroy 228 229 .seealso: PetscCommDuplicate() 230 @*/ 231 PetscErrorCode PetscCommDestroy(MPI_Comm *comm) 232 { 233 PetscErrorCode ierr; 234 PetscCommCounter *counter; 235 PetscMPIInt flg; 236 MPI_Comm icomm = *comm,ocomm; 237 void *ptr; 238 PetscThreadComm tcomm; 239 240 PetscFunctionBegin; 241 ierr = MPI_Attr_get(icomm,Petsc_Counter_keyval,&counter,&flg);CHKERRQ(ierr); 242 if (!flg) { /* not a PETSc comm, check if it has an inner comm */ 243 ierr = MPI_Attr_get(icomm,Petsc_InnerComm_keyval,&ptr,&flg);CHKERRQ(ierr); 244 if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"MPI_Comm does not have tag/name counter nor does it have inner MPI_Comm"); 245 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 246 ierr = PetscMemcpy(&icomm,&ptr,sizeof(MPI_Comm));CHKERRQ(ierr); 247 ierr = MPI_Attr_get(icomm,Petsc_Counter_keyval,&counter,&flg);CHKERRQ(ierr); 248 if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"Inner MPI_Comm does not have expected tag/name counter, problem with corrupted memory"); 249 } 250 251 #if defined(PETSC_THREADCOMM_ACTIVE) 252 /* Only the main thread updates counter->refcount */ 253 ierr = MPI_Attr_get(icomm,Petsc_ThreadComm_keyval,(PetscThreadComm*)&tcomm,&flg);CHKERRQ(ierr); 254 if(flg) { 255 PetscInt trank; 256 trank = PetscThreadCommGetRank(tcomm); 257 /* Only thread rank 0 updates the counter */ 258 if(!trank) counter->refcount--; 259 } else counter->refcount--; 260 #else 261 counter->refcount--; 262 #endif 263 264 if (!counter->refcount) { 265 /* if MPI_Comm has outer comm then remove reference to inner MPI_Comm from outer MPI_Comm */ 266 ierr = MPI_Attr_get(icomm,Petsc_OuterComm_keyval,&ptr,&flg);CHKERRQ(ierr); 267 if (flg) { 268 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 269 ierr = PetscMemcpy(&ocomm,&ptr,sizeof(MPI_Comm));CHKERRQ(ierr); 270 ierr = MPI_Attr_get(ocomm,Petsc_InnerComm_keyval,&ptr,&flg);CHKERRQ(ierr); 271 if (flg) { 272 ierr = MPI_Attr_delete(ocomm,Petsc_InnerComm_keyval);CHKERRQ(ierr); 273 } else SETERRQ2(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"Outer MPI_Comm %ld does not have expected reference to inner comm %d, problem with corrupted memory",(long int)ocomm,(long int)icomm); 274 } 275 276 ierr = PetscInfo1(0,"Deleting PETSc MPI_Comm %ld\n",(long)icomm);CHKERRQ(ierr); 277 ierr = MPI_Comm_free(&icomm);CHKERRQ(ierr); 278 } 279 *comm = 0; 280 PetscFunctionReturn(0); 281 } 282 283 #undef __FUNCT__ 284 #define __FUNCT__ "PetscObjectListGetGlobalNumbering" 285 /*@C 286 PetscObjectListGetGlobalNumbering - computes a global numbering 287 of PetscObjects living on subcommunicators of a given communicator. 288 This results in a deadlock-free ordering of the subcommunicators 289 and, hence, the objects. 290 291 292 Collective on comm. 293 294 Input Parameters: 295 + comm - MPI_Comm 296 . len - length of objlist 297 - objlist - a list of PETSc objects living on subcommunicators of comm 298 (subcommunicator ordering is assumed to be deadlock-free) 299 300 Output Parameters: 301 + count - number of globally-distinct subcommunicators on objlist 302 . numbering - global numbers of objlist entries (allocated by user) 303 304 305 Level: developer 306 307 Concepts: MPI subcomm^numbering 308 309 .seealso: PetscObjectListOrder() 310 @*/ 311 PetscErrorCode PetscObjectListGetGlobalNumbering(MPI_Comm comm, PetscInt len, PetscObject *objlist, PetscInt *count, PetscInt *numbering) 312 { 313 PetscErrorCode ierr; 314 PetscInt i, roots, offset; 315 PetscMPIInt rank, r0 = 0, r; 316 MPI_Group group, subgroup; 317 PetscFunctionBegin; 318 PetscValidPointer(objlist,3); 319 /* Identify comm ranks of subcomm roots. What makes it work is that MPI_Group_translate_ranks is not collective. */ 320 ierr = MPI_Comm_rank(comm, &rank); CHKERRQ(ierr); 321 ierr = MPI_Comm_group(comm, &group); CHKERRQ(ierr); 322 roots = 0; 323 for(i = 0; i < len; ++i) { 324 ierr = MPI_Comm_group(objlist[i]->comm, &subgroup); CHKERRQ(ierr); 325 ierr = MPI_Group_translate_ranks(subgroup, 1,&r0,group,&r); CHKERRQ(ierr); 326 if(r == MPI_UNDEFINED) SETERRQ1(objlist[i]->comm, PETSC_ERR_ARG_WRONG, "Cannot determine global rank of the root of local subcomm %D", i); CHKERRQ(ierr); 327 /* Am I the root of the i-th subcomm? */ 328 if(r == rank) ++roots; 329 } 330 if(count) { 331 /* Obtain the sum of all roots -- the global number of distinct subcomms. */ 332 ierr = MPI_Allreduce((void*)&roots,(void*)count,1,MPIU_INT,MPI_SUM,comm); CHKERRQ(ierr); 333 } 334 /* Now introduce a global numbering for subcomms, initially known only by subcomm roots. */ 335 /* 336 At the subcomm roots number the subcomms in the subcomm-root local manner, 337 and make it global by calculating the shift. 338 */ 339 ierr = MPI_Scan((PetscMPIInt*)&roots,(PetscMPIInt*)&offset,1,MPI_INT,MPI_SUM,comm); CHKERRQ(ierr); 340 offset -= roots; 341 /* Now we are ready to communicate global subcomm numbers from subcomm roots to the other subcomm ranks.*/ 342 /* Communication proceeds one subcomm at a time: here the deadlock-free ordering assumption is used. */ 343 for(i = 0; i < len; ++i) { 344 PetscInt num = offset + i; 345 PetscMPIInt srank, ssize, tag, j; 346 MPI_Request *sreq, rreq; 347 /* Subcomm rank and size. */ 348 ierr = MPI_Comm_size(objlist[i]->comm, &ssize); CHKERRQ(ierr); 349 ierr = MPI_Comm_rank(objlist[i]->comm, &srank); CHKERRQ(ierr); 350 /* Obtain a subcomm tag. */ 351 ierr = PetscCommGetNewTag(objlist[i]->comm, &tag); CHKERRQ(ierr); 352 /* Post receives first. */ 353 ierr = MPI_Irecv((PetscMPIInt*)(numbering+i),1,MPI_INT,0,tag,objlist[i]->comm, &rreq); CHKERRQ(ierr); 354 /* Only the subcomm root posts the sends. */ 355 if(!srank) { 356 ierr = PetscMalloc(sizeof(MPI_Request)*ssize, &sreq); CHKERRQ(ierr); 357 for(j = 0; j < ssize; ++j) { 358 ierr = MPI_Isend((PetscMPIInt*)&num,1,MPI_INT,j,tag,objlist[i]->comm,sreq+j); CHKERRQ(ierr); 359 } 360 } 361 /* Now we wait on receives. */ 362 ierr = MPI_Wait(&rreq, MPI_STATUS_IGNORE); CHKERRQ(ierr); 363 /* And finally we wait on the sends. */ 364 ierr = MPI_Waitall(ssize,sreq,MPI_STATUSES_IGNORE); CHKERRQ(ierr); 365 ierr = PetscFree(sreq); CHKERRQ(ierr); 366 } 367 368 PetscFunctionReturn(0); 369 } 370