Actual source code: tagm.c

petsc-3.8.3 2017-12-09
Report Typos and Errors

  2: /*
  3:       Some PETSc utilites
  4: */
  5:  #include <petsc/private/petscimpl.h>
  6: /* ---------------------------------------------------------------- */
  7: /*
  8:    A simple way to manage tags inside a communicator.

 10:    It uses the attributes to determine if a new communicator
 11:       is needed and to store the available tags.

 13: */


 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.

 22:     Collective on PetscObject

 24:     Input Parameter:
 25: .   obj - the PETSc object; this must be cast with a (PetscObject), for example,
 26:          PetscObjectGetNewTag((PetscObject)mat,&tag);

 28:     Output Parameter:
 29: .   tag - the new tag

 31:     Level: developer

 33:     Concepts: tag^getting
 34:     Concepts: message tag^getting
 35:     Concepts: MPI message tag^getting

 37: .seealso: PetscCommGetNewTag()
 38: @*/
 39: PetscErrorCode  PetscObjectGetNewTag(PetscObject obj,PetscMPIInt *tag)
 40: {

 44:   PetscCommGetNewTag(obj->comm,tag);
 45:   return(0);
 46: }

 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.

 54:     Collective on comm

 56:     Input Parameter:
 57: .   comm - the MPI communicator

 59:     Output Parameter:
 60: .   tag - the new tag

 62:     Level: developer

 64:     Concepts: tag^getting
 65:     Concepts: message tag^getting
 66:     Concepts: MPI message tag^getting

 68: .seealso: PetscObjectGetNewTag(), PetscCommDuplicate()
 69: @*/
 70: PetscErrorCode  PetscCommGetNewTag(MPI_Comm comm,PetscMPIInt *tag)
 71: {
 72:   PetscErrorCode   ierr;
 73:   PetscCommCounter *counter;
 74:   PetscMPIInt      *maxval,flg;


 79:   MPI_Attr_get(comm,Petsc_Counter_keyval,&counter,&flg);
 80:   if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"Bad MPI communicator supplied; must be a PETSc communicator");

 82:   if (counter->tag < 1) {
 83:     PetscInfo1(0,"Out of tags for object, starting to recycle. Comm reference count %d\n",counter->refcount);
 84:     MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);
 85:     if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"MPI error: MPI_Attr_get() 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:   }

 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:   MPI_Barrier(comm);
 95: #endif
 96:   return(0);
 97: }

 99: /*@C
100:   PetscCommDuplicate - Duplicates the communicator only if it is not already a PETSc communicator.

102:   Collective on MPI_Comm

104:   Input Parameters:
105: . comm_in - Input communicator

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)

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.

118:   Level: developer

120:   Concepts: communicator^duplicate

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;

131:   PetscSpinlockLock(&PetscCommSpinLock);
132:   MPI_Attr_get(comm_in,Petsc_Counter_keyval,&counter,&flg);

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:     MPI_Attr_get(comm_in,Petsc_InnerComm_keyval,&ucomm,&flg);
138:     if (!flg) {
139:       /* This communicator is not yet known to this system, so we duplicate it and make an internal communicator */
140:       MPI_Comm_dup(comm_in,comm_out);
141:       MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);
142:       if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
143:       PetscNew(&counter);

145:       counter->tag       = *maxval;
146:       counter->refcount  = 0;
147:       counter->namecount = 0;

149:       MPI_Attr_put(*comm_out,Petsc_Counter_keyval,counter);
150:       PetscInfo3(0,"Duplicating a communicator %ld %ld max tags = %d\n",(long)comm_in,(long)*comm_out,*maxval);

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:       MPI_Attr_put(comm_in,Petsc_InnerComm_keyval,ucomm.ptr);
155:       ucomm.comm = comm_in;
156:       MPI_Attr_put(*comm_out,Petsc_OuterComm_keyval,ucomm.ptr);
157:     } else {
158:       *comm_out = ucomm.comm;
159:       /* pull out the inner MPI_Comm and hand it back to the caller */
160:       MPI_Attr_get(*comm_out,Petsc_Counter_keyval,&counter,&flg);
161:       if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"Inner PETSc communicator does not have its tag/name counter attribute set");
162:       PetscInfo2(0,"Using internal PETSc communicator %ld %ld\n",(long)comm_in,(long)*comm_out);
163:     }
164:   } else *comm_out = comm_in;

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:   MPI_Barrier(comm_in);
173: #endif

175:   if (counter->tag < 1) {
176:     PetscInfo1(0,"Out of tags for object, starting to recycle. Comm reference count %d\n",counter->refcount);
177:     MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);
178:     if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"MPI error: MPI_Attr_get() 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:   }

182:   if (first_tag) *first_tag = counter->tag--;

184:   counter->refcount++; /* number of references to this comm */
185:   PetscSpinlockUnlock(&PetscCommSpinLock);
186:   return(0);
187: }

189: /*@C
190:    PetscCommDestroy - Frees communicator.  Use in conjunction with PetscCommDuplicate().

192:    Collective on MPI_Comm

194:    Input Parameter:
195: .  comm - the communicator to free

197:    Level: developer

199:    Concepts: communicator^destroy

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;

212:   if (*comm == MPI_COMM_NULL) return(0);
213:   PetscSpinlockLock(&PetscCommSpinLock);
214:   MPI_Attr_get(icomm,Petsc_Counter_keyval,&counter,&flg);
215:   if (!flg) { /* not a PETSc comm, check if it has an inner comm */
216:     MPI_Attr_get(icomm,Petsc_InnerComm_keyval,&ucomm,&flg);
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:     MPI_Attr_get(icomm,Petsc_Counter_keyval,&counter,&flg);
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:   }

223:   counter->refcount--;

225:   if (!counter->refcount) {
226:     /* if MPI_Comm has outer comm then remove reference to inner MPI_Comm from outer MPI_Comm */
227:     MPI_Attr_get(icomm,Petsc_OuterComm_keyval,&ucomm,&flg);
228:     if (flg) {
229:       ocomm = ucomm.comm;
230:       MPI_Attr_get(ocomm,Petsc_InnerComm_keyval,&ucomm,&flg);
231:       if (flg) {
232:         MPI_Attr_delete(ocomm,Petsc_InnerComm_keyval);
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:     }

236:     PetscInfo1(0,"Deleting PETSc MPI_Comm %ld\n",(long)icomm);
237:     MPI_Comm_free(&icomm);
238:   }
239:   *comm = MPI_COMM_NULL;
240:   PetscSpinlockUnlock(&PetscCommSpinLock);
241:   return(0);
242: }

244: /*@C
245:     PetscObjectsListGetGlobalNumbering - computes a global numbering
246:     of PetscObjects living on subcommunicators of a given communicator.


249:     Collective on comm.

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)

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)


262:     Level: developer

264:     Concepts: MPI subcomm^numbering

266: @*/
267: PetscErrorCode  PetscObjectsListGetGlobalNumbering(MPI_Comm comm, PetscInt len, PetscObject *objlist, PetscInt *count, PetscInt *numbering)
268: {
270:   PetscInt       i, roots, offset;
271:   PetscMPIInt    size, rank;

275:   if (!count && !numbering) return(0);

277:   MPI_Comm_size(comm, &size);
278:   MPI_Comm_rank(comm, &rank);
279:   roots = 0;
280:   for (i = 0; i < len; ++i) {
281:     PetscMPIInt srank;
282:     MPI_Comm_rank(objlist[i]->comm, &srank);
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:     MPIU_Allreduce(&roots,count,1,MPIU_INT,MPI_SUM,comm);
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:     MPI_Scan(&roots,&offset,1,MPIU_INT,MPI_SUM,comm);
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. */

309:       MPI_Comm_rank(objlist[i]->comm, &srank);
310:       MPI_Bcast(numbering+i,1,MPIU_INT,0,objlist[i]->comm);
311:       if (!srank) ++roots;
312:     }
313:   }
314:   return(0);
315: }