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: }