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