1 #include <petscsys.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 _maxclassid = PETSC_SMALLEST_CLASSID; 38 PetscFunctionReturn(0); 39 } 40 41 #undef __FUNCT__ 42 #define __FUNCT__ "PetscFortranCallbackRegister" 43 /*@C 44 PetscFortranCallbackRegister - register a type+subtype callback 45 46 Not Collective 47 48 Input Arguments: 49 + classid - ID of class on which to register callback 50 - subtype - subtype string, or PETSC_NULL for class ids 51 52 Output Arguments: 53 . id - callback id 54 55 Level: developer 56 57 .seealso: PetscFortranCallbackGetSizes() 58 @*/ 59 PetscErrorCode PetscFortranCallbackRegister(PetscClassId classid,const char *subtype,PetscFortranCallbackId *id) 60 { 61 PetscErrorCode ierr; 62 FortranCallbackBase *base; 63 FortranCallbackLink link; 64 65 PetscFunctionBegin; 66 *id = 0; 67 if (classid < PETSC_SMALLEST_CLASSID || PETSC_LARGEST_CLASSID <= classid) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_ARG_CORRUPT,"ClassId %D corrupt",classid); 68 if (classid >= _maxclassid) { 69 PetscClassId newmax = PETSC_SMALLEST_CLASSID + 2*(PETSC_LARGEST_CLASSID-PETSC_SMALLEST_CLASSID); 70 FortranCallbackBase *newbase; 71 if (!_classbase) { 72 ierr = PetscRegisterFinalize(PetscFortranCallbackFinalize);CHKERRQ(ierr); 73 } 74 ierr = PetscMalloc((newmax-PETSC_SMALLEST_CLASSID)*sizeof(_classbase[0]),&newbase);CHKERRQ(ierr); 75 ierr = PetscMemzero(newbase,(newmax-PETSC_SMALLEST_CLASSID)*sizeof(_classbase[0]));CHKERRQ(ierr); 76 ierr = PetscMemcpy(newbase,_classbase,(_maxclassid-PETSC_SMALLEST_CLASSID)*sizeof(_classbase[0]));CHKERRQ(ierr); 77 ierr = PetscFree(_classbase);CHKERRQ(ierr); 78 _classbase = newbase; 79 _maxclassid = newmax; 80 } 81 base = &_classbase[classid-PETSC_SMALLEST_CLASSID]; 82 if (!subtype) { 83 *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 = PetscMalloc(sizeof(*link),&link);CHKERRQ(ierr); 94 ierr = PetscStrallocpy(subtype,&link->type_name);CHKERRQ(ierr); 95 link->max = PETSC_SMALLEST_FORTRAN_CALLBACK; 96 link->next = base->subtypes; 97 base->subtypes = link; 98 found: 99 *id = link->max++; 100 base->maxsubtypecount = PetscMax(base->maxsubtypecount,link->max-PETSC_SMALLEST_FORTRAN_CALLBACK); 101 } 102 PetscFunctionReturn(0); 103 } 104 105 #undef __FUNCT__ 106 #define __FUNCT__ "PetscFortranCallbackGetSizes" 107 /*@C 108 PetscFortranCallbackGetSizes - get sizes of class and subtype pointer arrays 109 110 Collective 111 112 Input Arguments: 113 . classid - class Id 114 115 Output Arguments: 116 + numbase - number of registered class callbacks 117 - numsubtype - max number of registered subtype callbacks 118 119 Level: developer 120 121 .seealso: PetscFortranCallbackRegister() 122 @*/ 123 PetscErrorCode PetscFortranCallbackGetSizes(PetscClassId classid,PetscInt *numbase,PetscInt *numsubtype) 124 { 125 126 PetscFunctionBegin; 127 if (classid < _maxclassid) { 128 FortranCallbackBase *base = &_classbase[classid-PETSC_SMALLEST_CLASSID]; 129 *numbase = base->basecount; 130 *numsubtype = base->maxsubtypecount; 131 } else { /* nothing registered */ 132 *numbase = 0; 133 *numsubtype = 0; 134 } 135 PetscFunctionReturn(0); 136 } 137