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: #undef __FUNCT__
28: /*
29: Private routine to delete internal storage when a communicator is freed.
30: This is called by MPI, not by users.
32: The binding for the first argument changed from MPI 1.0 to 1.1; in 1.0
33: it was MPI_Comm *comm.
35: Note: this is declared extern "C" because it is passed to the system routine signal()
36: which is an extern "C" routine. The Solaris 2.7 OS compilers require that this be
37: extern "C".
38: */
39: int Petsc_DelTag(MPI_Comm comm,int keyval,void* attr_val,void* extra_state)
40: {
44: PetscLogInfo(0,"Petsc_DelTag:Deleting tag data in an MPI_Comm %ldn",(long)comm);
45: PetscFree(attr_val);
46: PetscFunctionReturn(MPI_SUCCESS);
47: }
48: EXTERN_C_END
50: #undef __FUNCT__
52: /*@C
53: PetscObjectGetNewTag - Gets a unique new tag from a PETSc object. All
54: processors that share the object MUST call this routine EXACTLY the same
55: number of times. This tag should only be used with the current objects
56: communicator; do NOT use it with any other MPI communicator.
58: Collective on PetscObject
60: Input Parameter:
61: . obj - the PETSc object; this must be cast with a (PetscObject), for example,
62: PetscObjectGetNewTag((PetscObject)mat,&tag);
64: Output Parameter:
65: . tag - the new tag
67: Level: developer
69: Concepts: tag^getting
70: Concepts: message tag^getting
71: Concepts: MPI message tag^getting
73: .seealso: PetscCommGetNewTag()
74: @*/
75: int PetscObjectGetNewTag(PetscObject obj,int *tag)
76: {
77: int ierr,*tagvalp=0,*maxval;
78: PetscTruth flg;
84: MPI_Attr_get(obj->comm,Petsc_Tag_keyval,(void**)&tagvalp,(int*)&flg);
85: if (!flg) SETERRQ(PETSC_ERR_ARG_CORRUPT,"Bad MPI communicator in PETSc object, likely memory corruption");
87: if (tagvalp[0] < 1) {
88: PetscLogInfo(0,"Out of tags for object, starting to recycle. Number tags issued %d",tagvalp[1]);
89: ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(int*)&flg);
90: if (!flg) {
91: SETERRQ(1,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
92: }
93: tagvalp[0] = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
94: }
96: *tag = tagvalp[0]--;
97: return(0);
98: }
100: #undef __FUNCT__
102: /*@C
103: PetscCommGetNewTag - Gets a unique new tag from a PETSc communicator. All
104: processors that share the communicator MUST call this routine EXACTLY the same
105: number of times. This tag should only be used with the current objects
106: communicator; do NOT use it with any other MPI communicator.
108: Collective on comm
110: Input Parameter:
111: . comm - the PETSc communicator
113: Output Parameter:
114: . tag - the new tag
116: Level: developer
118: Concepts: tag^getting
119: Concepts: message tag^getting
120: Concepts: MPI message tag^getting
122: .seealso: PetscObjectGetNewTag()
123: @*/
124: int PetscCommGetNewTag(MPI_Comm comm,int *tag)
125: {
126: int ierr,*tagvalp=0,*maxval;
127: PetscTruth flg;
132: MPI_Attr_get(comm,Petsc_Tag_keyval,(void**)&tagvalp,(int*)&flg);
133: if (!flg) SETERRQ(PETSC_ERR_ARG_CORRUPT,"Bad MPI communicator supplied; must be a PETSc communicator");
136: if (tagvalp[0] < 1) {
137: PetscLogInfo(0,"Out of tags for object, starting to recycle. Number tags issued %d",tagvalp[1]);
138: ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(int*)&flg);
139: if (!flg) {
140: SETERRQ(1,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
141: }
142: tagvalp[0] = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
143: }
145: *tag = tagvalp[0]--;
146: return(0);
147: }
149: #undef __FUNCT__
151: /*
152: PetscCommDuplicate_Private - Duplicates the communicator only if it is not already a PETSc
153: communicator.
155: Input Parameters:
156: . comm_in - Input communicator
158: Output Parameters:
159: + comm_out - Output communicator. May be comm_in.
160: - first_tag - First tag available
162: Notes:
163: This routine returns one tag number.
165: */
166: int PetscCommDuplicate_Private(MPI_Comm comm_in,MPI_Comm *comm_out,int* first_tag)
167: {
168: int ierr,*tagvalp,*maxval;
169: PetscTruth flg;
172: if (Petsc_Tag_keyval == MPI_KEYVAL_INVALID) {
173: /*
174: The calling sequence of the 2nd argument to this function changed
175: between MPI Standard 1.0 and the revisions 1.1 Here we match the
176: new standard, if you are using an MPI implementation that uses
177: the older version you will get a warning message about the next line;
178: it is only a warning message and should do no harm.
179: */
180: MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelTag,&Petsc_Tag_keyval,(void*)0);
181: }
183: MPI_Attr_get(comm_in,Petsc_Tag_keyval,(void**)&tagvalp,(int*)&flg);
185: if (!flg) {
186: /* This communicator is not yet known to this system, so we duplicate it and set its value */
187: ierr = MPI_Comm_dup(comm_in,comm_out);
188: ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(int*)&flg);
189: if (!flg) {
190: SETERRQ(1,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
191: }
192: PetscMalloc(2*sizeof(int),&tagvalp);
193: tagvalp[0] = *maxval;
194: tagvalp[1] = 0;
195: ierr = MPI_Attr_put(*comm_out,Petsc_Tag_keyval,tagvalp);
196: PetscLogInfo(0,"PetscCommDuplicate_Private: Duplicating a communicator %ld %ld max tags = %dn",(long)comm_in,(long)*comm_out,*maxval);
197: } else {
198: #if defined(PETSC_USE_BOPT_g)
199: int tag;
200: MPI_Allreduce(tagvalp,&tag,1,MPI_INT,MPI_BOR,comm_in);
201: if (tag != tagvalp[0]) {
202: SETERRQ(PETSC_ERR_ARG_CORRUPT,"Communicator was used on subset of processors.");
203: }
204: #endif
205: *comm_out = comm_in;
206: }
208: if (tagvalp[0] < 1) {
209: PetscLogInfo(0,"Out of tags for object, starting to recycle. Number tags issued %d",tagvalp[1]);
210: ierr = MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(int*)&flg);
211: if (!flg) {
212: SETERRQ(1,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
213: }
214: tagvalp[0] = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
215: }
217: *first_tag = tagvalp[0]--;
218: tagvalp[1]++;
219: return(0);
220: }
222: #undef __FUNCT__
224: /*
225: PetscCommDestroy_Private - Frees communicator. Use in conjunction with PetscCommDuplicate_Private().
226: */
227: int PetscCommDestroy_Private(MPI_Comm *comm)
228: {
229: int ierr,*tagvalp;
230: PetscTruth flg;
233: MPI_Attr_get(*comm,Petsc_Tag_keyval,(void**)&tagvalp,(int*)&flg);
234: if (!flg) {
235: SETERRQ(PETSC_ERR_ARG_CORRUPT,"Error freeing MPI_Comm, problem with corrupted memory");
236: }
237: tagvalp[1]--;
238: if (!tagvalp[1]) {
239: PetscLogInfo(0,"PetscCommDestroy_Private:Deleting MPI_Comm %ldn",(long)*comm);
240: MPI_Comm_free(comm);
241: }
242: return(0);
243: }