Actual source code: ztsf.c
1: #include <petsc/private/fortranimpl.h>
2: #include <petscts.h>
3: #include <petscviewer.h>
4: #include <petsc/private/f90impl.h>
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
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;
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: }
118: static PetscErrorCode ourmonitordestroy(void **ctx)
119: {
120: TS ts = (TS)*ctx;
121: PetscObjectUseFortranCallback(ts, _cb.mondestroy, (void *, PetscErrorCode *), (_ctx, &ierr));
122: }
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: }
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: }
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: }
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: }
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: }
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: }
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: }
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: }
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: }
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: }
252: /* ---------------------------------------------------------*/
254: /* PETSC_EXTERN void tsmonitordefault_(TS*,PetscInt*,PetscReal*,Vec*,void*,PetscErrorCode*); */
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: }
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: }
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: }
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;
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: }
307: PETSC_EXTERN void tsviewfromoptions_(TS *ao, PetscObject obj, char *type, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len)
308: {
309: char *t;
311: FIXCHAR(type, len, t);
312: CHKFORTRANNULLOBJECT(obj);
313: *ierr = TSViewFromOptions(*ao, obj, t);
314: if (*ierr) return;
315: FREECHAR(type, t);
316: }