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