Actual source code: tagm.c
1: /*$Id: tagm.c,v 1.33 2001/03/23 23:20:38 balay Exp $*/
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 private
13: communicator. It uses the attribute to determine if a new communicator
14: is needed.
16: Notes on the implementation
18: The tagvalues to use are stored in a two element array. The first element
19: is the first free tag value. The second is used to indicate how
20: many "copies" of the communicator there are used in destroying.
21: */
23: static int Petsc_Tag_keyval = MPI_KEYVAL_INVALID;
25: EXTERN_C_BEGIN
26: /*
27: Private routine to delete internal storage when a communicator is freed.
28: This is called by MPI, not by users.
30: The binding for the first argument changed from MPI 1.0 to 1.1; in 1.0
31: it was MPI_Comm *comm.
33: Note: this is declared extern "C" because it is passed to the system routine signal()
34: which is an extern "C" routine. The Solaris 2.7 OS compilers require that this be
35: extern "C".
36: */
37: int Petsc_DelTag(MPI_Comm comm,int keyval,void* attr_val,void* extra_state)
38: {
42: PetscLogInfo(0,"Petsc_DelTag:Deleting tag data in an MPI_Comm %ldn",(long)comm);
43: PetscFree(attr_val);
44: PetscFunctionReturn(MPI_SUCCESS);
45: }
46: EXTERN_C_END
48: /*@C
49: PetscObjectGetNewTag - Gets a unique new tag from a PETSc object. All
50: processors that share the object 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 PetscObject
56: Input Parameter:
57: . obj - the PETSc object; this must be cast with a (PetscObject), for example,
58: PetscObjectGetNewTag((PetscObject)mat,&tag);
60: Output Parameter:
61: . tag - the new tag
63: Level: developer
65: Concepts: tag^getting
66: Concepts: message tag^getting
67: Concepts: MPI message tag^getting
69: .seealso: PetscCommGetNewTag()
70: @*/
71: int PetscObjectGetNewTag(PetscObject obj,int *tag)
72: {
73: int ierr,*tagvalp=0,*maxval;
74: PetscTruth flg;
80: MPI_Attr_get(obj->comm,Petsc_Tag_keyval,(void**)&tagvalp,(int*)&flg);
81: if (!flg) SETERRQ(PETSC_ERR_ARG_CORRUPT,"Bad MPI communicator in PETSc object, likely memory corruption");
83: if (tagvalp[0] < 1) {
84: PetscLogInfo(0,"Out of tags for object, starting to recycle. Number tags issued %d",tagvalp[1]);
85: ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(int*)&flg);
86: if (!flg) {
87: SETERRQ(1,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
88: }
89: tagvalp[0] = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
90: }
92: *tag = tagvalp[0]--;
93: return(0);
94: }
96: /*@C
97: PetscCommGetNewTag - Gets a unique new tag from a PETSc communicator. All
98: processors that share the communicator MUST call this routine EXACTLY the same
99: number of times. This tag should only be used with the current objects
100: communicator; do NOT use it with any other MPI communicator.
102: Collective on comm
104: Input Parameter:
105: . comm - the PETSc communicator
107: Output Parameter:
108: . tag - the new tag
110: Level: developer
112: Concepts: tag^getting
113: Concepts: message tag^getting
114: Concepts: MPI message tag^getting
116: .seealso: PetscObjectGetNewTag()
117: @*/
118: int PetscCommGetNewTag(MPI_Comm comm,int *tag)
119: {
120: int ierr,*tagvalp=0,*maxval;
121: PetscTruth flg;
126: MPI_Attr_get(comm,Petsc_Tag_keyval,(void**)&tagvalp,(int*)&flg);
127: if (!flg) SETERRQ(PETSC_ERR_ARG_CORRUPT,"Bad MPI communicator supplied; must be a PETSc communicator");
130: if (tagvalp[0] < 1) {
131: PetscLogInfo(0,"Out of tags for object, starting to recycle. Number tags issued %d",tagvalp[1]);
132: ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(int*)&flg);
133: if (!flg) {
134: SETERRQ(1,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
135: }
136: tagvalp[0] = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
137: }
139: *tag = tagvalp[0]--;
140: return(0);
141: }
143: /*
144: PetscCommDuplicate_Private - Duplicates the communicator only if it is not already a PETSc
145: communicator.
147: Input Parameters:
148: . comm_in - Input communicator
150: Output Parameters:
151: + comm_out - Output communicator. May be comm_in.
152: - first_tag - First tag available
154: Notes:
155: This routine returns one tag number.
157: */
158: int PetscCommDuplicate_Private(MPI_Comm comm_in,MPI_Comm *comm_out,int* first_tag)
159: {
160: int ierr,*tagvalp,*maxval;
161: PetscTruth flg;
164: if (Petsc_Tag_keyval == MPI_KEYVAL_INVALID) {
165: /*
166: The calling sequence of the 2nd argument to this function changed
167: between MPI Standard 1.0 and the revisions 1.1 Here we match the
168: new standard, if you are using an MPI implementation that uses
169: the older version you will get a warning message about the next line;
170: it is only a warning message and should do no harm.
171: */
172: MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelTag,&Petsc_Tag_keyval,(void*)0);
173: }
175: MPI_Attr_get(comm_in,Petsc_Tag_keyval,(void**)&tagvalp,(int*)&flg);
177: if (!flg) {
178: /* This communicator is not yet known to this system, so we duplicate it and set its value */
179: ierr = MPI_Comm_dup(comm_in,comm_out);
180: ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(int*)&flg);
181: if (!flg) {
182: SETERRQ(1,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
183: }
184: PetscMalloc(2*sizeof(int),&tagvalp);
185: tagvalp[0] = *maxval;
186: tagvalp[1] = 0;
187: ierr = MPI_Attr_put(*comm_out,Petsc_Tag_keyval,tagvalp);
188: PetscLogInfo(0,"PetscCommDuplicate_Private: Duplicating a communicator %ld %ld max tags = %dn",(long)comm_in,(long)*comm_out,*maxval);
189: } else {
190: #if defined(PETSC_USE_BOPT_g)
191: int tag;
192: MPI_Allreduce(tagvalp,&tag,1,MPI_INT,MPI_BOR,comm_in);
193: if (tag != tagvalp[0]) {
194: SETERRQ(PETSC_ERR_ARG_CORRUPT,"Communicator was used on subset of processors.");
195: }
196: #endif
197: *comm_out = comm_in;
198: }
200: if (tagvalp[0] < 1) {
201: PetscLogInfo(0,"Out of tags for object, starting to recycle. Number tags issued %d",tagvalp[1]);
202: ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(int*)&flg);
203: if (!flg) {
204: SETERRQ(1,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
205: }
206: tagvalp[0] = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
207: }
209: *first_tag = tagvalp[0]--;
210: tagvalp[1]++;
211: return(0);
212: }
214: /*
215: PetscCommDestroy_Private - Frees communicator. Use in conjunction with PetscCommDuplicate_Private().
216: */
217: int PetscCommDestroy_Private(MPI_Comm *comm)
218: {
219: int ierr,*tagvalp;
220: PetscTruth flg;
223: MPI_Attr_get(*comm,Petsc_Tag_keyval,(void**)&tagvalp,(int*)&flg);
224: if (!flg) {
225: SETERRQ(PETSC_ERR_ARG_CORRUPT,"Error freeing MPI_Comm, problem with corrupted memory");
226: }
227: tagvalp[1]--;
228: if (!tagvalp[1]) {
229: PetscLogInfo(0,"PetscCommDestroy_Private:Deleting MPI_Comm %ldn",(long)*comm);
230: MPI_Comm_free(comm);
231: }
232: return(0);
233: }