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