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:   PetscInt            basecount;
 12:   PetscInt            maxsubtypecount;
 13:   FortranCallbackLink subtypes;
 14: } FortranCallbackBase;

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

 19: static PetscErrorCode PetscFortranCallbackFinalize(void)
 20: {
 22:   PetscClassId   i;

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

 36:   _maxclassid = PETSC_SMALLEST_CLASSID;
 37:   return(0);
 38: }

 40: /*@C
 41:    PetscFortranCallbackRegister - register a type+subtype callback

 43:    Not Collective

 45:    Input Arguments:
 46: +  classid - ID of class on which to register callback
 47: -  subtype - subtype string, or NULL for class ids

 49:    Output Arguments:
 50: .  id - callback id

 52:    Level: developer

 54: .seealso: PetscFortranCallbackGetSizes()
 55: @*/
 56: PetscErrorCode PetscFortranCallbackRegister(PetscClassId classid,const char *subtype,PetscFortranCallbackId *id)
 57: {
 58:   PetscErrorCode      ierr;
 59:   FortranCallbackBase *base;
 60:   FortranCallbackLink link;

 63:   *id = 0;
 64:   if (classid < PETSC_SMALLEST_CLASSID || PETSC_LARGEST_CLASSID < classid) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"ClassId %D corrupt",classid);
 65:   if (classid >= _maxclassid) {
 66:     PetscClassId        newmax = PETSC_SMALLEST_CLASSID + 2*(PETSC_LARGEST_CLASSID-PETSC_SMALLEST_CLASSID);
 67:     FortranCallbackBase *newbase;
 68:     if (!_classbase) {
 69:       PetscRegisterFinalize(PetscFortranCallbackFinalize);
 70:     }
 71:     PetscCalloc1(newmax-PETSC_SMALLEST_CLASSID,&newbase);
 72:     PetscArraycpy(newbase,_classbase,_maxclassid-PETSC_SMALLEST_CLASSID);
 73:     PetscFree(_classbase);

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

 92:     link->max      = PETSC_SMALLEST_FORTRAN_CALLBACK;
 93:     link->next     = base->subtypes;
 94:     base->subtypes = link;

 96: found:
 97:     *id = link->max++;

 99:     base->maxsubtypecount = PetscMax(base->maxsubtypecount,link->max-PETSC_SMALLEST_FORTRAN_CALLBACK);
100:   }
101:   return(0);
102: }

104: /*@C
105:    PetscFortranCallbackGetSizes - get sizes of class and subtype pointer arrays

107:    Collective

109:    Input Arguments:
110: .  classid - class Id

112:    Output Arguments:
113: +  numbase - number of registered class callbacks
114: -  numsubtype - max number of registered subtype callbacks

116:    Level: developer

118: .seealso: PetscFortranCallbackRegister()
119: @*/
120: PetscErrorCode PetscFortranCallbackGetSizes(PetscClassId classid,PetscInt *numbase,PetscInt *numsubtype)
121: {

124:   if (classid < _maxclassid) {
125:     FortranCallbackBase *base = &_classbase[classid-PETSC_SMALLEST_CLASSID];
126:     *numbase    = base->basecount;
127:     *numsubtype = base->maxsubtypecount;
128:   } else {                      /* nothing registered */
129:     *numbase    = 0;
130:     *numsubtype = 0;
131:   }
132:   return(0);
133: }