Actual source code: tagm.c

  2: /*
  3:       Some PETSc utilites
  4: */
  5: #include <petscsys.h>             /*I    "petscsys.h"   I*/
  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: */


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

 28:     Collective on PetscObject

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

 34:     Output Parameter:
 35: .   tag - the new tag

 37:     Level: developer

 39:     Concepts: tag^getting
 40:     Concepts: message tag^getting
 41:     Concepts: MPI message tag^getting

 43: .seealso: PetscCommGetNewTag()
 44: @*/
 45: PetscErrorCode  PetscObjectGetNewTag(PetscObject obj,PetscMPIInt *tag)
 46: {

 50:   PetscCommGetNewTag(obj->comm,tag);
 51:   return(0);
 52: }

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

 62:     Collective on comm

 64:     Input Parameter:
 65: .   comm - the MPI communicator

 67:     Output Parameter:
 68: .   tag - the new tag

 70:     Level: developer

 72:     Concepts: tag^getting
 73:     Concepts: message tag^getting
 74:     Concepts: MPI message tag^getting

 76: .seealso: PetscObjectGetNewTag(), PetscCommDuplicate()
 77: @*/
 78: PetscErrorCode  PetscCommGetNewTag(MPI_Comm comm,PetscMPIInt *tag)
 79: {
 80:   PetscErrorCode   ierr;
 81:   PetscCommCounter *counter;
 82:   PetscMPIInt      *maxval,flg;


 87:   MPI_Attr_get(comm,Petsc_Counter_keyval,&counter,&flg);
 88:   if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"Bad MPI communicator supplied; must be a PETSc communicator");

 90:   if (counter->tag < 1) {
 91:     PetscInfo1(0,"Out of tags for object, starting to recycle. Comm reference count %d\n",counter->refcount);
 92:     MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);
 93:     if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
 94:     counter->tag = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
 95:   }

 97:   *tag = counter->tag--;
 98: #if defined(PETSC_USE_DEBUG)
 99:   /* 
100:      Hanging here means that some processes have called PetscCommGetNewTag() and others have not.
101:   */
102:   MPI_Barrier(comm);
103: #endif
104:   return(0);
105: }

109: /*@C
110:   PetscCommDuplicate - Duplicates the communicator only if it is not already a PETSc communicator.

112:   Collective on MPI_Comm

114:   Input Parameters:
115: . comm_in - Input communicator

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

122:   PETSc communicators are just regular MPI communicators that keep track of which 
123:   tags have been used to prevent tag conflict. If you pass a non-PETSc communicator into
124:   a PETSc creation routine it will attach a private communicator for use in the objects communications.
125:   The internal MPI_Comm is used to perform all the MPI calls for PETSc, the outer MPI_Comm is a user
126:   level MPI_Comm that may be performing communication for the user or other library and so IS NOT used by PETSc.

128:   Level: developer

130:   Concepts: communicator^duplicate

132: .seealso: PetscObjectGetNewTag(), PetscCommGetNewTag(), PetscCommDestroy()
133: @*/
134: PetscErrorCode  PetscCommDuplicate(MPI_Comm comm_in,MPI_Comm *comm_out,PetscMPIInt* first_tag)
135: {
136:   PetscErrorCode   ierr;
137:   PetscCommCounter *counter;
138:   PetscMPIInt      *maxval,flg;

141:   MPI_Attr_get(comm_in,Petsc_Counter_keyval,&counter,&flg);

143:   if (!flg) {  /* this is NOT a PETSc comm */
144:     void *ptr;
145:     /* check if this communicator has a PETSc communicator imbedded in it */
146:     MPI_Attr_get(comm_in,Petsc_InnerComm_keyval,&ptr,&flg);
147:     if (!flg) {
148:       /* This communicator is not yet known to this system, so we duplicate it and make an internal communicator */
149:       MPI_Comm_dup(comm_in,comm_out);
150:       MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);
151:       if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
152:       PetscMalloc(sizeof(PetscCommCounter),&counter);
153:       counter->tag       = *maxval;
154:       counter->refcount  = 0;
155:       counter->namecount = 0;
156:       MPI_Attr_put(*comm_out,Petsc_Counter_keyval,counter);
157:       PetscInfo3(0,"Duplicating a communicator %ld %ld max tags = %d\n",(long)comm_in,(long)*comm_out,*maxval);

159:       /* save PETSc communicator inside user communicator, so we can get it next time */
160:       /*  Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers  */
161:       PetscMemcpy(&ptr,comm_out,sizeof(MPI_Comm));
162:       MPI_Attr_put(comm_in,Petsc_InnerComm_keyval,ptr);
163:       /*  Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers  */
164:       PetscMemcpy(&ptr,&comm_in,sizeof(MPI_Comm));
165:       MPI_Attr_put(*comm_out,Petsc_OuterComm_keyval,ptr);
166:     } else {
167:       /* pull out the inner MPI_Comm and hand it back to the caller */
168:       /*  Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers  */
169:       PetscMemcpy(comm_out,&ptr,sizeof(MPI_Comm));
170:       MPI_Attr_get(*comm_out,Petsc_Counter_keyval,&counter,&flg);
171:       if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"Inner PETSc communicator does not have its tag/name counter attribute set");
172:       PetscInfo2(0,"Using internal PETSc communicator %ld %ld\n",(long)comm_in,(long)*comm_out);
173:     }
174:   } else {
175:     *comm_out = comm_in;
176:   }

178: #if defined(PETSC_USE_DEBUG)
179:   /* 
180:      Hanging here means that some processes have called PetscCommDuplicate() and others have not.
181:      This likley means that a subset of processes in a MPI_Comm have attempted to create a PetscObject!
182:      ALL processes that share a communicator MUST shared objects created from that communicator.
183:   */
184:   MPI_Barrier(comm_in);
185: #endif

187:   if (counter->tag < 1) {
188:     PetscInfo1(0,"Out of tags for object, starting to recycle. Comm reference count %d\n",counter->refcount);
189:     MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);
190:     if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
191:     counter->tag = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
192:   }

194:   if (first_tag) {
195:     *first_tag = counter->tag--;
196:   }
197:   counter->refcount++; /* number of references to this comm */
198:   return(0);
199: }

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

206:    Collective on MPI_Comm

208:    Input Parameter:
209: .  comm - the communicator to free

211:    Level: developer

213:    Concepts: communicator^destroy

215: .seealso:   PetscCommDuplicate()
216: @*/
217: PetscErrorCode  PetscCommDestroy(MPI_Comm *comm)
218: {
219:   PetscErrorCode   ierr;
220:   PetscCommCounter *counter;
221:   PetscMPIInt      flg;
222:   MPI_Comm         icomm = *comm,ocomm;
223:   void             *ptr;

226:   MPI_Attr_get(icomm,Petsc_Counter_keyval,&counter,&flg);
227:   if (!flg) { /* not a PETSc comm, check if it has an inner comm */
228:     MPI_Attr_get(icomm,Petsc_InnerComm_keyval,&ptr,&flg);
229:     if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"MPI_Comm does not have tag/name counter nor does it have inner MPI_Comm");
230:     /*  Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers  */
231:     PetscMemcpy(&icomm,&ptr,sizeof(MPI_Comm));
232:     MPI_Attr_get(icomm,Petsc_Counter_keyval,&counter,&flg);
233:     if (!flg) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"Inner MPI_Comm does not have expected tag/name counter, problem with corrupted memory");
234:   }
235:   counter->refcount--;
236:   if (!counter->refcount) {

238:     /* if MPI_Comm has outer comm then remove reference to inner MPI_Comm from outer MPI_Comm */
239:     MPI_Attr_get(icomm,Petsc_OuterComm_keyval,&ptr,&flg);
240:     if (flg) {
241:       /*  Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers  */
242:       PetscMemcpy(&ocomm,&ptr,sizeof(MPI_Comm));
243:       MPI_Attr_get(ocomm,Petsc_InnerComm_keyval,&ptr,&flg);
244:       if (flg) {
245:         MPI_Attr_delete(ocomm,Petsc_InnerComm_keyval);
246:       } else SETERRQ2(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"Outer MPI_Comm %ld does not have expected reference to inner comm %d, problem with corrupted memory",(long int)ocomm,(long int)icomm);
247:     }

249:     PetscInfo1(0,"Deleting PETSc MPI_Comm %ld\n",(long)icomm);
250:     MPI_Comm_free(&icomm);
251:   }
252:   *comm = 0;
253:   return(0);
254: }