Actual source code: fcallback.c
petsc-3.7.1 2016-05-15
Report Typos and Errors

      1: #include <petsc/private/petscimpl.h>  /*I   "petscsys.h"    I*/

      3: typedef struct _FortranCallbackLink *FortranCallbackLink;
      4: struct _FortranCallbackLink {
      5:   char                   *type_name;
      6:   PetscFortranCallbackId max;
      7:   FortranCallbackLink    next;
      8: };

     10: typedef struct {
     11:   PetscInt            basecount;
     12:   PetscInt            maxsubtypecount;
     13:   FortranCallbackLink subtypes;
     14: } FortranCallbackBase;

     16: static FortranCallbackBase *_classbase;
     17: static PetscClassId        _maxclassid = PETSC_SMALLEST_CLASSID;

     21: static PetscErrorCode PetscFortranCallbackFinalize(void)
     22: {
     24:   PetscClassId   i;

     27:   for (i=PETSC_SMALLEST_CLASSID; i<_maxclassid; i++) {
     28:     FortranCallbackBase *base = &_classbase[i-PETSC_SMALLEST_CLASSID];
     29:     FortranCallbackLink next,link = base->subtypes;
     30:     for (; link; link=next) {
     31:       next = link->next;
     32:       PetscFree(link->type_name);
     33:       PetscFree(link);
     34:     }
     35:   }
     36:   PetscFree(_classbase);

     38:   _maxclassid = PETSC_SMALLEST_CLASSID;
     39:   return(0);
     40: }

     44: /*@C
     45:    PetscFortranCallbackRegister - register a type+subtype callback

     47:    Not Collective

     49:    Input Arguments:
     50: +  classid - ID of class on which to register callback
     51: -  subtype - subtype string, or NULL for class ids

     53:    Output Arguments:
     54: .  id - callback id

     56:    Level: developer

     58: .seealso: PetscFortranCallbackGetSizes()
     59: @*/
     60: PetscErrorCode PetscFortranCallbackRegister(PetscClassId classid,const char *subtype,PetscFortranCallbackId *id)
     61: {
     62:   PetscErrorCode      ierr;
     63:   FortranCallbackBase *base;
     64:   FortranCallbackLink link;

     67:   *id = 0;
     68:   if (classid < PETSC_SMALLEST_CLASSID || PETSC_LARGEST_CLASSID <= classid) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"ClassId %D corrupt",classid);
     69:   if (classid >= _maxclassid) {
     70:     PetscClassId        newmax = PETSC_SMALLEST_CLASSID + 2*(PETSC_LARGEST_CLASSID-PETSC_SMALLEST_CLASSID);
     71:     FortranCallbackBase *newbase;
     72:     if (!_classbase) {
     73:       PetscRegisterFinalize(PetscFortranCallbackFinalize);
     74:     }
     75:     PetscCalloc1(newmax-PETSC_SMALLEST_CLASSID,&newbase);
     76:     PetscMemcpy(newbase,_classbase,(_maxclassid-PETSC_SMALLEST_CLASSID)*sizeof(_classbase[0]));
     77:     PetscFree(_classbase);

     79:     _classbase = newbase;
     80:     _maxclassid = newmax;
     81:   }
     82:   base = &_classbase[classid-PETSC_SMALLEST_CLASSID];
     83:   if (!subtype) *id = PETSC_SMALLEST_FORTRAN_CALLBACK + base->basecount++;
     84:   else {
     85:     for (link=base->subtypes; link; link=link->next) { /* look for either both NULL or matching values (implies both non-NULL) */
     86:       PetscBool match;
     87:       PetscStrcmp(subtype,link->type_name,&match);
     88:       if (match) { /* base type or matching subtype */
     89:         goto found;
     90:       }
     91:     }
     92:     /* Not found. Create node and prepend to class' subtype list */
     93:     PetscNew(&link);
     94:     PetscStrallocpy(subtype,&link->type_name);

     96:     link->max      = PETSC_SMALLEST_FORTRAN_CALLBACK;
     97:     link->next     = base->subtypes;
     98:     base->subtypes = link;

    100: found:
    101:     *id = link->max++;

    103:     base->maxsubtypecount = PetscMax(base->maxsubtypecount,link->max-PETSC_SMALLEST_FORTRAN_CALLBACK);
    104:   }
    105:   return(0);
    106: }

    110: /*@C
    111:    PetscFortranCallbackGetSizes - get sizes of class and subtype pointer arrays

    113:    Collective

    115:    Input Arguments:
    116: .  classid - class Id

    118:    Output Arguments:
    119: +  numbase - number of registered class callbacks
    120: -  numsubtype - max number of registered subtype callbacks

    122:    Level: developer

    124: .seealso: PetscFortranCallbackRegister()
    125: @*/
    126: PetscErrorCode PetscFortranCallbackGetSizes(PetscClassId classid,PetscInt *numbase,PetscInt *numsubtype)
    127: {

    130:   if (classid < _maxclassid) {
    131:     FortranCallbackBase *base = &_classbase[classid-PETSC_SMALLEST_CLASSID];
    132:     *numbase    = base->basecount;
    133:     *numsubtype = base->maxsubtypecount;
    134:   } else {                      /* nothing registered */
    135:     *numbase    = 0;
    136:     *numsubtype = 0;
    137:   }
    138:   return(0);
    139: }