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 PetscFortranCallbackId basecount; 12 PetscFortranCallbackId maxsubtypecount; 13 FortranCallbackLink subtypes; 14 } FortranCallbackBase; 15 16 static FortranCallbackBase *_classbase; 17 static PetscClassId _maxclassid = PETSC_SMALLEST_CLASSID; 18 19 static PetscErrorCode PetscFortranCallbackFinalize(void) { 20 PetscFunctionBegin; 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 PetscCall(PetscFree(link->type_name)); 27 PetscCall(PetscFree(link)); 28 } 29 } 30 PetscCall(PetscFree(_classbase)); 31 _maxclassid = PETSC_SMALLEST_CLASSID; 32 PetscFunctionReturn(0); 33 } 34 35 /*@C 36 PetscFortranCallbackRegister - register a type+subtype callback 37 38 Not Collective 39 40 Input Parameters: 41 + classid - ID of class on which to register callback 42 - subtype - subtype string, or NULL for class ids 43 44 Output Parameter: 45 . id - callback id 46 47 Level: developer 48 49 .seealso: `PetscFortranCallbackGetSizes()` 50 @*/ 51 PetscErrorCode PetscFortranCallbackRegister(PetscClassId classid, const char *subtype, PetscFortranCallbackId *id) { 52 FortranCallbackBase *base; 53 FortranCallbackLink link; 54 55 PetscFunctionBegin; 56 if (subtype) PetscValidCharPointer(subtype, 2); 57 PetscValidPointer(id, 3); 58 PetscCheck(classid >= PETSC_SMALLEST_CLASSID && classid <= PETSC_LARGEST_CLASSID, PETSC_COMM_SELF, PETSC_ERR_ARG_CORRUPT, "ClassId %d corrupt", classid); 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) PetscCall(PetscRegisterFinalize(PetscFortranCallbackFinalize)); 64 PetscCall(PetscCalloc1(newmax - PETSC_SMALLEST_CLASSID, &newbase)); 65 PetscCall(PetscArraycpy(newbase, _classbase, _maxclassid - PETSC_SMALLEST_CLASSID)); 66 PetscCall(PetscFree(_classbase)); 67 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 PetscCall(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 PetscCall(PetscNew(&link)); 83 PetscCall(PetscStrallocpy(subtype, &link->type_name)); 84 85 link->max = PETSC_SMALLEST_FORTRAN_CALLBACK; 86 link->next = base->subtypes; 87 base->subtypes = link; 88 89 found: 90 *id = link->max++; 91 92 base->maxsubtypecount = PetscMax(base->maxsubtypecount, link->max - PETSC_SMALLEST_FORTRAN_CALLBACK); 93 } 94 PetscFunctionReturn(0); 95 } 96 97 /*@C 98 PetscFortranCallbackGetSizes - get sizes of class and subtype pointer arrays 99 100 Collective 101 102 Input Parameter: 103 . classid - class Id 104 105 Output Parameters: 106 + numbase - number of registered class callbacks 107 - numsubtype - max number of registered subtype callbacks 108 109 Level: developer 110 111 .seealso: `PetscFortranCallbackRegister()` 112 @*/ 113 PetscErrorCode PetscFortranCallbackGetSizes(PetscClassId classid, PetscFortranCallbackId *numbase, PetscFortranCallbackId *numsubtype) { 114 PetscFunctionBegin; 115 PetscValidPointer(numbase, 2); 116 PetscValidPointer(numsubtype, 3); 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 PetscFunctionReturn(0); 126 } 127