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: }