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 = PetscMalloc((newmax-PETSC_SMALLEST_CLASSID)*sizeof(_classbase[0]),&newbase);CHKERRQ(ierr); 76 ierr = PetscMemzero(newbase,(newmax-PETSC_SMALLEST_CLASSID)*sizeof(_classbase[0]));CHKERRQ(ierr); 77 ierr = PetscMemcpy(newbase,_classbase,(_maxclassid-PETSC_SMALLEST_CLASSID)*sizeof(_classbase[0]));CHKERRQ(ierr); 78 ierr = PetscFree(_classbase);CHKERRQ(ierr); 79 80 _classbase = newbase; 81 _maxclassid = newmax; 82 } 83 base = &_classbase[classid-PETSC_SMALLEST_CLASSID]; 84 if (!subtype) *id = PETSC_SMALLEST_FORTRAN_CALLBACK + base->basecount++; 85 else { 86 for (link=base->subtypes; link; link=link->next) { /* look for either both NULL or matching values (implies both non-NULL) */ 87 PetscBool match; 88 ierr = PetscStrcmp(subtype,link->type_name,&match);CHKERRQ(ierr); 89 if (match) { /* base type or matching subtype */ 90 goto found; 91 } 92 } 93 /* Not found. Create node and prepend to class' subtype list */ 94 ierr = PetscMalloc(sizeof(*link),&link);CHKERRQ(ierr); 95 ierr = PetscStrallocpy(subtype,&link->type_name);CHKERRQ(ierr); 96 97 link->max = PETSC_SMALLEST_FORTRAN_CALLBACK; 98 link->next = base->subtypes; 99 base->subtypes = link; 100 101 found: 102 *id = link->max++; 103 104 base->maxsubtypecount = PetscMax(base->maxsubtypecount,link->max-PETSC_SMALLEST_FORTRAN_CALLBACK); 105 } 106 PetscFunctionReturn(0); 107 } 108 109 #undef __FUNCT__ 110 #define __FUNCT__ "PetscFortranCallbackGetSizes" 111 /*@C 112 PetscFortranCallbackGetSizes - get sizes of class and subtype pointer arrays 113 114 Collective 115 116 Input Arguments: 117 . classid - class Id 118 119 Output Arguments: 120 + numbase - number of registered class callbacks 121 - numsubtype - max number of registered subtype callbacks 122 123 Level: developer 124 125 .seealso: PetscFortranCallbackRegister() 126 @*/ 127 PetscErrorCode PetscFortranCallbackGetSizes(PetscClassId classid,PetscInt *numbase,PetscInt *numsubtype) 128 { 129 130 PetscFunctionBegin; 131 if (classid < _maxclassid) { 132 FortranCallbackBase *base = &_classbase[classid-PETSC_SMALLEST_CLASSID]; 133 *numbase = base->basecount; 134 *numsubtype = base->maxsubtypecount; 135 } else { /* nothing registered */ 136 *numbase = 0; 137 *numsubtype = 0; 138 } 139 PetscFunctionReturn(0); 140 } 141