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(0); 34 } 35 36 /*@C 37 PetscFortranCallbackRegister - register a type+subtype callback 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 { 54 FortranCallbackBase *base; 55 FortranCallbackLink link; 56 57 PetscFunctionBegin; 58 if (subtype) PetscValidCharPointer(subtype,2); 59 PetscValidPointer(id,3); 60 PetscCheck(classid >= PETSC_SMALLEST_CLASSID && classid <= PETSC_LARGEST_CLASSID,PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"ClassId %d corrupt",classid); 61 *id = 0; 62 if (classid >= _maxclassid) { 63 PetscClassId newmax = PETSC_SMALLEST_CLASSID + 2*(PETSC_LARGEST_CLASSID-PETSC_SMALLEST_CLASSID); 64 FortranCallbackBase *newbase; 65 if (!_classbase) PetscCall(PetscRegisterFinalize(PetscFortranCallbackFinalize)); 66 PetscCall(PetscCalloc1(newmax-PETSC_SMALLEST_CLASSID,&newbase)); 67 PetscCall(PetscArraycpy(newbase,_classbase,_maxclassid-PETSC_SMALLEST_CLASSID)); 68 PetscCall(PetscFree(_classbase)); 69 70 _classbase = newbase; 71 _maxclassid = newmax; 72 } 73 base = &_classbase[classid-PETSC_SMALLEST_CLASSID]; 74 if (!subtype) *id = PETSC_SMALLEST_FORTRAN_CALLBACK + base->basecount++; 75 else { 76 for (link=base->subtypes; link; link=link->next) { /* look for either both NULL or matching values (implies both non-NULL) */ 77 PetscBool match; 78 PetscCall(PetscStrcmp(subtype,link->type_name,&match)); 79 if (match) { /* base type or matching subtype */ 80 goto found; 81 } 82 } 83 /* Not found. Create node and prepend to class' subtype list */ 84 PetscCall(PetscNew(&link)); 85 PetscCall(PetscStrallocpy(subtype,&link->type_name)); 86 87 link->max = PETSC_SMALLEST_FORTRAN_CALLBACK; 88 link->next = base->subtypes; 89 base->subtypes = link; 90 91 found: 92 *id = link->max++; 93 94 base->maxsubtypecount = PetscMax(base->maxsubtypecount,link->max-PETSC_SMALLEST_FORTRAN_CALLBACK); 95 } 96 PetscFunctionReturn(0); 97 } 98 99 /*@C 100 PetscFortranCallbackGetSizes - get sizes of class and subtype pointer arrays 101 102 Collective 103 104 Input Parameter: 105 . classid - class Id 106 107 Output Parameters: 108 + numbase - number of registered class callbacks 109 - numsubtype - max number of registered subtype callbacks 110 111 Level: developer 112 113 .seealso: `PetscFortranCallbackRegister()` 114 @*/ 115 PetscErrorCode PetscFortranCallbackGetSizes(PetscClassId classid,PetscFortranCallbackId *numbase,PetscFortranCallbackId *numsubtype) 116 { 117 PetscFunctionBegin; 118 PetscValidPointer(numbase,2); 119 PetscValidPointer(numsubtype,3); 120 if (classid < _maxclassid) { 121 FortranCallbackBase *base = &_classbase[classid-PETSC_SMALLEST_CLASSID]; 122 *numbase = base->basecount; 123 *numsubtype = base->maxsubtypecount; 124 } else { /* nothing registered */ 125 *numbase = 0; 126 *numsubtype = 0; 127 } 128 PetscFunctionReturn(0); 129 } 130