Actual source code: tagm.c

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

  9: /* ---------------------------------------------------------------- */
 10: /*
 11:    A simple way to manage tags inside a private 
 12:    communicator.  It uses the attribute to determine if a new communicator
 13:    is needed.

 15:    Notes on the implementation

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

 22: static PetscMPIInt Petsc_Tag_keyval = MPI_KEYVAL_INVALID;

 27: /*
 28:    Private routine to delete internal storage when a communicator is freed.
 29:   This is called by MPI, not by users.

 31:   The binding for the first argument changed from MPI 1.0 to 1.1; in 1.0
 32:   it was MPI_Comm *comm.  

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

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

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

 56:     Collective on PetscObject

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

 62:     Output Parameter:
 63: .   tag - the new tag

 65:     Level: developer

 67:     Concepts: tag^getting
 68:     Concepts: message tag^getting
 69:     Concepts: MPI message tag^getting

 71: .seealso: PetscCommGetNewTag()
 72: @*/
 73: PetscErrorCode PetscObjectGetNewTag(PetscObject obj,PetscMPIInt *tag)
 74: {
 76:   PetscMPIInt    *tagvalp = 0,*maxval;
 77:   PetscTruth     flg;


 83:   MPI_Attr_get(obj->comm,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);
 84:   if (!flg) SETERRQ(PETSC_ERR_ARG_CORRUPT,"Bad MPI communicator in PETSc object, likely memory corruption");

 86:   if (tagvalp[0] < 1) {
 87:     PetscLogInfo(0,"Out of tags for object, starting to recycle. Number tags issued %d",tagvalp[1]);
 88:     MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(PetscMPIInt*)&flg);
 89:     if (!flg) {
 90:       SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
 91:     }
 92:     tagvalp[0] = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
 93:   }
 94:   *tag = tagvalp[0]--;
 95:   return(0);
 96: }

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

106:     Collective on comm

108:     Input Parameter:
109: .   comm - the PETSc communicator

111:     Output Parameter:
112: .   tag - the new tag

114:     Level: developer

116:     Concepts: tag^getting
117:     Concepts: message tag^getting
118:     Concepts: MPI message tag^getting

120: .seealso: PetscObjectGetNewTag(), PetscCommDuplicate()
121: @*/
122: PetscErrorCode PetscCommGetNewTag(MPI_Comm comm,PetscMPIInt *tag)
123: {
125:   PetscMPIInt    *tagvalp=0,*maxval;
126:   PetscTruth     flg;


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


135:   if (tagvalp[0] < 1) {
136:     PetscLogInfo(0,"Out of tags for object, starting to recycle. Number tags issued %d",tagvalp[1]);
137:     MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(PetscMPIInt*)&flg);
138:     if (!flg) {
139:       SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
140:     }
141:     tagvalp[0] = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
142:   }

144:   *tag = tagvalp[0]--;
145:   return(0);
146: }

150: /*@C
151:   PetscCommDuplicate - Duplicates the communicator only if it is not already a PETSc 
152:                          communicator.

154:   Collective on MPI_Comm

156:   Input Parameters:
157: . comm_in - Input communicator

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

164:   PETSc communicators are just regular MPI communicators that keep track of which 
165:   tags have been used to prevent tag conflict. If you pass a non-PETSc communicator into
166:   a PETSc creation routine it will be duplicated for use in the object.

168:   Level: developer

170:   Concepts: communicator^duplicate

172: .seealso: PetscObjectGetNewTag(), PetscCommGetNewTag()
173: @*/
174: PetscErrorCode PetscCommDuplicate(MPI_Comm comm_in,MPI_Comm *comm_out,PetscMPIInt* first_tag)
175: {
177:   PetscMPIInt    *tagvalp,*maxval;
178:   PetscTruth     flg;

181:   if (Petsc_Tag_keyval == MPI_KEYVAL_INVALID) {
182:     /* 
183:        The calling sequence of the 2nd argument to this function changed
184:        between MPI Standard 1.0 and the revisions 1.1 Here we match the 
185:        new standard, if you are using an MPI implementation that uses 
186:        the older version you will get a warning message about the next line;
187:        it is only a warning message and should do no harm.
188:     */
189:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelTag,&Petsc_Tag_keyval,(void*)0);
190:   }

192:   MPI_Attr_get(comm_in,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);

194:   if (!flg) {
195:     /* This communicator is not yet known to this system, so we duplicate it and set its value */
196:     MPI_Comm_dup(comm_in,comm_out);
197:     MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(PetscMPIInt*)&flg);
198:     if (!flg) {
199:       SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
200:     }
201:     PetscMalloc(2*sizeof(PetscMPIInt),&tagvalp);
202:     tagvalp[0] = *maxval;
203:     tagvalp[1] = 0;
204:     MPI_Attr_put(*comm_out,Petsc_Tag_keyval,tagvalp);
205:     PetscLogInfo(0,"PetscCommDuplicate: Duplicating a communicator %ld %ld max tags = %d\n",(long)comm_in,(long)*comm_out,*maxval);
206:   } else {
207: #if defined(PETSC_USE_BOPT_g)
208:     PetscMPIInt tag;
209:     MPI_Allreduce(tagvalp,&tag,1,MPI_INT,MPI_BOR,comm_in);
210:     if (tag != tagvalp[0]) {
211:       SETERRQ(PETSC_ERR_ARG_CORRUPT,"Communicator was used on subset of processors.");
212:     }
213: #endif
214:     *comm_out = comm_in;
215:   }

217:   if (tagvalp[0] < 1) {
218:     PetscLogInfo(0,"Out of tags for object, starting to recycle. Number tags issued %d",tagvalp[1]);
219:     MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(PetscMPIInt*)&flg);
220:     if (!flg) {
221:       SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
222:     }
223:     tagvalp[0] = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
224:   }

226:   if (first_tag) {
227:     *first_tag = tagvalp[0]--;
228:     tagvalp[1]++;
229:   }
230:   return(0);
231: }

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

238:    Collective on MPI_Comm

240:    Input Parameter:
241: .  comm - the communicator to free

243:    Level: developer

245:    Concepts: communicator^destroy

247: @*/
248: PetscErrorCode PetscCommDestroy(MPI_Comm *comm)
249: {
251:   PetscMPIInt    *tagvalp;
252:   PetscTruth     flg;

255:   MPI_Attr_get(*comm,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);
256:   if (!flg) {
257:     SETERRQ(PETSC_ERR_ARG_CORRUPT,"Error freeing MPI_Comm, problem with corrupted memory");
258:   }
259:   tagvalp[1]--;
260:   if (!tagvalp[1]) {
261:     PetscLogInfo(0,"PetscCommDestroy:Deleting MPI_Comm %ld\n",(long)*comm);
262:     MPI_Comm_free(comm);
263:   }
264:   return(0);
265: }