1 #include <petsc-private/fortranimpl.h> 2 #include <petscts.h> 3 4 #if defined(PETSC_HAVE_FORTRAN_CAPS) 5 #define tssetrhsfunction_ TSSETRHSFUNCTION 6 #define tsgetrhsfunction_ TSGETRHSFUNCTION 7 #define tssetrhsjacobian_ TSSETRHSJACOBIAN 8 #define tsgetrhsjacobian_ TSGETRHSJACOBIAN 9 #define tssetifunction_ TSSETIFUNCTION 10 #define tsgetifunction_ TSGETIFUNCTION 11 #define tssetijacobian_ TSSETIJACOBIAN 12 #define tsgetijacobian_ TSGETIJACOBIAN 13 #define tsview_ TSVIEW 14 #define tssetoptionsprefix_ TSSETOPTIONSPREFIX 15 #define tsgetoptionsprefix_ TSGETOPTIONSPREFIX 16 #define tsappendoptionsprefix_ TSAPPENDOPTIONSPREFIX 17 #define tsmonitorset_ TSMONITORSET 18 #define tscomputerhsfunctionlinear_ TSCOMPUTERHSFUNCTIONLINEAR 19 #define tscomputerhsjacobianconstant_ TSCOMPUTERHSJACOBIANCONSTANT 20 #define tscomputeifunctionlinear_ TSCOMPUTEIFUNCTIONLINEAR 21 #define tscomputeijacobianconstant_ TSCOMPUTEIJACOBIANCONSTANT 22 #define tsmonitordefault_ TSMONITORDEFAULT 23 #define tssetprestep_ TSSETPRESTEP 24 #define tssetpoststep_ TSSETPOSTSTEP 25 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 26 #define tssetrhsfunction_ tssetrhsfunction 27 #define tsgetrhsfunction_ tsgetrhsfunction 28 #define tssetrhsjacobian_ tssetrhsjacobian 29 #define tsgetrhsjacobian_ tsgetrhsjacobian 30 #define tssetifunction_ tssetifunction 31 #define tsgetifunction_ tsgetifunction 32 #define tssetijacobian_ tssetijacobian 33 #define tsgetijacobian_ tsgetijacobian 34 #define tsview_ tsview 35 #define tssetoptionsprefix_ tssetoptionsprefix 36 #define tsgetoptionsprefix_ tsgetoptionsprefix 37 #define tsappendoptionsprefix_ tsappendoptionsprefix 38 #define tsmonitorset_ tsmonitorset 39 #define tscomputerhsfunctionlinear_ tscomputerhsfunctionlinear 40 #define tscomputerhsjacobianconstant_ tscomputerhsjacobianconstant 41 #define tscomputeifunctionlinear_ tscomputeifunctionlinear 42 #define tscomputeijacobianconstant_ tscomputeijacobianconstant 43 #define tsmonitordefault_ tsmonitordefault 44 #define tssetprestep_ tssetprestep 45 #define tssetpoststep_ tssetpoststep 46 #endif 47 48 enum {OUR_PRESTEP = 0, 49 OUR_POSTSTEP, 50 OUR_RHSFUNCTION, 51 OUR_IFUNCTION, 52 OUR_RHSJACOBIAN, 53 OUR_IJACOBIAN, 54 OUR_MONITOR, 55 OUR_MONITORDESTROY, 56 OUR_MONITOR_CTX, /* Casting from function pointer is invalid according to the standard. */ 57 OUR_COUNT}; 58 59 static PetscErrorCode ourprestep(TS ts) 60 { 61 PetscErrorCode ierr = 0; 62 (*(void (PETSC_STDCALL *)(TS*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[OUR_PRESTEP]))(&ts,&ierr); 63 return 0; 64 } 65 static PetscErrorCode ourpoststep(TS ts) 66 { 67 PetscErrorCode ierr = 0; 68 (*(void (PETSC_STDCALL *)(TS*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[OUR_POSTSTEP]))(&ts,&ierr); 69 return 0; 70 } 71 static PetscErrorCode ourrhsfunction(TS ts,PetscReal d,Vec x,Vec f,void *ctx) 72 { 73 PetscErrorCode ierr = 0; 74 (*(void (PETSC_STDCALL *)(TS*,PetscReal*,Vec*,Vec*,void*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[OUR_RHSFUNCTION]))(&ts,&d,&x,&f,ctx,&ierr); 75 return 0; 76 } 77 static PetscErrorCode ourifunction(TS ts,PetscReal d,Vec x,Vec xdot,Vec f,void *ctx) 78 { 79 PetscErrorCode ierr = 0; 80 (*(void (PETSC_STDCALL *)(TS*,PetscReal*,Vec*,Vec*,Vec*,void*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[OUR_IFUNCTION]))(&ts,&d,&x,&xdot,&f,ctx,&ierr); 81 return 0; 82 } 83 static PetscErrorCode ourrhsjacobian(TS ts,PetscReal d,Vec x,Mat* m,Mat* p,MatStructure* type,void*ctx) 84 { 85 PetscErrorCode ierr = 0; 86 (*(void (PETSC_STDCALL *)(TS*,PetscReal*,Vec*,Mat*,Mat*,MatStructure*,void*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[OUR_RHSJACOBIAN]))(&ts,&d,&x,m,p,type,ctx,&ierr); 87 return 0; 88 } 89 static PetscErrorCode ourijacobian(TS ts,PetscReal d,Vec x,Vec xdot,PetscReal shift,Mat* m,Mat* p,MatStructure* type,void*ctx) 90 { 91 PetscErrorCode ierr = 0; 92 (*(void (PETSC_STDCALL *)(TS*,PetscReal*,Vec*,Vec*,PetscReal*,Mat*,Mat*,MatStructure*,void*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[OUR_IJACOBIAN]))(&ts,&d,&x,&xdot,&shift,m,p,type,ctx,&ierr); 93 return 0; 94 } 95 96 static PetscErrorCode ourmonitordestroy(void **ctx) 97 { 98 PetscErrorCode ierr = 0; 99 TS ts = *(TS*)ctx; 100 void *mctx = (void*) ((PetscObject)ts)->fortran_func_pointers[OUR_MONITOR_CTX]; 101 (*(void (PETSC_STDCALL *)(void*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[OUR_MONITORDESTROY]))(mctx,&ierr); 102 return 0; 103 } 104 105 /* 106 Note ctx is the same as ts so we need to get the Fortran context out of the TS 107 */ 108 static PetscErrorCode ourmonitor(TS ts,PetscInt i,PetscReal d,Vec v,void*ctx) 109 { 110 PetscErrorCode ierr = 0; 111 void *mctx = (void*) ((PetscObject)ts)->fortran_func_pointers[OUR_MONITOR_CTX]; 112 (*(void (PETSC_STDCALL *)(TS*,PetscInt*,PetscReal*,Vec*,void*,PetscErrorCode*))(((PetscObject)ts)->fortran_func_pointers[OUR_MONITOR]))(&ts,&i,&d,&v,mctx,&ierr); 113 return 0; 114 } 115 116 EXTERN_C_BEGIN 117 118 void PETSC_STDCALL tssetprestep_(TS *ts,PetscErrorCode (PETSC_STDCALL *f)(TS*,PetscErrorCode*),PetscErrorCode *ierr) 119 { 120 PetscObjectAllocateFortranPointers(*ts,OUR_COUNT); 121 ((PetscObject)*ts)->fortran_func_pointers[OUR_PRESTEP] = (PetscVoidFunction)f; 122 *ierr = TSSetPreStep(*ts,ourprestep); 123 } 124 125 void PETSC_STDCALL tssetpoststep_(TS *ts,PetscErrorCode (PETSC_STDCALL *f)(TS*,PetscErrorCode*),PetscErrorCode *ierr) 126 { 127 PetscObjectAllocateFortranPointers(*ts,OUR_COUNT); 128 ((PetscObject)*ts)->fortran_func_pointers[OUR_POSTSTEP] = (PetscVoidFunction)f; 129 *ierr = TSSetPreStep(*ts,ourpoststep); 130 } 131 132 void tscomputerhsfunctionlinear_(TS *ts,PetscReal *t,Vec *X,Vec *F,void *ctx,PetscErrorCode *ierr) 133 { 134 *ierr = TSComputeRHSFunctionLinear(*ts,*t,*X,*F,ctx); 135 } 136 void PETSC_STDCALL tssetrhsfunction_(TS *ts,Vec *r,PetscErrorCode (PETSC_STDCALL *f)(TS*,PetscReal*,Vec*,Vec*,void*,PetscErrorCode*),void*fP,PetscErrorCode *ierr) 137 { 138 Vec R; 139 CHKFORTRANNULLOBJECT(r); 140 CHKFORTRANNULLFUNCTION(f); 141 CHKFORTRANNULLOBJECT(fP); 142 R = r ? *r : (Vec)PETSC_NULL; 143 if ((PetscVoidFunction)f == (PetscVoidFunction)tscomputerhsfunctionlinear_) { 144 *ierr = TSSetRHSFunction(*ts,R,TSComputeRHSFunctionLinear,fP); 145 } else { 146 PetscObjectAllocateFortranPointers(*ts,OUR_COUNT); 147 ((PetscObject)*ts)->fortran_func_pointers[OUR_RHSFUNCTION] = (PetscVoidFunction)f; 148 *ierr = TSSetRHSFunction(*ts,R,ourrhsfunction,fP); 149 } 150 } 151 void PETSC_STDCALL tsgetrhsfunction_(TS *ts,Vec *r,void *func,void **ctx,PetscErrorCode *ierr) 152 { 153 CHKFORTRANNULLINTEGER(ctx); 154 CHKFORTRANNULLOBJECT(r); 155 *ierr = TSGetRHSFunction(*ts,r,PETSC_NULL,ctx); 156 } 157 158 void tscomputeifunctionlinear_(TS *ts,PetscReal *t,Vec *X,Vec *Xdot,Vec *F,void *ctx,PetscErrorCode *ierr) 159 { 160 *ierr = TSComputeIFunctionLinear(*ts,*t,*X,*Xdot,*F,ctx); 161 } 162 void PETSC_STDCALL tssetifunction_(TS *ts,Vec *r,PetscErrorCode (PETSC_STDCALL *f)(TS*,PetscReal*,Vec*,Vec*,Vec*,void*,PetscErrorCode*),void*fP,PetscErrorCode *ierr) 163 { 164 Vec R; 165 CHKFORTRANNULLOBJECT(r); 166 CHKFORTRANNULLFUNCTION(f); 167 CHKFORTRANNULLOBJECT(fP); 168 R = r ? *r : (Vec)PETSC_NULL; 169 if ((PetscVoidFunction)f == (PetscVoidFunction)tscomputeifunctionlinear_) { 170 *ierr = TSSetIFunction(*ts,R,TSComputeIFunctionLinear,fP); 171 } else { 172 PetscObjectAllocateFortranPointers(*ts,OUR_COUNT); 173 ((PetscObject)*ts)->fortran_func_pointers[OUR_IFUNCTION] = (PetscVoidFunction)f; 174 *ierr = TSSetIFunction(*ts,R,ourifunction,fP); 175 } 176 } 177 void PETSC_STDCALL tsgetifunction_(TS *ts,Vec *r,void *func,void **ctx,PetscErrorCode *ierr) 178 { 179 CHKFORTRANNULLINTEGER(ctx); 180 CHKFORTRANNULLOBJECT(r); 181 *ierr = TSGetIFunction(*ts,r,PETSC_NULL,ctx); 182 } 183 184 /* ---------------------------------------------------------*/ 185 void tscomputerhsjacobianconstant_(TS *ts,PetscReal *t,Vec *X,Mat *A,Mat *B,MatStructure *flg,void *ctx,PetscErrorCode *ierr) 186 { 187 *ierr = TSComputeRHSJacobianConstant(*ts,*t,*X,A,B,flg,ctx); 188 } 189 void PETSC_STDCALL tssetrhsjacobian_(TS *ts,Mat *A,Mat *B,void (PETSC_STDCALL *f)(TS*,PetscReal*,Vec*,Mat*,Mat*,MatStructure*, 190 void*,PetscErrorCode*),void*fP,PetscErrorCode *ierr) 191 { 192 PetscObjectAllocateFortranPointers(*ts,OUR_COUNT); 193 if (FORTRANNULLFUNCTION(f)) { 194 *ierr = TSSetRHSJacobian(*ts,*A,*B,PETSC_NULL,fP); 195 } else if ((PetscVoidFunction)f == (PetscVoidFunction)tscomputerhsjacobianconstant_) { 196 *ierr = TSSetRHSJacobian(*ts,*A,*B,TSComputeRHSJacobianConstant,fP); 197 } else { 198 ((PetscObject)*ts)->fortran_func_pointers[OUR_RHSJACOBIAN] = (PetscVoidFunction)f; 199 *ierr = TSSetRHSJacobian(*ts,*A,*B,ourrhsjacobian,fP); 200 } 201 } 202 203 void tscomputeijacobianconstant_(TS *ts,PetscReal *t,Vec *X,Vec *Xdot,PetscReal *shift,Mat *A,Mat *B,MatStructure *flg,void *ctx,PetscErrorCode *ierr) 204 { 205 *ierr = TSComputeIJacobianConstant(*ts,*t,*X,*Xdot,*shift,A,B,flg,ctx); 206 } 207 void PETSC_STDCALL tssetijacobian_(TS *ts,Mat *A,Mat *B,void (PETSC_STDCALL *f)(TS*,PetscReal*,Vec*,Mat*,Mat*,MatStructure*, 208 void*,PetscErrorCode*),void*fP,PetscErrorCode *ierr) 209 { 210 PetscObjectAllocateFortranPointers(*ts,OUR_COUNT); 211 if (FORTRANNULLFUNCTION(f)) { 212 *ierr = TSSetIJacobian(*ts,*A,*B,PETSC_NULL,fP); 213 } else if ((PetscVoidFunction)f == (PetscVoidFunction)tscomputeijacobianconstant_) { 214 *ierr = TSSetIJacobian(*ts,*A,*B,TSComputeIJacobianConstant,fP); 215 } else { 216 ((PetscObject)*ts)->fortran_func_pointers[OUR_IJACOBIAN] = (PetscVoidFunction)f; 217 *ierr = TSSetIJacobian(*ts,*A,*B,ourijacobian,fP); 218 } 219 } 220 void PETSC_STDCALL tsgetijacobian_(TS *ts,Mat *J,Mat *M,int *func,void **ctx,PetscErrorCode *ierr) 221 { 222 CHKFORTRANNULLINTEGER(ctx); 223 CHKFORTRANNULLOBJECT(J); 224 CHKFORTRANNULLOBJECT(M); 225 *ierr = TSGetIJacobian(*ts,J,M,0,ctx); 226 } 227 228 /* ---------------------------------------------------------*/ 229 230 extern void PETSC_STDCALL tsmonitordefault_(TS*,PetscInt*,PetscReal*,Vec*,void*,PetscErrorCode*); 231 232 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) 233 { 234 PetscObjectAllocateFortranPointers(*ts,OUR_COUNT); 235 if ((PetscVoidFunction)func == (PetscVoidFunction)tsmonitordefault_) { 236 *ierr = TSMonitorSet(*ts,TSMonitorDefault,0,0); 237 } else { 238 ((PetscObject)*ts)->fortran_func_pointers[OUR_MONITOR] = (PetscVoidFunction)func; 239 ((PetscObject)*ts)->fortran_func_pointers[OUR_MONITORDESTROY] = (PetscVoidFunction)d; 240 ((PetscObject)*ts)->fortran_func_pointers[OUR_MONITOR_CTX] = (PetscVoidFunction)mctx; 241 if (FORTRANNULLFUNCTION(d)) { 242 *ierr = TSMonitorSet(*ts,ourmonitor,*ts,0); 243 } else { 244 *ierr = TSMonitorSet(*ts,ourmonitor,*ts,ourmonitordestroy); 245 } 246 } 247 } 248 249 /* ---------------------------------------------------------*/ 250 /* func is currently ignored from Fortran */ 251 void PETSC_STDCALL tsgetrhsjacobian_(TS *ts,Mat *J,Mat *M,int *func,void **ctx,PetscErrorCode *ierr) 252 { 253 *ierr = TSGetRHSJacobian(*ts,J,M,0,ctx); 254 } 255 256 void PETSC_STDCALL tsview_(TS *ts,PetscViewer *viewer, PetscErrorCode *ierr) 257 { 258 PetscViewer v; 259 PetscPatchDefaultViewers_Fortran(viewer,v); 260 *ierr = TSView(*ts,v); 261 } 262 263 void PETSC_STDCALL tssetoptionsprefix_(TS *ts,CHAR prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 264 { 265 char *t; 266 FIXCHAR(prefix,len,t); 267 *ierr = TSSetOptionsPrefix(*ts,t); 268 FREECHAR(prefix,t); 269 } 270 void PETSC_STDCALL tsgetoptionsprefix_(TS *ts,CHAR prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 271 { 272 const char *tname; 273 274 *ierr = TSGetOptionsPrefix(*ts,&tname); 275 *ierr = PetscStrncpy(prefix,tname,len); 276 } 277 void PETSC_STDCALL tsappendoptionsprefix_(TS *ts,CHAR prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 278 { 279 char *t; 280 FIXCHAR(prefix,len,t); 281 *ierr = TSAppendOptionsPrefix(*ts,t); 282 FREECHAR(prefix,t); 283 } 284 285 286 EXTERN_C_END 287