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. This is used by the PETSc Fortran interface to allow the use of user Fortran functions as arguments
37: to PETSc functions that take function pointers
39: Not Collective
41: Input Parameters:
42: + classid - ID of class on which to register callback
43: - subtype - subtype string, or NULL for class ids
45: Output Parameter:
46: . id - callback id
48: Level: developer
50: .seealso: `PetscFortranCallbackGetSizes()`
51: @*/
52: PetscErrorCode PetscFortranCallbackRegister(PetscClassId classid, const char *subtype, PetscFortranCallbackId *id)
53: {
54: FortranCallbackBase *base;
55: FortranCallbackLink link;
60: *id = 0;
61: if (classid >= _maxclassid) {
62: PetscClassId newmax = PETSC_SMALLEST_CLASSID + 2 * (PETSC_LARGEST_CLASSID - PETSC_SMALLEST_CLASSID);
63: FortranCallbackBase *newbase;
64: if (!_classbase) PetscRegisterFinalize(PetscFortranCallbackFinalize);
65: PetscCalloc1(newmax - PETSC_SMALLEST_CLASSID, &newbase);
66: PetscArraycpy(newbase, _classbase, _maxclassid - PETSC_SMALLEST_CLASSID);
67: PetscFree(_classbase);
69: _classbase = newbase;
70: _maxclassid = newmax;
71: }
72: base = &_classbase[classid - PETSC_SMALLEST_CLASSID];
73: if (!subtype) *id = PETSC_SMALLEST_FORTRAN_CALLBACK + base->basecount++;
74: else {
75: for (link = base->subtypes; link; link = link->next) { /* look for either both NULL or matching values (implies both non-NULL) */
76: PetscBool match;
77: PetscStrcmp(subtype, link->type_name, &match);
78: if (match) { /* base type or matching subtype */
79: goto found;
80: }
81: }
82: /* Not found. Create node and prepend to class' subtype list */
83: PetscNew(&link);
84: PetscStrallocpy(subtype, &link->type_name);
86: link->max = PETSC_SMALLEST_FORTRAN_CALLBACK;
87: link->next = base->subtypes;
88: base->subtypes = link;
90: found:
91: *id = link->max++;
93: base->maxsubtypecount = PetscMax(base->maxsubtypecount, link->max - PETSC_SMALLEST_FORTRAN_CALLBACK);
94: }
95: return 0;
96: }
98: /*@C
99: PetscFortranCallbackGetSizes - get sizes of class and subtype pointer arrays
101: Collective
103: Input Parameter:
104: . classid - class Id
106: Output Parameters:
107: + numbase - number of registered class callbacks
108: - numsubtype - max number of registered subtype callbacks
110: Level: developer
112: .seealso: `PetscFortranCallbackRegister()`
113: @*/
114: PetscErrorCode PetscFortranCallbackGetSizes(PetscClassId classid, PetscFortranCallbackId *numbase, PetscFortranCallbackId *numsubtype)
115: {
118: if (classid < _maxclassid) {
119: FortranCallbackBase *base = &_classbase[classid - PETSC_SMALLEST_CLASSID];
120: *numbase = base->basecount;
121: *numsubtype = base->maxsubtypecount;
122: } else { /* nothing registered */
123: *numbase = 0;
124: *numsubtype = 0;
125: }
126: return 0;
127: }