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 { 21 PetscFunctionBegin; 22 for (PetscInt i = PETSC_SMALLEST_CLASSID; i < _maxclassid; i++) { 23 FortranCallbackBase *base = &_classbase[i - PETSC_SMALLEST_CLASSID]; 24 FortranCallbackLink next, link = base->subtypes; 25 for (; link; link = next) { 26 next = link->next; 27 PetscCall(PetscFree(link->type_name)); 28 PetscCall(PetscFree(link)); 29 } 30 } 31 PetscCall(PetscFree(_classbase)); 32 _maxclassid = PETSC_SMALLEST_CLASSID; 33 PetscFunctionReturn(PETSC_SUCCESS); 34 } 35 36 /*@C 37 PetscFortranCallbackRegister - register a type+subtype callback. This is used by the PETSc Fortran interface to allow the use of user Fortran functions as arguments 38 to PETSc functions that take function pointers 39 40 Not Collective 41 42 Input Parameters: 43 + classid - ID of class on which to register callback 44 - subtype - subtype string, or NULL for class ids 45 46 Output Parameter: 47 . id - callback id 48 49 Level: developer 50 51 .seealso: `PetscFortranCallbackGetSizes()` 52 @*/ 53 PetscErrorCode PetscFortranCallbackRegister(PetscClassId classid, const char *subtype, PetscFortranCallbackId *id) 54 { 55 FortranCallbackBase *base; 56 FortranCallbackLink link; 57 58 PetscFunctionBegin; 59 if (subtype) PetscValidCharPointer(subtype, 2); 60 PetscValidPointer(id, 3); 61 PetscCheck(classid >= PETSC_SMALLEST_CLASSID && classid <= PETSC_LARGEST_CLASSID, PETSC_COMM_SELF, PETSC_ERR_ARG_CORRUPT, "ClassId %d corrupt", classid); 62 *id = 0; 63 if (classid >= _maxclassid) { 64 PetscClassId newmax = PETSC_SMALLEST_CLASSID + 2 * (PETSC_LARGEST_CLASSID - PETSC_SMALLEST_CLASSID); 65 FortranCallbackBase *newbase; 66 if (!_classbase) PetscCall(PetscRegisterFinalize(PetscFortranCallbackFinalize)); 67 PetscCall(PetscCalloc1(newmax - PETSC_SMALLEST_CLASSID, &newbase)); 68 PetscCall(PetscArraycpy(newbase, _classbase, _maxclassid - PETSC_SMALLEST_CLASSID)); 69 PetscCall(PetscFree(_classbase)); 70 71 _classbase = newbase; 72 _maxclassid = newmax; 73 } 74 base = &_classbase[classid - PETSC_SMALLEST_CLASSID]; 75 if (!subtype) *id = PETSC_SMALLEST_FORTRAN_CALLBACK + base->basecount++; 76 else { 77 for (link = base->subtypes; link; link = link->next) { /* look for either both NULL or matching values (implies both non-NULL) */ 78 PetscBool match; 79 PetscCall(PetscStrcmp(subtype, link->type_name, &match)); 80 if (match) { /* base type or matching subtype */ 81 goto found; 82 } 83 } 84 /* Not found. Create node and prepend to class' subtype list */ 85 PetscCall(PetscNew(&link)); 86 PetscCall(PetscStrallocpy(subtype, &link->type_name)); 87 88 link->max = PETSC_SMALLEST_FORTRAN_CALLBACK; 89 link->next = base->subtypes; 90 base->subtypes = link; 91 92 found: 93 *id = link->max++; 94 95 base->maxsubtypecount = PetscMax(base->maxsubtypecount, link->max - PETSC_SMALLEST_FORTRAN_CALLBACK); 96 } 97 PetscFunctionReturn(PETSC_SUCCESS); 98 } 99 100 /*@C 101 PetscFortranCallbackGetSizes - get sizes of class and subtype pointer arrays 102 103 Collective 104 105 Input Parameter: 106 . classid - class Id 107 108 Output Parameters: 109 + numbase - number of registered class callbacks 110 - numsubtype - max number of registered subtype callbacks 111 112 Level: developer 113 114 .seealso: `PetscFortranCallbackRegister()` 115 @*/ 116 PetscErrorCode PetscFortranCallbackGetSizes(PetscClassId classid, PetscFortranCallbackId *numbase, PetscFortranCallbackId *numsubtype) 117 { 118 PetscFunctionBegin; 119 PetscValidPointer(numbase, 2); 120 PetscValidPointer(numsubtype, 3); 121 if (classid < _maxclassid) { 122 FortranCallbackBase *base = &_classbase[classid - PETSC_SMALLEST_CLASSID]; 123 *numbase = base->basecount; 124 *numsubtype = base->maxsubtypecount; 125 } else { /* nothing registered */ 126 *numbase = 0; 127 *numsubtype = 0; 128 } 129 PetscFunctionReturn(PETSC_SUCCESS); 130 } 131