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