Date: 2022-03-04T17:37:09+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:   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 Parameters:
     46: +  classid - ID of class on which to register callback
     47: -  subtype - subtype string, or NULL for class ids

     49:    Output Parameter:
     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 Parameter:
    110: .  classid - class Id

    112:    Output Parameters:
    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: }