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:     PetscMalloc((newmax-PETSC_SMALLEST_CLASSID)*sizeof(_classbase[0]),&newbase);
 76:     PetscMemzero(newbase,(newmax-PETSC_SMALLEST_CLASSID)*sizeof(_classbase[0]));
 77:     PetscMemcpy(newbase,_classbase,(_maxclassid-PETSC_SMALLEST_CLASSID)*sizeof(_classbase[0]));
 78:     PetscFree(_classbase);

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

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

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

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

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

114:    Collective

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

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

123:    Level: developer

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

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