1 #include <petsc/private/fortranimpl.h> 2 #include <petscts.h> 3 #include <petscviewer.h> 4 #include <petsc/private/f90impl.h> 5 6 #if defined(PETSC_HAVE_FORTRAN_CAPS) 7 #define tsmonitorlgsettransform_ TSMONITORLGSETTRANSFORM 8 #define tssetrhsfunction_ TSSETRHSFUNCTION 9 #define tsgetrhsfunction_ TSGETRHSFUNCTION 10 #define tssetrhsjacobian_ TSSETRHSJACOBIAN 11 #define tsgetrhsjacobian_ TSGETRHSJACOBIAN 12 #define tssetifunction_ TSSETIFUNCTION 13 #define tsgetifunction_ TSGETIFUNCTION 14 #define tssetijacobian_ TSSETIJACOBIAN 15 #define tsgetijacobian_ TSGETIJACOBIAN 16 #define tsview_ TSVIEW 17 #define tssetoptionsprefix_ TSSETOPTIONSPREFIX 18 #define tsgetoptionsprefix_ TSGETOPTIONSPREFIX 19 #define tsappendoptionsprefix_ TSAPPENDOPTIONSPREFIX 20 #define tsmonitorset_ TSMONITORSET 21 #define tscomputerhsfunctionlinear_ TSCOMPUTERHSFUNCTIONLINEAR 22 #define tscomputerhsjacobianconstant_ TSCOMPUTERHSJACOBIANCONSTANT 23 #define tscomputeifunctionlinear_ TSCOMPUTEIFUNCTIONLINEAR 24 #define tscomputeijacobianconstant_ TSCOMPUTEIJACOBIANCONSTANT 25 #define tsmonitordefault_ TSMONITORDEFAULT 26 #define tssetprestep_ TSSETPRESTEP 27 #define tssetpoststep_ TSSETPOSTSTEP 28 #define tsviewfromoptions_ TSVIEWFROMOPTIONS 29 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 30 #define tsmonitorlgsettransform_ tsmonitorlgsettransform 31 #define tssetrhsfunction_ tssetrhsfunction 32 #define tsgetrhsfunction_ tsgetrhsfunction 33 #define tssetrhsjacobian_ tssetrhsjacobian 34 #define tsgetrhsjacobian_ tsgetrhsjacobian 35 #define tssetifunction_ tssetifunction 36 #define tsgetifunction_ tsgetifunction 37 #define tssetijacobian_ tssetijacobian 38 #define tsgetijacobian_ tsgetijacobian 39 #define tsview_ tsview 40 #define tssetoptionsprefix_ tssetoptionsprefix 41 #define tsgetoptionsprefix_ tsgetoptionsprefix 42 #define tsappendoptionsprefix_ tsappendoptionsprefix 43 #define tsmonitorset_ tsmonitorset 44 #define tscomputerhsfunctionlinear_ tscomputerhsfunctionlinear 45 #define tscomputerhsjacobianconstant_ tscomputerhsjacobianconstant 46 #define tscomputeifunctionlinear_ tscomputeifunctionlinear 47 #define tscomputeijacobianconstant_ tscomputeijacobianconstant 48 #define tsmonitordefault_ tsmonitordefault 49 #define tssetprestep_ tssetprestep 50 #define tssetpoststep_ tssetpoststep 51 #define tsviewfromoptions_ tsviewfromoptions 52 #endif 53 54 static struct { 55 PetscFortranCallbackId prestep; 56 PetscFortranCallbackId poststep; 57 PetscFortranCallbackId rhsfunction; 58 PetscFortranCallbackId rhsjacobian; 59 PetscFortranCallbackId ifunction; 60 PetscFortranCallbackId ijacobian; 61 PetscFortranCallbackId monitor; 62 PetscFortranCallbackId mondestroy; 63 PetscFortranCallbackId transform; 64 #if defined(PETSC_HAVE_F90_2PTR_ARG) 65 PetscFortranCallbackId function_pgiptr; 66 #endif 67 } _cb; 68 69 static PetscErrorCode ourprestep(TS ts) 70 { 71 #if defined(PETSC_HAVE_F90_2PTR_ARG) && defined(foo) 72 void *ptr; 73 PetscCall(PetscObjectGetFortranCallback((PetscObject)ts, PETSC_FORTRAN_CALLBACK_CLASS, _cb.function_pgiptr, NULL, &ptr)); 74 #endif 75 PetscObjectUseFortranCallback(ts, _cb.prestep, (TS *, PetscErrorCode * /* PETSC_F90_2PTR_PROTO_NOVAR */), (&ts, &ierr /* PETSC_F90_2PTR_PARAM(ptr) */)); 76 } 77 static PetscErrorCode ourpoststep(TS ts) 78 { 79 #if defined(PETSC_HAVE_F90_2PTR_ARG) && defined(foo) 80 void *ptr; 81 PetscCall(PetscObjectGetFortranCallback((PetscObject)ts, PETSC_FORTRAN_CALLBACK_CLASS, _cb.function_pgiptr, NULL, &ptr)); 82 #endif 83 PetscObjectUseFortranCallback(ts, _cb.poststep, (TS *, PetscErrorCode * /* PETSC_F90_2PTR_PROTO_NOVAR */), (&ts, &ierr /* PETSC_F90_2PTR_PARAM(ptr) */)); 84 } 85 static PetscErrorCode ourrhsfunction(TS ts, PetscReal d, Vec x, Vec f, void *ctx) 86 { 87 #if defined(PETSC_HAVE_F90_2PTR_ARG) && defined(foo) 88 void *ptr; 89 PetscCall(PetscObjectGetFortranCallback((PetscObject)ts, PETSC_FORTRAN_CALLBACK_CLASS, _cb.function_pgiptr, NULL, &ptr)); 90 #endif 91 PetscObjectUseFortranCallback(ts, _cb.rhsfunction, (TS *, PetscReal *, Vec *, Vec *, void *, PetscErrorCode * /* PETSC_F90_2PTR_PROTO_NOVAR */), (&ts, &d, &x, &f, _ctx, &ierr /* PETSC_F90_2PTR_PARAM(ptr) */)); 92 } 93 static PetscErrorCode ourifunction(TS ts, PetscReal d, Vec x, Vec xdot, Vec f, void *ctx) 94 { 95 #if defined(PETSC_HAVE_F90_2PTR_ARG) && defined(foo) 96 void *ptr; 97 PetscCall(PetscObjectGetFortranCallback((PetscObject)ts, PETSC_FORTRAN_CALLBACK_CLASS, _cb.function_pgiptr, NULL, &ptr)); 98 #endif 99 PetscObjectUseFortranCallback(ts, _cb.ifunction, (TS *, PetscReal *, Vec *, Vec *, Vec *, void *, PetscErrorCode * /* PETSC_F90_2PTR_PROTO_NOVAR */), (&ts, &d, &x, &xdot, &f, _ctx, &ierr /* PETSC_F90_2PTR_PARAM(ptr) */)); 100 } 101 static PetscErrorCode ourrhsjacobian(TS ts, PetscReal d, Vec x, Mat m, Mat p, void *ctx) 102 { 103 #if defined(PETSC_HAVE_F90_2PTR_ARG) && defined(foo) 104 void *ptr; 105 PetscCall(PetscObjectGetFortranCallback((PetscObject)ts, PETSC_FORTRAN_CALLBACK_CLASS, _cb.function_pgiptr, NULL, &ptr)); 106 #endif 107 PetscObjectUseFortranCallback(ts, _cb.rhsjacobian, (TS *, PetscReal *, Vec *, Mat *, Mat *, void *, PetscErrorCode * /* PETSC_F90_2PTR_PROTO_NOVAR */), (&ts, &d, &x, &m, &p, _ctx, &ierr /* PETSC_F90_2PTR_PARAM(ptr) */)); 108 } 109 static PetscErrorCode ourijacobian(TS ts, PetscReal d, Vec x, Vec xdot, PetscReal shift, Mat m, Mat p, void *ctx) 110 { 111 #if defined(PETSC_HAVE_F90_2PTR_ARG) && defined(foo) 112 void *ptr; 113 PetscCall(PetscObjectGetFortranCallback((PetscObject)ts, PETSC_FORTRAN_CALLBACK_CLASS, _cb.function_pgiptr, NULL, &ptr)); 114 #endif 115 PetscObjectUseFortranCallback(ts, _cb.ijacobian, (TS *, PetscReal *, Vec *, Vec *, PetscReal *, Mat *, Mat *, void *, PetscErrorCode * /* PETSC_F90_2PTR_PROTO_NOVAR */), (&ts, &d, &x, &xdot, &shift, &m, &p, _ctx, &ierr /* PETSC_F90_2PTR_PARAM(ptr) */)); 116 } 117 118 static PetscErrorCode ourmonitordestroy(void **ctx) 119 { 120 TS ts = (TS)*ctx; 121 PetscObjectUseFortranCallback(ts, _cb.mondestroy, (void *, PetscErrorCode *), (_ctx, &ierr)); 122 } 123 124 /* 125 Note ctx is the same as ts so we need to get the Fortran context out of the TS 126 */ 127 static PetscErrorCode ourmonitor(TS ts, PetscInt i, PetscReal d, Vec v, void *ctx) 128 { 129 PetscObjectUseFortranCallback(ts, _cb.monitor, (TS *, PetscInt *, PetscReal *, Vec *, void *, PetscErrorCode *), (&ts, &i, &d, &v, _ctx, &ierr)); 130 } 131 132 /* 133 Currently does not handle destroy or context 134 */ 135 static PetscErrorCode ourtransform(void *ctx, Vec x, Vec *xout) 136 { 137 PetscObjectUseFortranCallback((TS)ctx, _cb.transform, (void *, Vec *, Vec *, PetscErrorCode *), (_ctx, &x, xout, &ierr)); 138 } 139 140 PETSC_EXTERN void tsmonitorlgsettransform_(TS *ts, void (*f)(void *, Vec *, Vec *, PetscErrorCode *), PetscErrorCode (*d)(void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 141 { 142 *ierr = TSMonitorLGSetTransform(*ts, ourtransform, NULL, NULL); 143 if (*ierr) return; 144 *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.transform, (PetscVoidFn *)f, ctx); 145 } 146 147 PETSC_EXTERN void tssetprestep_(TS *ts, PetscErrorCode (*f)(TS *, PetscErrorCode *), PetscErrorCode *ierr) 148 { 149 *ierr = TSSetPreStep(*ts, ourprestep); 150 if (*ierr) return; 151 *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.prestep, (PetscVoidFn *)f, NULL); 152 } 153 154 PETSC_EXTERN void tssetpoststep_(TS *ts, PetscErrorCode (*f)(TS *, PetscErrorCode *), PetscErrorCode *ierr) 155 { 156 *ierr = TSSetPostStep(*ts, ourpoststep); 157 if (*ierr) return; 158 *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.poststep, (PetscVoidFn *)f, NULL); 159 } 160 161 PETSC_EXTERN void tscomputerhsfunctionlinear_(TS *ts, PetscReal *t, Vec *X, Vec *F, void *ctx, PetscErrorCode *ierr) 162 { 163 *ierr = TSComputeRHSFunctionLinear(*ts, *t, *X, *F, ctx); 164 } 165 PETSC_EXTERN void tssetrhsfunction_(TS *ts, Vec *r, PetscErrorCode (*f)(TS *, PetscReal *, Vec *, Vec *, void *, PetscErrorCode *), void *fP, PetscErrorCode *ierr) 166 { 167 Vec R; 168 CHKFORTRANNULLOBJECT(r); 169 CHKFORTRANNULLFUNCTION(f); 170 R = r ? *r : (Vec)NULL; 171 if ((PetscVoidFn *)f == (PetscVoidFn *)tscomputerhsfunctionlinear_) { 172 *ierr = TSSetRHSFunction(*ts, R, TSComputeRHSFunctionLinear, fP); 173 } else { 174 *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.rhsfunction, (PetscVoidFn *)f, fP); 175 *ierr = TSSetRHSFunction(*ts, R, ourrhsfunction, NULL); 176 } 177 } 178 PETSC_EXTERN void tsgetrhsfunction_(TS *ts, Vec *r, void *func, void **ctx, PetscErrorCode *ierr) 179 { 180 CHKFORTRANNULLINTEGER(ctx); 181 CHKFORTRANNULLOBJECT(r); 182 *ierr = TSGetRHSFunction(*ts, r, NULL, ctx); 183 } 184 185 PETSC_EXTERN void tscomputeifunctionlinear_(TS *ts, PetscReal *t, Vec *X, Vec *Xdot, Vec *F, void *ctx, PetscErrorCode *ierr) 186 { 187 *ierr = TSComputeIFunctionLinear(*ts, *t, *X, *Xdot, *F, ctx); 188 } 189 PETSC_EXTERN void tssetifunction_(TS *ts, Vec *r, PetscErrorCode (*f)(TS *, PetscReal *, Vec *, Vec *, Vec *, void *, PetscErrorCode *), void *fP, PetscErrorCode *ierr) 190 { 191 Vec R; 192 CHKFORTRANNULLOBJECT(r); 193 CHKFORTRANNULLFUNCTION(f); 194 R = r ? *r : (Vec)NULL; 195 if ((PetscVoidFn *)f == (PetscVoidFn *)tscomputeifunctionlinear_) { 196 *ierr = TSSetIFunction(*ts, R, TSComputeIFunctionLinear, fP); 197 } else { 198 *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.ifunction, (PetscVoidFn *)f, fP); 199 *ierr = TSSetIFunction(*ts, R, ourifunction, NULL); 200 } 201 } 202 PETSC_EXTERN void tsgetifunction_(TS *ts, Vec *r, void *func, void **ctx, PetscErrorCode *ierr) 203 { 204 CHKFORTRANNULLINTEGER(ctx); 205 CHKFORTRANNULLOBJECT(r); 206 *ierr = TSGetIFunction(*ts, r, NULL, ctx); 207 } 208 209 /* ---------------------------------------------------------*/ 210 PETSC_EXTERN void tscomputerhsjacobianconstant_(TS *ts, PetscReal *t, Vec *X, Mat *A, Mat *B, void *ctx, PetscErrorCode *ierr) 211 { 212 *ierr = TSComputeRHSJacobianConstant(*ts, *t, *X, *A, *B, ctx); 213 } 214 PETSC_EXTERN void tssetrhsjacobian_(TS *ts, Mat *A, Mat *B, void (*f)(TS *, PetscReal *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *fP, PetscErrorCode *ierr) 215 { 216 CHKFORTRANNULLFUNCTION(f); 217 if ((PetscVoidFn *)f == (PetscVoidFn *)tscomputerhsjacobianconstant_) { 218 *ierr = TSSetRHSJacobian(*ts, *A, *B, TSComputeRHSJacobianConstant, fP); 219 } else { 220 *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.rhsjacobian, (PetscVoidFn *)f, fP); 221 *ierr = TSSetRHSJacobian(*ts, *A, *B, ourrhsjacobian, NULL); 222 } 223 } 224 225 PETSC_EXTERN void tscomputeijacobianconstant_(TS *ts, PetscReal *t, Vec *X, Vec *Xdot, PetscReal *shift, Mat *A, Mat *B, void *ctx, PetscErrorCode *ierr) 226 { 227 *ierr = TSComputeIJacobianConstant(*ts, *t, *X, *Xdot, *shift, *A, *B, ctx); 228 } 229 PETSC_EXTERN void tssetijacobian_(TS *ts, Mat *A, Mat *B, void (*f)(TS *, PetscReal *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *fP, PetscErrorCode *ierr) 230 { 231 CHKFORTRANNULLFUNCTION(f); 232 if ((PetscVoidFn *)f == (PetscVoidFn *)tscomputeijacobianconstant_) { 233 *ierr = TSSetIJacobian(*ts, *A, *B, TSComputeIJacobianConstant, fP); 234 } else { 235 *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.ijacobian, (PetscVoidFn *)f, fP); 236 *ierr = TSSetIJacobian(*ts, *A, *B, ourijacobian, NULL); 237 } 238 } 239 PETSC_EXTERN void tsgetijacobian_(TS *ts, Mat *J, Mat *M, int *func, void **ctx, PetscErrorCode *ierr) 240 { 241 CHKFORTRANNULLINTEGER(ctx); 242 CHKFORTRANNULLOBJECT(J); 243 CHKFORTRANNULLOBJECT(M); 244 *ierr = TSGetIJacobian(*ts, J, M, NULL, ctx); 245 } 246 247 PETSC_EXTERN void tsmonitordefault_(TS *ts, PetscInt *its, PetscReal *fgnorm, Vec *u, PetscViewerAndFormat **dummy, PetscErrorCode *ierr) 248 { 249 *ierr = TSMonitorDefault(*ts, *its, *fgnorm, *u, *dummy); 250 } 251 252 /* ---------------------------------------------------------*/ 253 254 /* PETSC_EXTERN void tsmonitordefault_(TS*,PetscInt*,PetscReal*,Vec*,void*,PetscErrorCode*); */ 255 256 PETSC_EXTERN void tsmonitorset_(TS *ts, void (*func)(TS *, PetscInt *, PetscReal *, Vec *, void *, PetscErrorCode *), void *mctx, void (*d)(void *, PetscErrorCode *), PetscErrorCode *ierr) 257 { 258 CHKFORTRANNULLFUNCTION(d); 259 if ((PetscVoidFn *)func == (PetscVoidFn *)tsmonitordefault_) { 260 *ierr = TSMonitorSet(*ts, (PetscErrorCode(*)(TS, PetscInt, PetscReal, Vec, void *))TSMonitorDefault, *(PetscViewerAndFormat **)mctx, (PetscErrorCode(*)(void **))PetscViewerAndFormatDestroy); 261 } else { 262 *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.monitor, (PetscVoidFn *)func, mctx); 263 *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.mondestroy, (PetscVoidFn *)d, mctx); 264 *ierr = TSMonitorSet(*ts, ourmonitor, *ts, ourmonitordestroy); 265 } 266 } 267 268 /* ---------------------------------------------------------*/ 269 /* func is currently ignored from Fortran */ 270 PETSC_EXTERN void tsgetrhsjacobian_(TS *ts, Mat *J, Mat *M, int *func, void **ctx, PetscErrorCode *ierr) 271 { 272 *ierr = TSGetRHSJacobian(*ts, J, M, NULL, ctx); 273 } 274 275 PETSC_EXTERN void tsview_(TS *ts, PetscViewer *viewer, PetscErrorCode *ierr) 276 { 277 PetscViewer v; 278 PetscPatchDefaultViewers_Fortran(viewer, v); 279 *ierr = TSView(*ts, v); 280 } 281 282 PETSC_EXTERN void tssetoptionsprefix_(TS *ts, char *prefix, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len) 283 { 284 char *t; 285 FIXCHAR(prefix, len, t); 286 *ierr = TSSetOptionsPrefix(*ts, t); 287 if (*ierr) return; 288 FREECHAR(prefix, t); 289 } 290 PETSC_EXTERN void tsgetoptionsprefix_(TS *ts, char *prefix, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len) 291 { 292 const char *tname; 293 294 *ierr = TSGetOptionsPrefix(*ts, &tname); 295 *ierr = PetscStrncpy(prefix, tname, len); 296 FIXRETURNCHAR(PETSC_TRUE, prefix, len); 297 } 298 PETSC_EXTERN void tsappendoptionsprefix_(TS *ts, char *prefix, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len) 299 { 300 char *t; 301 FIXCHAR(prefix, len, t); 302 *ierr = TSAppendOptionsPrefix(*ts, t); 303 if (*ierr) return; 304 FREECHAR(prefix, t); 305 } 306 307 PETSC_EXTERN void tsviewfromoptions_(TS *ao, PetscObject obj, char *type, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len) 308 { 309 char *t; 310 311 FIXCHAR(type, len, t); 312 CHKFORTRANNULLOBJECT(obj); 313 *ierr = TSViewFromOptions(*ao, obj, t); 314 if (*ierr) return; 315 FREECHAR(type, t); 316 } 317