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