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