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