Date: 2025-03-28T21:11:17+00:00

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