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 #if defined(PETSC_THREADCOMM_ACTIVE) 141 PetscThreadComm tcomm; 142 #endif 143 144 PetscFunctionBegin; 145 ierr = MPI_Attr_get(comm_in,Petsc_Counter_keyval,&counter,&flg);CHKERRQ(ierr); 146 147 if (!flg) { /* this is NOT a PETSc comm */ 148 void *ptr; 149 /* check if this communicator has a PETSc communicator imbedded in it */ 150 ierr = MPI_Attr_get(comm_in,Petsc_InnerComm_keyval,&ptr,&flg);CHKERRQ(ierr); 151 if (!flg) { 152 /* This communicator is not yet known to this system, so we duplicate it and make an internal communicator */ 153 ierr = MPI_Comm_dup(comm_in,comm_out);CHKERRQ(ierr); 154 ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);CHKERRQ(ierr); 155 if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB"); 156 ierr = PetscMalloc(sizeof(PetscCommCounter),&counter);CHKERRQ(ierr); 157 counter->tag = *maxval; 158 counter->refcount = 0; 159 counter->namecount = 0; 160 ierr = MPI_Attr_put(*comm_out,Petsc_Counter_keyval,counter);CHKERRQ(ierr); 161 ierr = PetscInfo3(0,"Duplicating a communicator %ld %ld max tags = %d\n",(long)comm_in,(long)*comm_out,*maxval);CHKERRQ(ierr); 162 163 /* save PETSc communicator inside user communicator, so we can get it next time */ 164 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 165 ierr = PetscMemcpy(&ptr,comm_out,sizeof(MPI_Comm));CHKERRQ(ierr); 166 ierr = MPI_Attr_put(comm_in,Petsc_InnerComm_keyval,ptr);CHKERRQ(ierr); 167 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 168 ierr = PetscMemcpy(&ptr,&comm_in,sizeof(MPI_Comm));CHKERRQ(ierr); 169 ierr = MPI_Attr_put(*comm_out,Petsc_OuterComm_keyval,ptr);CHKERRQ(ierr); 170 } else { 171 /* pull out the inner MPI_Comm and hand it back to the caller */ 172 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 173 ierr = PetscMemcpy(comm_out,&ptr,sizeof(MPI_Comm));CHKERRQ(ierr); 174 ierr = MPI_Attr_get(*comm_out,Petsc_Counter_keyval,&counter,&flg);CHKERRQ(ierr); 175 if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"Inner PETSc communicator does not have its tag/name counter attribute set"); 176 ierr = PetscInfo2(0,"Using internal PETSc communicator %ld %ld\n",(long)comm_in,(long)*comm_out);CHKERRQ(ierr); 177 } 178 } else { 179 *comm_out = comm_in; 180 } 181 182 #if defined(PETSC_USE_DEBUG) 183 /* 184 Hanging here means that some processes have called PetscCommDuplicate() and others have not. 185 This likley means that a subset of processes in a MPI_Comm have attempted to create a PetscObject! 186 ALL processes that share a communicator MUST shared objects created from that communicator. 187 */ 188 ierr = MPI_Barrier(comm_in);CHKERRQ(ierr); 189 #endif 190 191 if (counter->tag < 1) { 192 ierr = PetscInfo1(0,"Out of tags for object, starting to recycle. Comm reference count %d\n",counter->refcount);CHKERRQ(ierr); 193 ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);CHKERRQ(ierr); 194 if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB"); 195 counter->tag = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */ 196 } 197 198 if (first_tag) { 199 *first_tag = counter->tag--; 200 } 201 202 #if defined(PETSC_THREADCOMM_ACTIVE) 203 /* Only the main thread updates counter->refcount */ 204 ierr = MPI_Attr_get(*comm_out,Petsc_ThreadComm_keyval,(PetscThreadComm*)&tcomm,&flg);CHKERRQ(ierr); 205 if (flg) { 206 PetscInt trank; 207 trank = PetscThreadCommGetRank(tcomm); 208 if (!trank) counter->refcount++; /* number of references to this comm */ 209 } else counter->refcount++; 210 #else 211 counter->refcount++; 212 #endif 213 214 PetscFunctionReturn(0); 215 } 216 217 #undef __FUNCT__ 218 #define __FUNCT__ "PetscCommDestroy" 219 /*@C 220 PetscCommDestroy - Frees communicator. Use in conjunction with PetscCommDuplicate(). 221 222 Collective on MPI_Comm 223 224 Input Parameter: 225 . comm - the communicator to free 226 227 Level: developer 228 229 Concepts: communicator^destroy 230 231 .seealso: PetscCommDuplicate() 232 @*/ 233 PetscErrorCode PetscCommDestroy(MPI_Comm *comm) 234 { 235 PetscErrorCode ierr; 236 PetscCommCounter *counter; 237 PetscMPIInt flg; 238 MPI_Comm icomm = *comm,ocomm; 239 void *ptr; 240 #if defined(PETSC_THREADCOMM_ACTIVE) 241 PetscThreadComm tcomm; 242 #endif 243 244 PetscFunctionBegin; 245 if (*comm == MPI_COMM_NULL) PetscFunctionReturn(0); 246 ierr = MPI_Attr_get(icomm,Petsc_Counter_keyval,&counter,&flg);CHKERRQ(ierr); 247 if (!flg) { /* not a PETSc comm, check if it has an inner comm */ 248 ierr = MPI_Attr_get(icomm,Petsc_InnerComm_keyval,&ptr,&flg);CHKERRQ(ierr); 249 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"); 250 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 251 ierr = PetscMemcpy(&icomm,&ptr,sizeof(MPI_Comm));CHKERRQ(ierr); 252 ierr = MPI_Attr_get(icomm,Petsc_Counter_keyval,&counter,&flg);CHKERRQ(ierr); 253 if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"Inner MPI_Comm does not have expected tag/name counter, problem with corrupted memory"); 254 } 255 256 #if defined(PETSC_THREADCOMM_ACTIVE) 257 /* Only the main thread updates counter->refcount */ 258 ierr = MPI_Attr_get(icomm,Petsc_ThreadComm_keyval,(PetscThreadComm*)&tcomm,&flg);CHKERRQ(ierr); 259 if(flg) { 260 PetscInt trank; 261 trank = PetscThreadCommGetRank(tcomm); 262 /* Only thread rank 0 updates the counter */ 263 if(!trank) counter->refcount--; 264 } else counter->refcount--; 265 #else 266 counter->refcount--; 267 #endif 268 269 if (!counter->refcount) { 270 /* if MPI_Comm has outer comm then remove reference to inner MPI_Comm from outer MPI_Comm */ 271 ierr = MPI_Attr_get(icomm,Petsc_OuterComm_keyval,&ptr,&flg);CHKERRQ(ierr); 272 if (flg) { 273 /* Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */ 274 ierr = PetscMemcpy(&ocomm,&ptr,sizeof(MPI_Comm));CHKERRQ(ierr); 275 ierr = MPI_Attr_get(ocomm,Petsc_InnerComm_keyval,&ptr,&flg);CHKERRQ(ierr); 276 if (flg) { 277 ierr = MPI_Attr_delete(ocomm,Petsc_InnerComm_keyval);CHKERRQ(ierr); 278 } 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); 279 } 280 281 ierr = PetscInfo1(0,"Deleting PETSc MPI_Comm %ld\n",(long)icomm);CHKERRQ(ierr); 282 ierr = MPI_Comm_free(&icomm);CHKERRQ(ierr); 283 } 284 *comm = MPI_COMM_NULL; 285 PetscFunctionReturn(0); 286 } 287 288 #undef __FUNCT__ 289 #define __FUNCT__ "PetscObjectsGetGlobalNumbering" 290 /*@C 291 PetscObjectsGetGlobalNumbering - computes a global numbering 292 of PetscObjects living on subcommunicators of a given communicator. 293 This results in a deadlock-free ordering of the subcommunicators 294 and, hence, the objects. 295 296 297 Collective on comm. 298 299 Input Parameters: 300 + comm - MPI_Comm 301 . len - length of objlist 302 - objlist - a list of PETSc objects living on subcommunicators of comm 303 (subcommunicator ordering is assumed to be deadlock-free) 304 305 Output Parameters: 306 + count - number of globally-distinct subcommunicators on objlist 307 . numbering - global numbers of objlist entries (allocated by user) 308 309 310 Level: developer 311 312 Concepts: MPI subcomm^numbering 313 314 @*/ 315 PetscErrorCode PetscObjectsGetGlobalNumbering(MPI_Comm comm, PetscInt len, PetscObject *objlist, PetscInt *count, PetscInt *numbering) 316 { 317 PetscErrorCode ierr; 318 PetscInt i, roots, offset; 319 PetscMPIInt size, rank; 320 PetscFunctionBegin; 321 PetscValidPointer(objlist,3); 322 PetscValidPointer(count,4); 323 PetscValidPointer(numbering,5); 324 ierr = MPI_Comm_size(comm, &size); CHKERRQ(ierr); 325 ierr = MPI_Comm_rank(comm, &rank); CHKERRQ(ierr); 326 roots = 0; 327 for(i = 0; i < len; ++i) { 328 PetscMPIInt srank; 329 ierr = MPI_Comm_rank(objlist[i]->comm, &srank); CHKERRQ(ierr); 330 /* Am I the root of the i-th subcomm? */ 331 if(!srank) ++roots; 332 } 333 /* Obtain the sum of all roots -- the global number of distinct subcomms. */ 334 ierr = MPI_Allreduce((void*)&roots,(void*)count,1,MPIU_INT,MPI_SUM,comm); CHKERRQ(ierr); 335 /* Now introduce a global numbering for subcomms, initially known only by subcomm roots. */ 336 /* 337 At the subcomm roots number the subcomms in the subcomm-root local manner, 338 and make it global by calculating the shift. 339 */ 340 ierr = MPI_Scan((PetscMPIInt*)&roots,(PetscMPIInt*)&offset,1,MPIU_INT,MPI_SUM,comm); CHKERRQ(ierr); 341 offset -= roots; 342 /* Now we are ready to broadcast global subcomm numbers within each subcomm.*/ 343 /* 344 This is where the assumption of a deadlock-free ordering of the subcomms is assumed: 345 broadcast is collective on the subcomm. 346 */ 347 roots = 0; 348 for(i = 0; i < len; ++i) { 349 PetscMPIInt srank; 350 numbering[i] = offset + roots; /* only meaningful if !srank. */ 351 ierr = MPI_Comm_rank(objlist[i]->comm, &srank); CHKERRQ(ierr); 352 ierr = MPI_Bcast(numbering+i,1,MPIU_INT,0,objlist[i]->comm); CHKERRQ(ierr); 353 if(!srank) ++roots; 354 } 355 356 PetscFunctionReturn(0); 357 } 358