1 #include <private/fortranimpl.h> 2 #include <petscts.h> 3 4 #if defined(PETSC_HAVE_FORTRAN_CAPS) 5 #define tssetrhsfunction_ TSSETRHSFUNCTION 6 #define tssetrhsjacobian_ TSSETRHSJACOBIAN 7 #define tsgetrhsjacobian_ TSGETRHSJACOBIAN 8 #define tsview_ TSVIEW 9 #define tsgetoptionsprefix_ TSGETOPTIONSPREFIX 10 #define tsmonitorset_ TSMONITORSET 11 #define tscomputerhsfunctionlinear_ TSCOMPUTERHSFUNCTIONLINEAR 12 #define tscomputerhsjacobianconstant_ TSCOMPUTERHSJACOBIANCONSTANT 13 #define tsdefaultcomputejacobian_ TSDEFAULTCOMPUTEJACOBIAN 14 #define tsdefaultcomputejacobiancolor_ TSDEFAULTCOMPUTEJACOBIANCOLOR 15 #define tsmonitordefault_ TSMONITORDEFAULT 16 #define tssetprestep_ TSSETPRESTEP 17 #define tssetpoststep_ TSSETPOSTSTEP 18 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 19 #define tssetrhsfunction_ tssetrhsfunction 20 #define tssetrhsjacobian_ tssetrhsjacobian 21 #define tsgetrhsjacobian_ tsgetrhsjacobian 22 #define tsview_ tsview 23 #define tsgetoptionsprefix_ tsgetoptionsprefix 24 #define tsmonitorset_ tsmonitorset 25 #define tscomputerhsfunctionlinear_ tscomputerhsfunctionlinear 26 #define tscomputerhsjacobianconstant_ tscomputerhsjacobianconstant 27 #define tsdefaultcomputejacobian_ tsdefaultcomputejacobian 28 #define tsdefaultcomputejacobiancolor_ tsdefaultcomputejacobiancolor 29 #define tsmonitordefault_ tsmonitordefault 30 #define tssetprestep_ tssetprestep 31 #define tssetpoststep_ tssetpoststep 32 #endif 33 34 static PetscErrorCode ourprestep(TS ts) 35 { 36 PetscErrorCode ierr = 0; 37 (*(void (PETSC_STDCALL *)(TS*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[8]))(&ts,&ierr); 38 return 0; 39 } 40 static PetscErrorCode ourpoststep(TS ts) 41 { 42 PetscErrorCode ierr = 0; 43 (*(void (PETSC_STDCALL *)(TS*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[9]))(&ts,&ierr); 44 return 0; 45 } 46 static PetscErrorCode ourtsfunction(TS ts,PetscReal d,Vec x,Vec f,void *ctx) 47 { 48 PetscErrorCode ierr = 0; 49 (*(void (PETSC_STDCALL *)(TS*,PetscReal*,Vec*,Vec*,void*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[1]))(&ts,&d,&x,&f,ctx,&ierr); 50 return 0; 51 } 52 static PetscErrorCode ourtsjacobian(TS ts,PetscReal d,Vec x,Mat* m,Mat* p,MatStructure* type,void*ctx) 53 { 54 PetscErrorCode ierr = 0; 55 (*(void (PETSC_STDCALL *)(TS*,PetscReal*,Vec*,Mat*,Mat*,MatStructure*,void*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[3]))(&ts,&d,&x,m,p,type,ctx,&ierr); 56 return 0; 57 } 58 59 static PetscErrorCode ourmonitordestroy(void **ctx) 60 { 61 PetscErrorCode ierr = 0; 62 TS ts = *(TS*)ctx; 63 void *mctx = (void*) ((PetscObject)ts)->fortran_func_pointers[6]; 64 (*(void (PETSC_STDCALL *)(void*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[5]))(mctx,&ierr); 65 return 0; 66 } 67 68 /* 69 Note ctx is the same as ts so we need to get the Fortran context out of the TS 70 */ 71 static PetscErrorCode ourtsmonitor(TS ts,PetscInt i,PetscReal d,Vec v,void*ctx) 72 { 73 PetscErrorCode ierr = 0; 74 void *mctx = (void*) ((PetscObject)ts)->fortran_func_pointers[6]; 75 (*(void (PETSC_STDCALL *)(TS*,PetscInt*,PetscReal*,Vec*,void*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[4]))(&ts,&i,&d,&v,mctx,&ierr); 76 return 0; 77 } 78 79 EXTERN_C_BEGIN 80 81 void PETSC_STDCALL tssetprestep_(TS *ts,PetscErrorCode (PETSC_STDCALL *f)(TS*,PetscErrorCode*),PetscErrorCode *ierr) 82 { 83 PetscObjectAllocateFortranPointers(*ts,10); 84 ((PetscObject)*ts)->fortran_func_pointers[8] = (PetscVoidFunction)f; 85 *ierr = TSSetPreStep(*ts,ourprestep); 86 } 87 88 void PETSC_STDCALL tssetpoststep_(TS *ts,PetscErrorCode (PETSC_STDCALL *f)(TS*,PetscErrorCode*),PetscErrorCode *ierr) 89 { 90 PetscObjectAllocateFortranPointers(*ts,10); 91 ((PetscObject)*ts)->fortran_func_pointers[9] = (PetscVoidFunction)f; 92 *ierr = TSSetPreStep(*ts,ourpoststep); 93 } 94 95 void tscomputerhsfunctionlinear_(TS *ts,PetscReal *t,Vec *X,Vec *F,void *ctx,PetscErrorCode *ierr) 96 { 97 *ierr = TSComputeRHSFunctionLinear(*ts,*t,*X,*F,ctx); 98 } 99 void PETSC_STDCALL tssetrhsfunction_(TS *ts,Vec *r,PetscErrorCode (PETSC_STDCALL *f)(TS*,PetscReal*,Vec*,Vec*,void*,PetscErrorCode*),void*fP,PetscErrorCode *ierr) 100 { 101 Vec R; 102 CHKFORTRANNULLOBJECT(r); 103 CHKFORTRANNULLFUNCTION(f); 104 CHKFORTRANNULLOBJECT(fP); 105 R = r ? *r : PETSC_NULL; 106 if ((PetscVoidFunction)f == (PetscVoidFunction)tscomputerhsfunctionlinear_) { 107 *ierr = TSSetRHSFunction(*ts,R,TSComputeRHSFunctionLinear,fP); 108 } else { 109 PetscObjectAllocateFortranPointers(*ts,10); 110 ((PetscObject)*ts)->fortran_func_pointers[1] = (PetscVoidFunction)f; 111 *ierr = TSSetRHSFunction(*ts,R,ourtsfunction,fP); 112 } 113 } 114 115 /* ---------------------------------------------------------*/ 116 extern void tsdefaultcomputejacobian_(TS*,PetscReal*,Vec*,Mat*,Mat*,MatStructure*,void*,PetscErrorCode*); 117 extern void tsdefaultcomputejacobiancolor_(TS*,PetscReal*,Vec*,Mat*,Mat*,MatStructure*,void*,PetscErrorCode*); 118 void tscomputerhsjacobianconstant_(TS *ts,PetscReal *t,Vec *X,Mat *A,Mat *B,MatStructure *flg,void *ctx,PetscErrorCode *ierr) 119 { 120 *ierr = TSComputeRHSJacobianConstant(*ts,*t,*X,A,B,flg,ctx); 121 } 122 void PETSC_STDCALL tssetrhsjacobian_(TS *ts,Mat *A,Mat *B,void (PETSC_STDCALL *f)(TS*,PetscReal*,Vec*,Mat*,Mat*,MatStructure*, 123 void*,PetscErrorCode*),void*fP,PetscErrorCode *ierr) 124 { 125 PetscObjectAllocateFortranPointers(*ts,10); 126 if (FORTRANNULLFUNCTION(f)) { 127 *ierr = TSSetRHSJacobian(*ts,*A,*B,PETSC_NULL,fP); 128 } else if ((PetscVoidFunction)f == (PetscVoidFunction)tscomputerhsjacobianconstant_) { 129 *ierr = TSSetRHSJacobian(*ts,*A,*B,TSComputeRHSJacobianConstant,fP); 130 } else if ((PetscVoidFunction)f == (PetscVoidFunction)tsdefaultcomputejacobian_) { 131 *ierr = TSSetRHSJacobian(*ts,*A,*B,TSDefaultComputeJacobian,fP); 132 } else if ((PetscVoidFunction)f == (PetscVoidFunction)tsdefaultcomputejacobiancolor_) { 133 *ierr = TSSetRHSJacobian(*ts,*A,*B,TSDefaultComputeJacobianColor,*(MatFDColoring*)fP); 134 } else { 135 ((PetscObject)*ts)->fortran_func_pointers[3] = (PetscVoidFunction)f; 136 *ierr = TSSetRHSJacobian(*ts,*A,*B,ourtsjacobian,fP); 137 } 138 } 139 140 /* ---------------------------------------------------------*/ 141 142 extern void PETSC_STDCALL tsmonitordefault_(TS*,PetscInt*,PetscReal*,Vec*,void*,PetscErrorCode*); 143 144 void PETSC_STDCALL tsmonitorset_(TS *ts,void (PETSC_STDCALL *func)(TS*,PetscInt*,PetscReal*,Vec*,void*,PetscErrorCode*),void (*mctx)(void),void (PETSC_STDCALL *d)(void*,PetscErrorCode*),PetscErrorCode *ierr) 145 { 146 PetscObjectAllocateFortranPointers(*ts,10); 147 if ((PetscVoidFunction)func == (PetscVoidFunction)tsmonitordefault_) { 148 *ierr = TSMonitorSet(*ts,TSMonitorDefault,0,0); 149 } else { 150 ((PetscObject)*ts)->fortran_func_pointers[4] = (PetscVoidFunction)func; 151 ((PetscObject)*ts)->fortran_func_pointers[5] = (PetscVoidFunction)d; 152 ((PetscObject)*ts)->fortran_func_pointers[6] = (PetscVoidFunction)mctx; 153 if (FORTRANNULLFUNCTION(d)) { 154 *ierr = TSMonitorSet(*ts,ourtsmonitor,*ts,0); 155 } else { 156 *ierr = TSMonitorSet(*ts,ourtsmonitor,*ts,ourmonitordestroy); 157 } 158 } 159 } 160 161 /* ---------------------------------------------------------*/ 162 /* func is currently ignored from Fortran */ 163 void PETSC_STDCALL tsgetrhsjacobian_(TS *ts,Mat *J,Mat *M,int *func,void **ctx,PetscErrorCode *ierr) 164 { 165 *ierr = TSGetRHSJacobian(*ts,J,M,0,ctx); 166 } 167 168 void PETSC_STDCALL tsview_(TS *ts,PetscViewer *viewer, PetscErrorCode *ierr) 169 { 170 PetscViewer v; 171 PetscPatchDefaultViewers_Fortran(viewer,v); 172 *ierr = TSView(*ts,v); 173 } 174 175 void PETSC_STDCALL tsgetoptionsprefix_(TS *ts,CHAR prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 176 { 177 const char *tname; 178 179 *ierr = TSGetOptionsPrefix(*ts,&tname); 180 *ierr = PetscStrncpy(prefix,tname,len); 181 } 182 183 184 EXTERN_C_END 185