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