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