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