Actual source code: fcallback.c

  1: #include <petsc/private/petscimpl.h>

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

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

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

 19: static PetscErrorCode PetscFortranCallbackFinalize(void)
 20: {
 21:   for (PetscInt i=PETSC_SMALLEST_CLASSID; i<_maxclassid; i++) {
 22:     FortranCallbackBase *base = &_classbase[i-PETSC_SMALLEST_CLASSID];
 23:     FortranCallbackLink next,link = base->subtypes;
 24:     for (; link; link=next) {
 25:       next = link->next;
 26:       PetscFree(link->type_name);
 27:       PetscFree(link);
 28:     }
 29:   }
 30:   PetscFree(_classbase);
 31:   _maxclassid = PETSC_SMALLEST_CLASSID;
 32:   return 0;
 33: }

 35: /*@C
 36:    PetscFortranCallbackRegister - register a type+subtype callback

 38:    Not Collective

 40:    Input Parameters:
 41: +  classid - ID of class on which to register callback
 42: -  subtype - subtype string, or NULL for class ids

 44:    Output Parameter:
 45: .  id - callback id

 47:    Level: developer

 49: .seealso: PetscFortranCallbackGetSizes()
 50: @*/
 51: PetscErrorCode PetscFortranCallbackRegister(PetscClassId classid,const char *subtype,PetscFortranCallbackId *id)
 52: {
 53:   FortranCallbackBase *base;
 54:   FortranCallbackLink link;

 59:   *id = 0;
 60:   if (classid >= _maxclassid) {
 61:     PetscClassId        newmax = PETSC_SMALLEST_CLASSID + 2*(PETSC_LARGEST_CLASSID-PETSC_SMALLEST_CLASSID);
 62:     FortranCallbackBase *newbase;
 63:     if (!_classbase) PetscRegisterFinalize(PetscFortranCallbackFinalize);
 64:     PetscCalloc1(newmax-PETSC_SMALLEST_CLASSID,&newbase);
 65:     PetscArraycpy(newbase,_classbase,_maxclassid-PETSC_SMALLEST_CLASSID);
 66:     PetscFree(_classbase);

 68:     _classbase = newbase;
 69:     _maxclassid = newmax;
 70:   }
 71:   base = &_classbase[classid-PETSC_SMALLEST_CLASSID];
 72:   if (!subtype) *id = PETSC_SMALLEST_FORTRAN_CALLBACK + base->basecount++;
 73:   else {
 74:     for (link=base->subtypes; link; link=link->next) { /* look for either both NULL or matching values (implies both non-NULL) */
 75:       PetscBool match;
 76:       PetscStrcmp(subtype,link->type_name,&match);
 77:       if (match) { /* base type or matching subtype */
 78:         goto found;
 79:       }
 80:     }
 81:     /* Not found. Create node and prepend to class' subtype list */
 82:     PetscNew(&link);
 83:     PetscStrallocpy(subtype,&link->type_name);

 85:     link->max      = PETSC_SMALLEST_FORTRAN_CALLBACK;
 86:     link->next     = base->subtypes;
 87:     base->subtypes = link;

 89: found:
 90:     *id = link->max++;

 92:     base->maxsubtypecount = PetscMax(base->maxsubtypecount,link->max-PETSC_SMALLEST_FORTRAN_CALLBACK);
 93:   }
 94:   return 0;
 95: }

 97: /*@C
 98:    PetscFortranCallbackGetSizes - get sizes of class and subtype pointer arrays

100:    Collective

102:    Input Parameter:
103: .  classid - class Id

105:    Output Parameters:
106: +  numbase - number of registered class callbacks
107: -  numsubtype - max number of registered subtype callbacks

109:    Level: developer

111: .seealso: PetscFortranCallbackRegister()
112: @*/
113: PetscErrorCode PetscFortranCallbackGetSizes(PetscClassId classid,PetscFortranCallbackId *numbase,PetscFortranCallbackId *numsubtype)
114: {
117:   if (classid < _maxclassid) {
118:     FortranCallbackBase *base = &_classbase[classid-PETSC_SMALLEST_CLASSID];
119:     *numbase    = base->basecount;
120:     *numsubtype = base->maxsubtypecount;
121:   } else {                      /* nothing registered */
122:     *numbase    = 0;
123:     *numsubtype = 0;
124:   }
125:   return 0;
126: }