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