1 #include <petsc/private/petscimpl.h> /*I "petscsys.h" I*/
2
3 typedef struct _FortranCallbackLink *FortranCallbackLink;
4 struct _FortranCallbackLink {
5 char *type_name;
6 PetscFortranCallbackId max;
7 FortranCallbackLink next;
8 };
9
10 typedef struct {
11 PetscInt basecount;
12 PetscInt maxsubtypecount;
13 FortranCallbackLink subtypes;
14 } FortranCallbackBase;
15
16 static FortranCallbackBase *_classbase;
17 static PetscClassId _maxclassid = PETSC_SMALLEST_CLASSID;
18
PetscFortranCallbackFinalize(void)19 static PetscErrorCode PetscFortranCallbackFinalize(void)
20 {
21 PetscErrorCode ierr;
22 PetscClassId i;
23
24 PetscFunctionBegin;
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 ierr = PetscFree(link->type_name);CHKERRQ(ierr);
31 ierr = PetscFree(link);CHKERRQ(ierr);
32 }
33 }
34 ierr = PetscFree(_classbase);CHKERRQ(ierr);
35
36 _maxclassid = PETSC_SMALLEST_CLASSID;
37 PetscFunctionReturn(0);
38 }
39
40 /*@C
41 PetscFortranCallbackRegister - register a type+subtype callback
42
43 Not Collective
44
45 Input Arguments:
46 + classid - ID of class on which to register callback
47 - subtype - subtype string, or NULL for class ids
48
49 Output Arguments:
50 . id - callback id
51
52 Level: developer
53
54 .seealso: PetscFortranCallbackGetSizes()
55 @*/
PetscFortranCallbackRegister(PetscClassId classid,const char * subtype,PetscFortranCallbackId * id)56 PetscErrorCode PetscFortranCallbackRegister(PetscClassId classid,const char *subtype,PetscFortranCallbackId *id)
57 {
58 PetscErrorCode ierr;
59 FortranCallbackBase *base;
60 FortranCallbackLink link;
61
62 PetscFunctionBegin;
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 ierr = PetscRegisterFinalize(PetscFortranCallbackFinalize);CHKERRQ(ierr);
70 }
71 ierr = PetscCalloc1(newmax-PETSC_SMALLEST_CLASSID,&newbase);CHKERRQ(ierr);
72 ierr = PetscArraycpy(newbase,_classbase,_maxclassid-PETSC_SMALLEST_CLASSID);CHKERRQ(ierr);
73 ierr = PetscFree(_classbase);CHKERRQ(ierr);
74
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 ierr = PetscStrcmp(subtype,link->type_name,&match);CHKERRQ(ierr);
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 ierr = PetscNew(&link);CHKERRQ(ierr);
90 ierr = PetscStrallocpy(subtype,&link->type_name);CHKERRQ(ierr);
91
92 link->max = PETSC_SMALLEST_FORTRAN_CALLBACK;
93 link->next = base->subtypes;
94 base->subtypes = link;
95
96 found:
97 *id = link->max++;
98
99 base->maxsubtypecount = PetscMax(base->maxsubtypecount,link->max-PETSC_SMALLEST_FORTRAN_CALLBACK);
100 }
101 PetscFunctionReturn(0);
102 }
103
104 /*@C
105 PetscFortranCallbackGetSizes - get sizes of class and subtype pointer arrays
106
107 Collective
108
109 Input Arguments:
110 . classid - class Id
111
112 Output Arguments:
113 + numbase - number of registered class callbacks
114 - numsubtype - max number of registered subtype callbacks
115
116 Level: developer
117
118 .seealso: PetscFortranCallbackRegister()
119 @*/
PetscFortranCallbackGetSizes(PetscClassId classid,PetscInt * numbase,PetscInt * numsubtype)120 PetscErrorCode PetscFortranCallbackGetSizes(PetscClassId classid,PetscInt *numbase,PetscInt *numsubtype)
121 {
122
123 PetscFunctionBegin;
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 PetscFunctionReturn(0);
133 }
134