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 = PetscNew(&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__ "PetscObjectsListGetGlobalNumbering" 269 /*@C 270 PetscObjectsListGetGlobalNumbering - computes a global numbering 271 of PetscObjects living on subcommunicators of a given communicator. 272 273 274 Collective on comm. 275 276 Input Parameters: 277 + comm - MPI_Comm 278 . len - local length of objlist 279 - objlist - a list of PETSc objects living on subcomms of comm and containing this comm rank 280 (subcomm ordering is assumed to be deadlock-free) 281 282 Output Parameters: 283 + count - global number of distinct subcommunicators on objlist (may be > len) 284 - numbering - global numbers of objlist entries (allocated by user) 285 286 287 Level: developer 288 289 Concepts: MPI subcomm^numbering 290 291 @*/ 292 PetscErrorCode PetscObjectsListGetGlobalNumbering(MPI_Comm comm, PetscInt len, PetscObject *objlist, PetscInt *count, PetscInt *numbering) 293 { 294 PetscErrorCode ierr; 295 PetscInt i, roots, offset; 296 PetscMPIInt size, rank; 297 298 PetscFunctionBegin; 299 PetscValidPointer(objlist,3); 300 if (!count && !numbering) PetscFunctionReturn(0); 301 302 ierr = MPI_Comm_size(comm, &size);CHKERRQ(ierr); 303 ierr = MPI_Comm_rank(comm, &rank);CHKERRQ(ierr); 304 roots = 0; 305 for (i = 0; i < len; ++i) { 306 PetscMPIInt srank; 307 ierr = MPI_Comm_rank(objlist[i]->comm, &srank);CHKERRQ(ierr); 308 /* Am I the root of the i-th subcomm? */ 309 if (!srank) ++roots; 310 } 311 if (count) { 312 /* Obtain the sum of all roots -- the global number of distinct subcomms. */ 313 ierr = MPI_Allreduce(&roots,count,1,MPIU_INT,MPI_SUM,comm);CHKERRQ(ierr); 314 } 315 if (numbering) { 316 /* Introduce a global numbering for subcomms, initially known only by subcomm roots. */ 317 /* 318 At each subcomm root number all of the subcomms it owns locally 319 and make it global by calculating the shift among all of the roots. 320 The roots are ordered using the comm ordering. 321 */ 322 ierr = MPI_Scan(&roots,&offset,1,MPIU_INT,MPI_SUM,comm);CHKERRQ(ierr); 323 offset -= roots; 324 /* Now we are ready to broadcast global subcomm numbers within each subcomm.*/ 325 /* 326 This is where the assumption of a deadlock-free ordering of the subcomms is assumed: 327 broadcast is collective on the subcomm. 328 */ 329 roots = 0; 330 for (i = 0; i < len; ++i) { 331 PetscMPIInt srank; 332 numbering[i] = offset + roots; /* only meaningful if !srank. */ 333 334 ierr = MPI_Comm_rank(objlist[i]->comm, &srank);CHKERRQ(ierr); 335 ierr = MPI_Bcast(numbering+i,1,MPIU_INT,0,objlist[i]->comm);CHKERRQ(ierr); 336 if (!srank) ++roots; 337 } 338 } 339 PetscFunctionReturn(0); 340 } 341