Actual source code: tagm.c

      1: #define PETSC_DLL
      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 communicator.

     14:    It uses the attributes to determine if a new communicator
     15:       is needed and to store the available tags.

     17:    Notes on the implementation

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

     23:
     24: */

     26: static PetscMPIInt Petsc_Tag_keyval       = MPI_KEYVAL_INVALID;
     27: static PetscMPIInt Petsc_InnerComm_keyval = MPI_KEYVAL_INVALID;
     28: static PetscMPIInt Petsc_OuterComm_keyval = MPI_KEYVAL_INVALID;
     32: /*
     33:    Private routine to delete internal storage when a communicator is freed.
     34:   This is called by MPI, not by users.

     38: */
     39: PetscMPIInt PETSC_DLLEXPORT Petsc_DelTag(MPI_Comm comm,PetscMPIInt keyval,void* attr_val,void* extra_state)
     40: {

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

     53: /*
     54:    Private routine to delete internal storage when a communicator is freed.
     55:   This is called by MPI, not by users.

     59: */
     60: PetscMPIInt PETSC_DLLEXPORT Petsc_DelComm(MPI_Comm comm,PetscMPIInt keyval,void* attr_val,void* extra_state)
     61: {

     65:   PetscLogInfo((0,"Petsc_DelComm:Deleting PETSc communicator imbedded in a user MPI_Comm %ld\n",(long)comm));if (ierr) PetscFunctionReturn((PetscMPIInt)ierr);
     66:   /* actually don't delete anything because we cannot increase the reference count of the communicator anyways */
     67:   PetscFunctionReturn(MPI_SUCCESS);
     68: }

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

     79:     Collective on PetscObject

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

     85:     Output Parameter:
     86: .   tag - the new tag

     88:     Level: developer

     90:     Concepts: tag^getting
     91:     Concepts: message tag^getting
     92:     Concepts: MPI message tag^getting

     94: .seealso: PetscCommGetNewTag()
     95: @*/
     96: PetscErrorCode PETSC_DLLEXPORT PetscObjectGetNewTag(PetscObject obj,PetscMPIInt *tag)
     97: {

    101:   PetscCommGetNewTag(obj->comm,tag);
    102:   return(0);
    103: }

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

    113:     Collective on comm

    115:     Input Parameter:
    116: .   comm - the PETSc communicator

    118:     Output Parameter:
    119: .   tag - the new tag

    121:     Level: developer

    123:     Concepts: tag^getting
    124:     Concepts: message tag^getting
    125:     Concepts: MPI message tag^getting

    127: .seealso: PetscObjectGetNewTag(), PetscCommDuplicate()
    128: @*/
    129: PetscErrorCode PETSC_DLLEXPORT PetscCommGetNewTag(MPI_Comm comm,PetscMPIInt *tag)
    130: {
    132:   PetscMPIInt    *tagvalp=0,*maxval;
    133:   PetscTruth     flg;

    138:   if (Petsc_Tag_keyval == MPI_KEYVAL_INVALID) {
    139:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelTag,&Petsc_Tag_keyval,(void*)0);
    140:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_InnerComm_keyval,(void*)0);
    141:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_OuterComm_keyval,(void*)0);
    142:   }

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

    147:   if (tagvalp[0] < 1) {
    148:     PetscLogInfo((0,"PetscCommGetNewTag:Out of tags for object, starting to recycle. Comm reference count %d\n",tagvalp[1]));
    149:     MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(PetscMPIInt*)&flg);
    150:     if (!flg) {
    151:       SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
    152:     }
    153:     tagvalp[0] = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
    154:   }

    156:   *tag = tagvalp[0]--;
    157:   return(0);
    158: }

    162: /*@C
    163:   PetscCommDuplicate - Duplicates the communicator only if it is not already a PETSc
    164:                          communicator.

    166:   Collective on MPI_Comm

    168:   Input Parameters:
    169: . comm_in - Input communicator

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

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

    180:   Level: developer

    182:   Concepts: communicator^duplicate

    184: .seealso: PetscObjectGetNewTag(), PetscCommGetNewTag()
    185: @*/
    186: PetscErrorCode PETSC_DLLEXPORT PetscCommDuplicate(MPI_Comm comm_in,MPI_Comm *comm_out,PetscMPIInt* first_tag)
    187: {
    189:   PetscMPIInt    *tagvalp,*maxval;
    190:   PetscTruth     flg;

    193:   if (Petsc_Tag_keyval == MPI_KEYVAL_INVALID) {
    194:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelTag,&Petsc_Tag_keyval,(void*)0);
    195:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_InnerComm_keyval,(void*)0);
    196:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_OuterComm_keyval,(void*)0);
    197:   }
    198:   MPI_Attr_get(comm_in,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);

    200:   if (!flg) {
    201:     void *ptr;
    202:     /* check if this communicator has a PETSc communicator imbedded in it */
    203:     MPI_Attr_get(comm_in,Petsc_InnerComm_keyval,&ptr,(PetscMPIInt*)&flg);
    204:     /*
    205:         The next line may generate the warning: cast from pointer to integer of different size
    206:         It is safe to ignore this warning because ptr is obtained by casting a MPI_Comm to void*
    207:         so we know it is safe to caste it back.
    208:     */
    209:     PetscMemcpy(comm_out,&ptr,sizeof(MPI_Comm));
    210:     if (!flg) {
    211:       /* This communicator is not yet known to this system, so we duplicate it and set its value */
    212:       MPI_Comm_dup(comm_in,comm_out);
    213:       MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(PetscMPIInt*)&flg);
    214:       if (!flg) {
    215:         SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
    216:       }
    217:       PetscMalloc(2*sizeof(PetscMPIInt),&tagvalp);
    218:       tagvalp[0] = *maxval;
    219:       tagvalp[1] = 0;
    220:       MPI_Attr_put(*comm_out,Petsc_Tag_keyval,tagvalp);
    221:       PetscLogInfo((0,"PetscCommDuplicate: Duplicating a communicator %ld %ld max tags = %d\n",(long)comm_in,(long)*comm_out,*maxval));

    223:       /* save PETSc communicator inside user communicator, so we can get it next time */
    224:       PetscMemcpy(&ptr,comm_out,sizeof(MPI_Comm));
    225:       MPI_Attr_put(comm_in,Petsc_InnerComm_keyval,ptr);
    226:       PetscMemcpy(&ptr,&comm_in,sizeof(MPI_Comm));
    227:       MPI_Attr_put(*comm_out,Petsc_OuterComm_keyval,ptr);
    228:     } else {
    229:       MPI_Attr_get(*comm_out,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);
    230:       if (!flg) {
    231:         SETERRQ(PETSC_ERR_PLIB,"Inner PETSc communicator does not have its tagvalp attribute set");
    232:       }
    233:       PetscLogInfo((0,"PetscCommDuplicate: Using internal PETSc communicator %ld %ld\n",(long)comm_in,(long)*comm_out));
    234:     }
    235:   } else {
    236: #if defined(PETSC_USE_DEBUG)
    237:     PetscMPIInt tag;
    238:     MPI_Allreduce(tagvalp,&tag,1,MPI_INT,MPI_BOR,comm_in);
    239:     if (tag != tagvalp[0]) {
    240:       SETERRQ(PETSC_ERR_ARG_CORRUPT,"Communicator was used on subset of processors.");
    241:     }
    242: #endif
    243:     *comm_out = comm_in;
    244:   }

    246:   if (tagvalp[0] < 1) {
    247:     PetscLogInfo((0,"PetscCommDuplicate:Out of tags for object, starting to recycle. Comm reference count %d\n",tagvalp[1]));
    248:     MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(PetscMPIInt*)&flg);
    249:     if (!flg) {
    250:       SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
    251:     }
    252:     tagvalp[0] = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
    253:   }

    255:   if (first_tag) {
    256:     *first_tag = tagvalp[0]--;
    257:   }
    258:   tagvalp[1]++; /* number of references to this comm */
    259:   return(0);
    260: }

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

    267:    Collective on MPI_Comm

    269:    Input Parameter:
    270: .  comm - the communicator to free

    272:    Level: developer

    274:    Concepts: communicator^destroy

    276: @*/
    277: PetscErrorCode PETSC_DLLEXPORT PetscCommDestroy(MPI_Comm *comm)
    278: {
    280:   PetscMPIInt    *tagvalp;
    281:   PetscTruth     flg;
    282:   MPI_Comm       icomm = *comm,ocomm;
    283:   void           *ptr;

    286:   if (Petsc_Tag_keyval == MPI_KEYVAL_INVALID) {
    287:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelTag,&Petsc_Tag_keyval,(void*)0);
    288:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_InnerComm_keyval,(void*)0);
    289:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_OuterComm_keyval,(void*)0);
    290:   }
    291:   MPI_Attr_get(icomm,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);
    292:   if (!flg) {
    293:     MPI_Attr_get(icomm,Petsc_InnerComm_keyval,&ptr,(PetscMPIInt*)&flg);
    294:     PetscMemcpy(&icomm,&ptr,sizeof(MPI_Comm));
    295:     if (!flg) {
    296:       return(0);
    297:     }
    298:     MPI_Attr_get(icomm,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);
    299:     if (!flg) {
    300:       SETERRQ(PETSC_ERR_ARG_CORRUPT,"Error freeing MPI_Comm, problem with corrupted memory");
    301:     }
    302:   }
    303:   tagvalp[1]--;
    304:   if (!tagvalp[1]) {

    306:     MPI_Attr_get(icomm,Petsc_OuterComm_keyval,&ptr,(PetscMPIInt*)&flg);
    307:     PetscMemcpy(&ocomm,&ptr,sizeof(MPI_Comm));

    309:     if (flg) {
    310:       MPI_Attr_delete(ocomm,Petsc_InnerComm_keyval);
    311:     }

    313:     PetscLogInfo((0,"PetscCommDestroy:Deleting MPI_Comm %ld\n",(long)icomm));
    314:     MPI_Comm_free(&icomm);
    315:   }
    316:   return(0);
    317: }