Actual source code: ztsf.c
1: #include <petsc/private/ftnimpl.h>
2: #include <petscts.h>
3: #include <petscviewer.h>
5: #if PetscDefined(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 !PetscDefined(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 PetscDefined(HAVE_F90_2PTR_ARG)
64: PetscFortranCallbackId function_pgiptr;
65: #endif
66: } _cb;
68: static PetscErrorCode ourprestep(TS ts)
69: {
70: #if PetscDefined(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 PetscDefined(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 PetscDefined(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 PetscDefined(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 PetscDefined(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 PetscDefined(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 PetscDefined(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 PetscDefined(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 (*transform)(void *, Vec *, Vec *, PetscErrorCode *), PetscErrorCode (*destroy)(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 *)transform, ctx);
160: }
162: PETSC_EXTERN void tssetprestep_(TS *ts, PetscErrorCode (*func)(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 *)func, NULL);
167: }
169: PETSC_EXTERN void tssetpoststep_(TS *ts, PetscErrorCode (*func)(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 *)func, 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: if (*ierr) return;
189: *ierr = TSSetRHSFunction(*ts, R, ourrhsfunction, NULL);
190: }
191: }
192: PETSC_EXTERN void tsgetrhsfunction_(TS *ts, Vec *r, void *func, void **ctx, PetscErrorCode *ierr)
193: {
194: CHKFORTRANNULLINTEGER(ctx);
195: CHKFORTRANNULLOBJECT(r);
196: *ierr = TSGetRHSFunction(*ts, r, NULL, ctx);
197: }
199: PETSC_EXTERN void tscomputeifunctionlinear_(TS *ts, PetscReal *t, Vec *X, Vec *Xdot, Vec *F, PetscCtx ctx, PetscErrorCode *ierr);
201: PETSC_EXTERN void tssetifunction_(TS *ts, Vec *r, void (*f)(TS *, PetscReal *, Vec *, Vec *, Vec *, void *, PetscErrorCode *), void *fP, PetscErrorCode *ierr)
202: {
203: Vec R;
204: CHKFORTRANNULLOBJECT(r);
205: CHKFORTRANNULLFUNCTION(f);
206: R = r ? *r : (Vec)NULL;
207: if (f == tscomputeifunctionlinear_) {
208: *ierr = TSSetIFunction(*ts, R, TSComputeIFunctionLinear, fP);
209: } else {
210: *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.ifunction, (PetscFortranCallbackFn *)f, fP);
211: if (*ierr) return;
212: *ierr = TSSetIFunction(*ts, R, ourifunction, NULL);
213: }
214: }
215: PETSC_EXTERN void tsgetifunction_(TS *ts, Vec *r, void *func, void **ctx, PetscErrorCode *ierr)
216: {
217: CHKFORTRANNULLINTEGER(ctx);
218: CHKFORTRANNULLOBJECT(r);
219: *ierr = TSGetIFunction(*ts, r, NULL, ctx);
220: }
222: PETSC_EXTERN void tscomputerhsjacobianconstant_(TS *, PetscReal *, Vec *, Mat *, Mat *, void *, PetscErrorCode *);
224: PETSC_EXTERN void tssetrhsjacobian_(TS *ts, Mat *Amat, Mat *Pmat, void (*f)(TS *, PetscReal *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *fP, PetscErrorCode *ierr)
225: {
226: CHKFORTRANNULLFUNCTION(f);
227: if (f == tscomputerhsjacobianconstant_) {
228: *ierr = TSSetRHSJacobian(*ts, *Amat, *Pmat, TSComputeRHSJacobianConstant, fP);
229: } else {
230: *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.rhsjacobian, (PetscFortranCallbackFn *)f, fP);
231: if (*ierr) return;
232: *ierr = TSSetRHSJacobian(*ts, *Amat, *Pmat, ourrhsjacobian, NULL);
233: }
234: }
236: PETSC_EXTERN void tscomputeijacobianconstant_(TS *ts, PetscReal *t, Vec *X, Vec *Xdot, PetscReal *shift, Mat *A, Mat *B, PetscCtx ctx, PetscErrorCode *ierr);
238: PETSC_EXTERN void tssetijacobian_(TS *ts, Mat *Amat, Mat *Pmat, void (*f)(TS *, PetscReal *, Vec *, Vec *, PetscReal *, Mat *, Mat *, void *, PetscErrorCode *), void *fP, PetscErrorCode *ierr)
239: {
240: CHKFORTRANNULLFUNCTION(f);
241: if (f == tscomputeijacobianconstant_) {
242: *ierr = TSSetIJacobian(*ts, *Amat, *Pmat, TSComputeIJacobianConstant, fP);
243: } else {
244: *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.ijacobian, (PetscFortranCallbackFn *)f, fP);
245: if (*ierr) return;
246: *ierr = TSSetIJacobian(*ts, *Amat, *Pmat, ourijacobian, NULL);
247: }
248: }
249: PETSC_EXTERN void tsgetijacobian_(TS *ts, Mat *Amat, Mat *Pmat, int *func, void **ctx, PetscErrorCode *ierr)
250: {
251: CHKFORTRANNULLINTEGER(ctx);
252: CHKFORTRANNULLOBJECT(Amat);
253: CHKFORTRANNULLOBJECT(Pmat);
254: *ierr = TSGetIJacobian(*ts, Amat, Pmat, NULL, ctx);
255: }
256: PETSC_EXTERN void tssetijacobianp_(TS *ts, Mat *Amat, void (*f)(TS *, PetscReal *, Vec *, Vec *, PetscReal *, Mat *, void *, PetscErrorCode *), void *fP, PetscErrorCode *ierr)
257: {
258: CHKFORTRANNULLFUNCTION(f);
259: if (f) {
260: *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.ijacobianp, (PetscFortranCallbackFn *)f, fP);
261: if (*ierr) return;
262: *ierr = TSSetIJacobianP(*ts, *Amat, ourijacobianp, NULL);
263: } else *ierr = TSSetIJacobianP(*ts, *Amat, NULL, NULL);
264: }
265: PETSC_EXTERN void tsgetijacobianp_(TS *ts, Mat *Amat, int *func, void **ctx, PetscErrorCode *ierr)
266: {
267: CHKFORTRANNULLINTEGER(ctx);
268: CHKFORTRANNULLOBJECT(Amat);
269: *ierr = TSGetIJacobianP(*ts, Amat, NULL, ctx);
270: }
271: PETSC_EXTERN void tssetrhsjacobianp_(TS *ts, Mat *Amat, void (*f)(TS *, PetscReal *, Vec *, Mat *, void *, PetscErrorCode *), void *fP, PetscErrorCode *ierr)
272: {
273: CHKFORTRANNULLFUNCTION(f);
274: if (f) {
275: *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.rhsjacobianp, (PetscFortranCallbackFn *)f, fP);
276: if (*ierr) return;
277: *ierr = TSSetRHSJacobianP(*ts, *Amat, ourrhsjacobianp, NULL);
278: } else *ierr = TSSetRHSJacobianP(*ts, *Amat, NULL, NULL);
279: }
280: PETSC_EXTERN void tsgetrhsjacobianp_(TS *ts, Mat *Amat, int *func, void **ctx, PetscErrorCode *ierr)
281: {
282: CHKFORTRANNULLINTEGER(ctx);
283: CHKFORTRANNULLOBJECT(Amat);
284: *ierr = TSGetRHSJacobianP(*ts, Amat, NULL, ctx);
285: }
287: PETSC_EXTERN void tsmonitordefault_(TS *, PetscInt *, PetscReal *, Vec *, PetscViewerAndFormat **, PetscErrorCode *);
289: /* PETSC_EXTERN void tsmonitordefault_(TS*,PetscInt*,PetscReal*,Vec*,void*,PetscErrorCode*); */
291: PETSC_EXTERN void tsmonitorset_(TS *ts, void (*func)(TS *, PetscInt *, PetscReal *, Vec *, void *, PetscErrorCode *), void *mctx, void (*mdestroy)(void *, PetscErrorCode *), PetscErrorCode *ierr)
292: {
293: CHKFORTRANNULLFUNCTION(mdestroy);
294: if ((PetscFortranCallbackFn *)func == (PetscFortranCallbackFn *)tsmonitordefault_) {
295: *ierr = TSMonitorSet(*ts, (PetscErrorCode (*)(TS, PetscInt, PetscReal, Vec, void *))TSMonitorDefault, *(PetscViewerAndFormat **)mctx, (PetscCtxDestroyFn *)PetscViewerAndFormatDestroy);
296: } else {
297: *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.monitor, (PetscFortranCallbackFn *)func, mctx);
298: if (*ierr) return;
299: *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.mondestroy, (PetscFortranCallbackFn *)mdestroy, mctx);
300: if (*ierr) return;
301: *ierr = TSMonitorSet(*ts, ourmonitor, *ts, ourmonitordestroy);
302: }
303: }
305: /* func is currently ignored from Fortran */
306: PETSC_EXTERN void tsgetrhsjacobian_(TS *ts, Mat *Amat, Mat *Pmat, int *func, void **ctx, PetscErrorCode *ierr)
307: {
308: *ierr = TSGetRHSJacobian(*ts, Amat, Pmat, NULL, ctx);
309: }