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: /*@
163: PetscCommSynchronizeTags - It is possible for the private PETSc tags to get out of
164: synch between processes. This function rectifies this disparity.
166: Collective on comm
168: Input Parameter:
169: . comm - the PETSc communicator
171: Level: developer
173: Concepts: tag^getting
174: Concepts: message tag^getting
175: Concepts: MPI message tag^getting
177: .seealso: PetscObjectCheckTags()
178: @*/
179: PetscErrorCode PetscCommSynchronizeTags(MPI_Comm comm)
180: {
181: PetscMPIInt *tagvalp = 0, tag;
182: PetscTruth flg;
186: MPI_Attr_get(comm, Petsc_Tag_keyval, (void **) &tagvalp, (PetscMPIInt *) &flg);
187: if (!flg) {
188: MPI_Comm innerComm;
189: void *ptr;
191: /* check if this communicator has a PETSc communicator imbedded in it */
192: MPI_Attr_get(comm, Petsc_InnerComm_keyval, &ptr, (PetscMPIInt*) &flg);
193: if (!flg) {
194: SETERRQ(PETSC_ERR_ARG_CORRUPT,"Bad MPI communicator supplied; must be a PETSc communicator");
195: } else {
196: /* We use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */
197: PetscMemcpy(&innerComm, &ptr, sizeof(MPI_Comm));
198: MPI_Attr_get(innerComm, Petsc_Tag_keyval, (void **) &tagvalp, (PetscMPIInt *) &flg);
199: if (!flg) {
200: SETERRQ(PETSC_ERR_PLIB,"Inner PETSc communicator does not have its tagvalp attribute set");
201: }
202: }
203: }
204: MPI_Allreduce(tagvalp, &tag, 1, MPI_INT, MPI_MIN, comm);
205: tagvalp[0] = tag;
206: PetscInfo2(0, "Reset tag for comm %ld to \n", (long) comm, tagvalp[0]);
207: return(0);
208: }
212: /*@
213: PetscCommCheckTags - It is possible for the private PETSc tags to get out of
214: synch between processes. This function returns an error if the tags are invalid.
216: Collective on comm
218: Input Parameter:
219: . comm - the PETSc communicator
221: Level: developer
223: Concepts: tag^getting
224: Concepts: message tag^getting
225: Concepts: MPI message tag^getting
227: .seealso: PetscObjectSynchronizeTags()
228: @*/
229: PetscErrorCode PetscCommCheckTags(MPI_Comm comm)
230: {
231: PetscMPIInt *tagvalp = 0, tag;
232: PetscTruth flg;
236: MPI_Attr_get(comm, Petsc_Tag_keyval, (void **) &tagvalp, (PetscMPIInt *) &flg);
237: if (!flg) {
238: MPI_Comm innerComm;
239: void *ptr;
241: /* check if this communicator has a PETSc communicator imbedded in it */
242: MPI_Attr_get(comm, Petsc_InnerComm_keyval, &ptr, (PetscMPIInt*) &flg);
243: if (!flg) {
244: SETERRQ(PETSC_ERR_ARG_CORRUPT,"Bad MPI communicator supplied; must be a PETSc communicator");
245: } else {
246: /* We use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers */
247: PetscMemcpy(&innerComm, &ptr, sizeof(MPI_Comm));
248: MPI_Attr_get(innerComm, Petsc_Tag_keyval, (void **) &tagvalp, (PetscMPIInt *) &flg);
249: if (!flg) {
250: SETERRQ(PETSC_ERR_PLIB,"Inner PETSc communicator does not have its tagvalp attribute set");
251: }
252: }
253: }
254: tag = tagvalp[0];
255: MPI_Bcast(&tag, 1, MPI_INT, 0, comm);
256: if (tagvalp[0] != tag) {
257: SETERRQ2(PETSC_ERR_LIB, "Invalid tag %d should be %d", tagvalp[0], tag);
258: }
259: return(0);
260: }
264: /*@C
265: PetscCommDuplicate - Duplicates the communicator only if it is not already a PETSc
266: communicator.
268: Collective on MPI_Comm
270: Input Parameters:
271: . comm_in - Input communicator
273: Output Parameters:
274: + comm_out - Output communicator. May be comm_in.
275: - first_tag - Tag available that has not already been used with this communicator (you may
276: pass in PETSC_NULL if you do not need a tag)
278: PETSc communicators are just regular MPI communicators that keep track of which
279: tags have been used to prevent tag conflict. If you pass a non-PETSc communicator into
280: a PETSc creation routine it will attach a private communicator for use in the objects communications.
282: Level: developer
284: Concepts: communicator^duplicate
286: .seealso: PetscObjectGetNewTag(), PetscCommGetNewTag()
287: @*/
288: PetscErrorCode PetscCommDuplicate(MPI_Comm comm_in,MPI_Comm *comm_out,PetscMPIInt* first_tag)
289: {
291: PetscMPIInt *tagvalp,*maxval;
292: PetscTruth flg;
295: if (Petsc_Tag_keyval == MPI_KEYVAL_INVALID) {
296: MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelTag,&Petsc_Tag_keyval,(void*)0);
297: MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_InnerComm_keyval,(void*)0);
298: MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_OuterComm_keyval,(void*)0);
299: }
300: MPI_Attr_get(comm_in,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);
302: if (!flg) {
303: void *ptr;
304: /* check if this communicator has a PETSc communicator imbedded in it */
305: MPI_Attr_get(comm_in,Petsc_InnerComm_keyval,&ptr,(PetscMPIInt*)&flg);
306: if (!flg) {
307: /* This communicator is not yet known to this system, so we duplicate it and set its value */
308: MPI_Comm_dup(comm_in,comm_out);
309: MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(PetscMPIInt*)&flg);
310: if (!flg) {
311: SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
312: }
313: PetscMalloc(2*sizeof(PetscMPIInt),&tagvalp);
314: tagvalp[0] = *maxval;
315: tagvalp[1] = 0;
316: MPI_Attr_put(*comm_out,Petsc_Tag_keyval,tagvalp);
317: PetscInfo3(0,"Duplicating a communicator %ld %ld max tags = %d\n",(long)comm_in,(long)*comm_out,*maxval);
319: /* save PETSc communicator inside user communicator, so we can get it next time */
320: PetscMemcpy(&ptr,comm_out,sizeof(MPI_Comm));
321: MPI_Attr_put(comm_in,Petsc_InnerComm_keyval,ptr);
322: PetscMemcpy(&ptr,&comm_in,sizeof(MPI_Comm));
323: MPI_Attr_put(*comm_out,Petsc_OuterComm_keyval,ptr);
324: } else {
325: /*
326: We use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers
327: */
328: PetscMemcpy(comm_out,&ptr,sizeof(MPI_Comm));
329: MPI_Attr_get(*comm_out,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);
330: if (!flg) {
331: SETERRQ(PETSC_ERR_PLIB,"Inner PETSc communicator does not have its tagvalp attribute set");
332: }
333: PetscInfo2(0,"Using internal PETSc communicator %ld %ld\n",(long)comm_in,(long)*comm_out);
334: }
335: } else {
336: #if defined(PETSC_USE_DEBUG)
337: PetscMPIInt tag;
338: MPI_Allreduce(tagvalp,&tag,1,MPI_INT,MPI_BOR,comm_in);
339: if (tag != tagvalp[0]) {
340: SETERRQ(PETSC_ERR_ARG_CORRUPT,"Communicator was used on subset of processors.");
341: }
342: #endif
343: *comm_out = comm_in;
344: }
346: if (tagvalp[0] < 1) {
347: PetscInfo1(0,"Out of tags for object, starting to recycle. Comm reference count %d\n",tagvalp[1]);
348: MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(PetscMPIInt*)&flg);
349: if (!flg) {
350: SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
351: }
352: tagvalp[0] = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
353: }
355: if (first_tag) {
356: *first_tag = tagvalp[0]--;
357: }
358: tagvalp[1]++; /* number of references to this comm */
359: return(0);
360: }
364: /*@C
365: PetscCommDestroy - Frees communicator. Use in conjunction with PetscCommDuplicate().
367: Collective on MPI_Comm
369: Input Parameter:
370: . comm - the communicator to free
372: Level: developer
374: Concepts: communicator^destroy
376: @*/
377: PetscErrorCode PetscCommDestroy(MPI_Comm *comm)
378: {
380: PetscMPIInt *tagvalp;
381: PetscTruth flg;
382: MPI_Comm icomm = *comm,ocomm;
383: void *ptr;
386: if (Petsc_Tag_keyval == MPI_KEYVAL_INVALID) {
387: MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelTag,&Petsc_Tag_keyval,(void*)0);
388: MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_InnerComm_keyval,(void*)0);
389: MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_OuterComm_keyval,(void*)0);
390: }
391: MPI_Attr_get(icomm,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);
392: if (!flg) {
393: MPI_Attr_get(icomm,Petsc_InnerComm_keyval,&ptr,(PetscMPIInt*)&flg);
394: /*
395: We use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers
396: */
397: PetscMemcpy(&icomm,&ptr,sizeof(MPI_Comm));
398: if (!flg) {
399: return(0);
400: }
401: MPI_Attr_get(icomm,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);
402: if (!flg) {
403: SETERRQ(PETSC_ERR_ARG_CORRUPT,"Error freeing MPI_Comm, problem with corrupted memory");
404: }
405: }
406: tagvalp[1]--;
407: if (!tagvalp[1]) {
409: MPI_Attr_get(icomm,Petsc_OuterComm_keyval,&ptr,(PetscMPIInt*)&flg);
410: PetscMemcpy(&ocomm,&ptr,sizeof(MPI_Comm));
412: if (flg) {
413: MPI_Attr_delete(ocomm,Petsc_InnerComm_keyval);
414: }
416: PetscInfo1(0,"Deleting MPI_Comm %ld\n",(long)icomm);
417: MPI_Comm_free(&icomm);
418: }
419: return(0);
420: }