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