Actual source code: tagm.c

  1: #define PETSC_DLL
  2: /*
  3:       Some PETSc utilites
  4: */
 5:  #include petscsys.h
  6: #if defined(PETSC_HAVE_STDLIB_H)
  7: #include <stdlib.h>
  8: #endif

 10: /* ---------------------------------------------------------------- */
 11: /*
 12:    A simple way to manage tags inside a communicator.  

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

 17:    Notes on the implementation

 19:    The tagvalues to use are stored in a two element array.  The first element
 20:    is the first free tag value.  The second is used to indicate how
 21:    many "copies" of the communicator there are used in destroying.

 23:   
 24: */

 26: static PetscMPIInt Petsc_Tag_keyval       = MPI_KEYVAL_INVALID;
 27: static PetscMPIInt Petsc_InnerComm_keyval = MPI_KEYVAL_INVALID;
 28: static PetscMPIInt Petsc_OuterComm_keyval = MPI_KEYVAL_INVALID;
 32: /*
 33:    Private routine to delete internal storage when a communicator is freed.
 34:   This is called by MPI, not by users.

 38: */
 39: PetscMPIInt  Petsc_DelTag(MPI_Comm comm,PetscMPIInt keyval,void* attr_val,void* extra_state)
 40: {

 44:   PetscInfo1(0,"Deleting tag data in an MPI_Comm %ld\n",(long)comm);if (ierr) PetscFunctionReturn((PetscMPIInt)ierr);
 45:   PetscFree(attr_val);if (ierr) PetscFunctionReturn((PetscMPIInt)ierr);
 46:   PetscFunctionReturn(MPI_SUCCESS);
 47: }

 53: /*
 54:    Private routine to delete internal storage when a communicator is freed.
 55:   This is called by MPI, not by users.

 59: */
 60: PetscMPIInt  Petsc_DelComm(MPI_Comm comm,PetscMPIInt keyval,void* attr_val,void* extra_state)
 61: {

 65:   PetscInfo1(0,"Deleting PETSc communicator imbedded in a user MPI_Comm %ld\n",(long)comm);if (ierr) PetscFunctionReturn((PetscMPIInt)ierr);
 66:   /* actually don't delete anything because we cannot increase the reference count of the communicator anyways */
 67:   PetscFunctionReturn(MPI_SUCCESS);
 68: }

 73: /*@C
 74:     PetscObjectGetNewTag - Gets a unique new tag from a PETSc object. All 
 75:     processors that share the object MUST call this routine EXACTLY the same
 76:     number of times.  This tag should only be used with the current objects
 77:     communicator; do NOT use it with any other MPI communicator.

 79:     Collective on PetscObject

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

 85:     Output Parameter:
 86: .   tag - the new tag

 88:     Level: developer

 90:     Concepts: tag^getting
 91:     Concepts: message tag^getting
 92:     Concepts: MPI message tag^getting

 94: .seealso: PetscCommGetNewTag()
 95: @*/
 96: PetscErrorCode  PetscObjectGetNewTag(PetscObject obj,PetscMPIInt *tag)
 97: {

101:   PetscCommGetNewTag(obj->comm,tag);
102:   return(0);
103: }

107: /*@
108:     PetscCommGetNewTag - Gets a unique new tag from a PETSc communicator. All 
109:     processors that share the communicator MUST call this routine EXACTLY the same
110:     number of times.  This tag should only be used with the current objects
111:     communicator; do NOT use it with any other MPI communicator.

113:     Collective on comm

115:     Input Parameter:
116: .   comm - the PETSc communicator

118:     Output Parameter:
119: .   tag - the new tag

121:     Level: developer

123:     Concepts: tag^getting
124:     Concepts: message tag^getting
125:     Concepts: MPI message tag^getting

127: .seealso: PetscObjectGetNewTag(), PetscCommDuplicate()
128: @*/
129: PetscErrorCode  PetscCommGetNewTag(MPI_Comm comm,PetscMPIInt *tag)
130: {
132:   PetscMPIInt    *tagvalp=0,*maxval;
133:   PetscTruth     flg;


138:   if (Petsc_Tag_keyval == MPI_KEYVAL_INVALID) {
139:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelTag,&Petsc_Tag_keyval,(void*)0);
140:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_InnerComm_keyval,(void*)0);
141:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_OuterComm_keyval,(void*)0);
142:   }

144:   MPI_Attr_get(comm,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);
145:   if (!flg) SETERRQ(PETSC_ERR_ARG_CORRUPT,"Bad MPI communicator supplied; must be a PETSc communicator");

147:   if (tagvalp[0] < 1) {
148:     PetscInfo1(0,"Out of tags for object, starting to recycle. Comm reference count %d\n",tagvalp[1]);
149:     MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(PetscMPIInt*)&flg);
150:     if (!flg) {
151:       SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
152:     }
153:     tagvalp[0] = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
154:   }

156:   *tag = tagvalp[0]--;
157:   return(0);
158: }

162: PetscErrorCode  PetscCommSynchronizeTags(MPI_Comm comm)
163: {
164:   PetscMPIInt   *tagvalp = 0, tag;
165:   PetscTruth     flg;

169:   MPI_Attr_get(comm, Petsc_Tag_keyval, (void **) &tagvalp, (PetscMPIInt *) &flg);
170:   if (!flg) {
171:     MPI_Comm innerComm;
172:     void    *ptr;

174:     /* check if this communicator has a PETSc communicator imbedded in it */
175:     MPI_Attr_get(comm, Petsc_InnerComm_keyval, &ptr, (PetscMPIInt*) &flg);
176:     if (!flg) {
177:       SETERRQ(PETSC_ERR_ARG_CORRUPT,"Bad MPI communicator supplied; must be a PETSc communicator");
178:     } else {
179:       /* We use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */
180:       PetscMemcpy(&innerComm, &ptr, sizeof(MPI_Comm));
181:       MPI_Attr_get(innerComm, Petsc_Tag_keyval, (void **) &tagvalp, (PetscMPIInt *) &flg);
182:       if (!flg) {
183:         SETERRQ(PETSC_ERR_PLIB,"Inner PETSc communicator does not have its tagvalp attribute set");
184:       }
185:     }
186:   }
187:   MPI_Allreduce(tagvalp, &tag, 1, MPI_INT, MPI_MIN, comm);
188:   tagvalp[0] = tag;
189:   PetscInfo2(0, "Reset tag for comm %ld to \n", (long) comm, tagvalp[0]);
190:   return(0);
191: }

195: /*@C
196:   PetscCommDuplicate - Duplicates the communicator only if it is not already a PETSc 
197:                          communicator.

199:   Collective on MPI_Comm

201:   Input Parameters:
202: . comm_in - Input communicator

204:   Output Parameters:
205: + comm_out - Output communicator.  May be comm_in.
206: - first_tag - Tag available that has not already been used with this communicator (you may
207:               pass in PETSC_NULL if you do not need a tag)

209:   PETSc communicators are just regular MPI communicators that keep track of which 
210:   tags have been used to prevent tag conflict. If you pass a non-PETSc communicator into
211:   a PETSc creation routine it will attach a private communicator for use in the objects communications.

213:   Level: developer

215:   Concepts: communicator^duplicate

217: .seealso: PetscObjectGetNewTag(), PetscCommGetNewTag()
218: @*/
219: PetscErrorCode  PetscCommDuplicate(MPI_Comm comm_in,MPI_Comm *comm_out,PetscMPIInt* first_tag)
220: {
222:   PetscMPIInt    *tagvalp,*maxval;
223:   PetscTruth     flg;

226:   if (Petsc_Tag_keyval == MPI_KEYVAL_INVALID) {
227:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelTag,&Petsc_Tag_keyval,(void*)0);
228:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_InnerComm_keyval,(void*)0);
229:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_OuterComm_keyval,(void*)0);
230:   }
231:   MPI_Attr_get(comm_in,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);

233:   if (!flg) {
234:     void *ptr;
235:     /* check if this communicator has a PETSc communicator imbedded in it */
236:     MPI_Attr_get(comm_in,Petsc_InnerComm_keyval,&ptr,(PetscMPIInt*)&flg);
237:     if (!flg) {
238:       /* This communicator is not yet known to this system, so we duplicate it and set its value */
239:       MPI_Comm_dup(comm_in,comm_out);
240:       MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(PetscMPIInt*)&flg);
241:       if (!flg) {
242:         SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
243:       }
244:       PetscMalloc(2*sizeof(PetscMPIInt),&tagvalp);
245:       tagvalp[0] = *maxval;
246:       tagvalp[1] = 0;
247:       MPI_Attr_put(*comm_out,Petsc_Tag_keyval,tagvalp);
248:       PetscInfo3(0,"Duplicating a communicator %ld %ld max tags = %d\n",(long)comm_in,(long)*comm_out,*maxval);

250:       /* save PETSc communicator inside user communicator, so we can get it next time */
251:       PetscMemcpy(&ptr,comm_out,sizeof(MPI_Comm));
252:       MPI_Attr_put(comm_in,Petsc_InnerComm_keyval,ptr);
253:       PetscMemcpy(&ptr,&comm_in,sizeof(MPI_Comm));
254:       MPI_Attr_put(*comm_out,Petsc_OuterComm_keyval,ptr);
255:     } else {
256:       /*
257:         We use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers
258:       */
259:       PetscMemcpy(comm_out,&ptr,sizeof(MPI_Comm));
260:       MPI_Attr_get(*comm_out,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);
261:       if (!flg) {
262:         SETERRQ(PETSC_ERR_PLIB,"Inner PETSc communicator does not have its tagvalp attribute set");
263:       }
264:       PetscInfo2(0,"Using internal PETSc communicator %ld %ld\n",(long)comm_in,(long)*comm_out);
265:     }
266:   } else {
267: #if defined(PETSC_USE_DEBUG)
268:     PetscMPIInt tag;
269:     MPI_Allreduce(tagvalp,&tag,1,MPI_INT,MPI_BOR,comm_in);
270:     if (tag != tagvalp[0]) {
271:       SETERRQ(PETSC_ERR_ARG_CORRUPT,"Communicator was used on subset of processors.");
272:     }
273: #endif
274:     *comm_out = comm_in;
275:   }

277:   if (tagvalp[0] < 1) {
278:     PetscInfo1(0,"Out of tags for object, starting to recycle. Comm reference count %d\n",tagvalp[1]);
279:     MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(PetscMPIInt*)&flg);
280:     if (!flg) {
281:       SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
282:     }
283:     tagvalp[0] = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
284:   }

286:   if (first_tag) {
287:     *first_tag = tagvalp[0]--;
288:   }
289:   tagvalp[1]++; /* number of references to this comm */
290:   return(0);
291: }

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

298:    Collective on MPI_Comm

300:    Input Parameter:
301: .  comm - the communicator to free

303:    Level: developer

305:    Concepts: communicator^destroy

307: @*/
308: PetscErrorCode  PetscCommDestroy(MPI_Comm *comm)
309: {
311:   PetscMPIInt    *tagvalp;
312:   PetscTruth     flg;
313:   MPI_Comm       icomm = *comm,ocomm;
314:   void           *ptr;

317:   if (Petsc_Tag_keyval == MPI_KEYVAL_INVALID) {
318:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelTag,&Petsc_Tag_keyval,(void*)0);
319:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_InnerComm_keyval,(void*)0);
320:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_OuterComm_keyval,(void*)0);
321:   }
322:   MPI_Attr_get(icomm,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);
323:   if (!flg) {
324:     MPI_Attr_get(icomm,Petsc_InnerComm_keyval,&ptr,(PetscMPIInt*)&flg);
325:     /*
326:         We use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers
327:     */
328:     PetscMemcpy(&icomm,&ptr,sizeof(MPI_Comm));
329:     if (!flg) {
330:       return(0);
331:     }
332:     MPI_Attr_get(icomm,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);
333:     if (!flg) {
334:       SETERRQ(PETSC_ERR_ARG_CORRUPT,"Error freeing MPI_Comm, problem with corrupted memory");
335:     }
336:   }
337:   tagvalp[1]--;
338:   if (!tagvalp[1]) {

340:     MPI_Attr_get(icomm,Petsc_OuterComm_keyval,&ptr,(PetscMPIInt*)&flg);
341:     PetscMemcpy(&ocomm,&ptr,sizeof(MPI_Comm));

343:     if (flg) {
344:       MPI_Attr_delete(ocomm,Petsc_InnerComm_keyval);
345:     }

347:     PetscInfo1(0,"Deleting MPI_Comm %ld\n",(long)icomm);
348:     MPI_Comm_free(&icomm);
349:   }
350:   return(0);
351: }