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. This is used by the PETSc Fortran interface to allow the use of user Fortran functions as arguments
 37:    to PETSc functions that take function pointers

 39:    Not Collective

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

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

 48:    Level: developer

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

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

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

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

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

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

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

101:    Collective

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

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

110:    Level: developer

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