Date: 2025-03-29T05:58:49+00:00

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 tscomputerhsfunctionlinear_   TSCOMPUTERHSFUNCTIONLINEAR
     17:   #define tscomputerhsjacobianconstant_ TSCOMPUTERHSJACOBIANCONSTANT
     18:   #define tscomputeifunctionlinear_     TSCOMPUTEIFUNCTIONLINEAR
     19:   #define tscomputeijacobianconstant_   TSCOMPUTEIJACOBIANCONSTANT
     20:   #define tsmonitordefault_             TSMONITORDEFAULT
     21:   #define tssetprestep_                 TSSETPRESTEP
     22:   #define tssetpoststep_                TSSETPOSTSTEP
     23: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
     24:   #define tsmonitorlgsettransform_      tsmonitorlgsettransform
     25:   #define tssetrhsfunction_             tssetrhsfunction
     26:   #define tsgetrhsfunction_             tsgetrhsfunction
     27:   #define tssetrhsjacobian_             tssetrhsjacobian
     28:   #define tsgetrhsjacobian_             tsgetrhsjacobian
     29:   #define tssetifunction_               tssetifunction
     30:   #define tsgetifunction_               tsgetifunction
     31:   #define tssetijacobian_               tssetijacobian
     32:   #define tsgetijacobian_               tsgetijacobian
     33:   #define tsmonitorset_                 tsmonitorset
     34:   #define tscomputerhsfunctionlinear_   tscomputerhsfunctionlinear
     35:   #define tscomputerhsjacobianconstant_ tscomputerhsjacobianconstant
     36:   #define tscomputeifunctionlinear_     tscomputeifunctionlinear
     37:   #define tscomputeijacobianconstant_   tscomputeijacobianconstant
     38:   #define tsmonitordefault_             tsmonitordefault
     39:   #define tssetprestep_                 tssetprestep
     40:   #define tssetpoststep_                tssetpoststep
     41: #endif

     43: static struct {
     44:   PetscFortranCallbackId prestep;
     45:   PetscFortranCallbackId poststep;
     46:   PetscFortranCallbackId rhsfunction;
     47:   PetscFortranCallbackId rhsjacobian;
     48:   PetscFortranCallbackId ifunction;
     49:   PetscFortranCallbackId ijacobian;
     50:   PetscFortranCallbackId monitor;
     51:   PetscFortranCallbackId mondestroy;
     52:   PetscFortranCallbackId transform;
     53: #if defined(PETSC_HAVE_F90_2PTR_ARG)
     54:   PetscFortranCallbackId function_pgiptr;
     55: #endif
     56: } _cb;

     58: static PetscErrorCode ourprestep(TS ts)
     59: {
     60: #if defined(PETSC_HAVE_F90_2PTR_ARG) && defined(foo)
     61:   void *ptr;
     62:   PetscCall(PetscObjectGetFortranCallback((PetscObject)ts, PETSC_FORTRAN_CALLBACK_CLASS, _cb.function_pgiptr, NULL, &ptr));
     63: #endif
     64:   PetscObjectUseFortranCallback(ts, _cb.prestep, (TS *, PetscErrorCode * /* PETSC_F90_2PTR_PROTO_NOVAR */), (&ts, &ierr /* PETSC_F90_2PTR_PARAM(ptr) */));
     65: }
     66: static PetscErrorCode ourpoststep(TS ts)
     67: {
     68: #if defined(PETSC_HAVE_F90_2PTR_ARG) && defined(foo)
     69:   void *ptr;
     70:   PetscCall(PetscObjectGetFortranCallback((PetscObject)ts, PETSC_FORTRAN_CALLBACK_CLASS, _cb.function_pgiptr, NULL, &ptr));
     71: #endif
     72:   PetscObjectUseFortranCallback(ts, _cb.poststep, (TS *, PetscErrorCode * /* PETSC_F90_2PTR_PROTO_NOVAR */), (&ts, &ierr /* PETSC_F90_2PTR_PARAM(ptr) */));
     73: }
     74: static PetscErrorCode ourrhsfunction(TS ts, PetscReal d, Vec x, Vec f, void *ctx)
     75: {
     76: #if defined(PETSC_HAVE_F90_2PTR_ARG) && defined(foo)
     77:   void *ptr;
     78:   PetscCall(PetscObjectGetFortranCallback((PetscObject)ts, PETSC_FORTRAN_CALLBACK_CLASS, _cb.function_pgiptr, NULL, &ptr));
     79: #endif
     80:   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) */));
     81: }
     82: static PetscErrorCode ourifunction(TS ts, PetscReal d, Vec x, Vec xdot, Vec f, void *ctx)
     83: {
     84: #if defined(PETSC_HAVE_F90_2PTR_ARG) && defined(foo)
     85:   void *ptr;
     86:   PetscCall(PetscObjectGetFortranCallback((PetscObject)ts, PETSC_FORTRAN_CALLBACK_CLASS, _cb.function_pgiptr, NULL, &ptr));
     87: #endif
     88:   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) */));
     89: }
     90: static PetscErrorCode ourrhsjacobian(TS ts, PetscReal d, Vec x, Mat m, Mat p, void *ctx)
     91: {
     92: #if defined(PETSC_HAVE_F90_2PTR_ARG) && defined(foo)
     93:   void *ptr;
     94:   PetscCall(PetscObjectGetFortranCallback((PetscObject)ts, PETSC_FORTRAN_CALLBACK_CLASS, _cb.function_pgiptr, NULL, &ptr));
     95: #endif
     96:   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) */));
     97: }
     98: static PetscErrorCode ourijacobian(TS ts, PetscReal d, Vec x, Vec xdot, PetscReal shift, Mat m, Mat p, void *ctx)
     99: {
    100: #if defined(PETSC_HAVE_F90_2PTR_ARG) && defined(foo)
    101:   void *ptr;
    102:   PetscCall(PetscObjectGetFortranCallback((PetscObject)ts, PETSC_FORTRAN_CALLBACK_CLASS, _cb.function_pgiptr, NULL, &ptr));
    103: #endif
    104:   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) */));
    105: }

    107: static PetscErrorCode ourmonitordestroy(void **ctx)
    108: {
    109:   TS ts = (TS)*ctx;
    110:   PetscObjectUseFortranCallback(ts, _cb.mondestroy, (void *, PetscErrorCode *), (_ctx, &ierr));
    111: }

    113: /*
    114:    Note ctx is the same as ts so we need to get the Fortran context out of the TS
    115: */
    116: static PetscErrorCode ourmonitor(TS ts, PetscInt i, PetscReal d, Vec v, void *ctx)
    117: {
    118:   PetscObjectUseFortranCallback(ts, _cb.monitor, (TS *, PetscInt *, PetscReal *, Vec *, void *, PetscErrorCode *), (&ts, &i, &d, &v, _ctx, &ierr));
    119: }

    121: /*
    122:    Currently does not handle destroy or context
    123: */
    124: static PetscErrorCode ourtransform(void *ctx, Vec x, Vec *xout)
    125: {
    126:   PetscObjectUseFortranCallback((TS)ctx, _cb.transform, (void *, Vec *, Vec *, PetscErrorCode *), (_ctx, &x, xout, &ierr));
    127: }

    129: PETSC_EXTERN void tsmonitorlgsettransform_(TS *ts, void (*f)(void *, Vec *, Vec *, PetscErrorCode *), PetscErrorCode (*d)(void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    130: {
    131:   *ierr = TSMonitorLGSetTransform(*ts, ourtransform, NULL, NULL);
    132:   if (*ierr) return;
    133:   *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.transform, (PetscVoidFn *)f, ctx);
    134: }

    136: PETSC_EXTERN void tssetprestep_(TS *ts, PetscErrorCode (*f)(TS *, PetscErrorCode *), PetscErrorCode *ierr)
    137: {
    138:   *ierr = TSSetPreStep(*ts, ourprestep);
    139:   if (*ierr) return;
    140:   *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.prestep, (PetscVoidFn *)f, NULL);
    141: }

    143: PETSC_EXTERN void tssetpoststep_(TS *ts, PetscErrorCode (*f)(TS *, PetscErrorCode *), PetscErrorCode *ierr)
    144: {
    145:   *ierr = TSSetPostStep(*ts, ourpoststep);
    146:   if (*ierr) return;
    147:   *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.poststep, (PetscVoidFn *)f, NULL);
    148: }

    150: PETSC_EXTERN void tscomputerhsfunctionlinear_(TS *ts, PetscReal *t, Vec *X, Vec *F, void *ctx, PetscErrorCode *ierr)
    151: {
    152:   *ierr = TSComputeRHSFunctionLinear(*ts, *t, *X, *F, ctx);
    153: }
    154: PETSC_EXTERN void tssetrhsfunction_(TS *ts, Vec *r, PetscErrorCode (*f)(TS *, PetscReal *, Vec *, Vec *, void *, PetscErrorCode *), void *fP, PetscErrorCode *ierr)
    155: {
    156:   Vec R;
    157:   CHKFORTRANNULLOBJECT(r);
    158:   CHKFORTRANNULLFUNCTION(f);
    159:   R = r ? *r : (Vec)NULL;
    160:   if ((PetscVoidFn *)f == (PetscVoidFn *)tscomputerhsfunctionlinear_) {
    161:     *ierr = TSSetRHSFunction(*ts, R, TSComputeRHSFunctionLinear, fP);
    162:   } else {
    163:     *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.rhsfunction, (PetscVoidFn *)f, fP);
    164:     *ierr = TSSetRHSFunction(*ts, R, ourrhsfunction, NULL);
    165:   }
    166: }
    167: PETSC_EXTERN void tsgetrhsfunction_(TS *ts, Vec *r, void *func, void **ctx, PetscErrorCode *ierr)
    168: {
    169:   CHKFORTRANNULLINTEGER(ctx);
    170:   CHKFORTRANNULLOBJECT(r);
    171:   *ierr = TSGetRHSFunction(*ts, r, NULL, ctx);
    172: }

    174: PETSC_EXTERN void tscomputeifunctionlinear_(TS *ts, PetscReal *t, Vec *X, Vec *Xdot, Vec *F, void *ctx, PetscErrorCode *ierr);

    176: PETSC_EXTERN void tssetifunction_(TS *ts, Vec *r, PetscErrorCode (*f)(TS *, PetscReal *, Vec *, Vec *, Vec *, void *, PetscErrorCode *), void *fP, PetscErrorCode *ierr)
    177: {
    178:   Vec R;
    179:   CHKFORTRANNULLOBJECT(r);
    180:   CHKFORTRANNULLFUNCTION(f);
    181:   R = r ? *r : (Vec)NULL;
    182:   if ((PetscVoidFn *)f == (PetscVoidFn *)tscomputeifunctionlinear_) {
    183:     *ierr = TSSetIFunction(*ts, R, TSComputeIFunctionLinear, fP);
    184:   } else {
    185:     *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.ifunction, (PetscVoidFn *)f, fP);
    186:     *ierr = TSSetIFunction(*ts, R, ourifunction, NULL);
    187:   }
    188: }
    189: PETSC_EXTERN void tsgetifunction_(TS *ts, Vec *r, void *func, void **ctx, PetscErrorCode *ierr)
    190: {
    191:   CHKFORTRANNULLINTEGER(ctx);
    192:   CHKFORTRANNULLOBJECT(r);
    193:   *ierr = TSGetIFunction(*ts, r, NULL, ctx);
    194: }

    196: /* ---------------------------------------------------------*/
    197: PETSC_EXTERN void tscomputerhsjacobianconstant_(TS *ts, PetscReal *t, Vec *X, Mat *A, Mat *B, void *ctx, PetscErrorCode *ierr)
    198: {
    199:   *ierr = TSComputeRHSJacobianConstant(*ts, *t, *X, *A, *B, ctx);
    200: }
    201: PETSC_EXTERN void tssetrhsjacobian_(TS *ts, Mat *A, Mat *B, void (*f)(TS *, PetscReal *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *fP, PetscErrorCode *ierr)
    202: {
    203:   CHKFORTRANNULLFUNCTION(f);
    204:   if ((PetscVoidFn *)f == (PetscVoidFn *)tscomputerhsjacobianconstant_) {
    205:     *ierr = TSSetRHSJacobian(*ts, *A, *B, TSComputeRHSJacobianConstant, fP);
    206:   } else {
    207:     *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.rhsjacobian, (PetscVoidFn *)f, fP);
    208:     *ierr = TSSetRHSJacobian(*ts, *A, *B, ourrhsjacobian, NULL);
    209:   }
    210: }

    212: PETSC_EXTERN void tscomputeijacobianconstant_(TS *ts, PetscReal *t, Vec *X, Vec *Xdot, PetscReal *shift, Mat *A, Mat *B, void *ctx, PetscErrorCode *ierr);

    214: PETSC_EXTERN void tssetijacobian_(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 *)tscomputeijacobianconstant_) {
    218:     *ierr = TSSetIJacobian(*ts, *A, *B, TSComputeIJacobianConstant, fP);
    219:   } else {
    220:     *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.ijacobian, (PetscVoidFn *)f, fP);
    221:     *ierr = TSSetIJacobian(*ts, *A, *B, ourijacobian, NULL);
    222:   }
    223: }
    224: PETSC_EXTERN void tsgetijacobian_(TS *ts, Mat *J, Mat *M, int *func, void **ctx, PetscErrorCode *ierr)
    225: {
    226:   CHKFORTRANNULLINTEGER(ctx);
    227:   CHKFORTRANNULLOBJECT(J);
    228:   CHKFORTRANNULLOBJECT(M);
    229:   *ierr = TSGetIJacobian(*ts, J, M, NULL, ctx);
    230: }

    232: PETSC_EXTERN void tsmonitordefault_(TS *, PetscInt *, PetscReal *, Vec *, PetscViewerAndFormat **, PetscErrorCode *);

    234: /* ---------------------------------------------------------*/

    236: /* PETSC_EXTERN void tsmonitordefault_(TS*,PetscInt*,PetscReal*,Vec*,void*,PetscErrorCode*); */

    238: PETSC_EXTERN void tsmonitorset_(TS *ts, void (*func)(TS *, PetscInt *, PetscReal *, Vec *, void *, PetscErrorCode *), void *mctx, void (*d)(void *, PetscErrorCode *), PetscErrorCode *ierr)
    239: {
    240:   CHKFORTRANNULLFUNCTION(d);
    241:   if ((PetscVoidFn *)func == (PetscVoidFn *)tsmonitordefault_) {
    242:     *ierr = TSMonitorSet(*ts, (PetscErrorCode (*)(TS, PetscInt, PetscReal, Vec, void *))TSMonitorDefault, *(PetscViewerAndFormat **)mctx, (PetscCtxDestroyFn *)PetscViewerAndFormatDestroy);
    243:   } else {
    244:     *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.monitor, (PetscVoidFn *)func, mctx);
    245:     *ierr = PetscObjectSetFortranCallback((PetscObject)*ts, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.mondestroy, (PetscVoidFn *)d, mctx);
    246:     *ierr = TSMonitorSet(*ts, ourmonitor, *ts, ourmonitordestroy);
    247:   }
    248: }

    250: /* ---------------------------------------------------------*/
    251: /*  func is currently ignored from Fortran */
    252: PETSC_EXTERN void tsgetrhsjacobian_(TS *ts, Mat *J, Mat *M, int *func, void **ctx, PetscErrorCode *ierr)
    253: {
    254:   *ierr = TSGetRHSJacobian(*ts, J, M, NULL, ctx);
    255: }