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: }