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