Date: 2022-03-31T04:46:07+00:00

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