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

Actual source code: ztaosolverf.c

      1: #include <petsc/private/fortranimpl.h>
      2: #include <petsc/private/f90impl.h>
      3: #include <petsc/private/taoimpl.h>

      5: #if defined(PETSC_HAVE_FORTRAN_CAPS)
      6:   #define taosetobjective_                    TAOSETOBJECTIVE
      7:   #define taosetgradient_                     TAOSETGRADIENT
      8:   #define taosetobjectiveandgradient_         TAOSETOBJECTIVEANDGRADIENT
      9:   #define taosethessian_                      TAOSETHESSIAN
     10:   #define taosetresidualroutine_              TAOSETRESIDUALROUTINE
     11:   #define taosetjacobianresidualroutine_      TAOSETJACOBIANRESIDUALROUTINE
     12:   #define taosetjacobianroutine_              TAOSETJACOBIANROUTINE
     13:   #define taosetjacobianstateroutine_         TAOSETJACOBIANSTATEROUTINE
     14:   #define taosetjacobiandesignroutine_        TAOSETJACOBIANDESIGNROUTINE
     15:   #define taosetjacobianinequalityroutine_    TAOSETJACOBIANINEQUALITYROUTINE
     16:   #define taosetjacobianequalityroutine_      TAOSETJACOBIANEQUALITYROUTINE
     17:   #define taosetinequalityconstraintsroutine_ TAOSETINEQUALITYCONSTRAINTSROUTINE
     18:   #define taosetequalityconstraintsroutine_   TAOSETEQUALITYCONSTRAINTSROUTINE
     19:   #define taosetvariableboundsroutine_        TAOSETVARIABLEBOUNDSROUTINE
     20:   #define taosetconstraintsroutine_           TAOSETCONSTRAINTSROUTINE
     21:   #define taomonitorset_                      TAOMONITORSET
     22:   #define taogetconvergencehistory_           TAOGETCONVERGENCEHISTORY
     23:   #define taosetconvergencetest_              TAOSETCONVERGENCETEST
     24:   #define taosetupdate_                       TAOSETUPDATE
     25: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
     26:   #define taosetobjective_                    taosetobjective
     27:   #define taosetgradient_                     taosetgradient
     28:   #define taosetobjectiveandgradient_         taosetobjectiveandgradient
     29:   #define taosethessian_                      taosethessian
     30:   #define taosetresidualroutine_              taosetresidualroutine
     31:   #define taosetjacobianresidualroutine_      taosetjacobianresidualroutine
     32:   #define taosetjacobianroutine_              taosetjacobianroutine
     33:   #define taosetjacobianstateroutine_         taosetjacobianstateroutine
     34:   #define taosetjacobiandesignroutine_        taosetjacobiandesignroutine
     35:   #define taosetjacobianinequalityroutine_    taosetjacobianinequalityroutine
     36:   #define taosetjacobianequalityroutine_      taosetjacobianequalityroutine
     37:   #define taosetinequalityconstraintsroutine_ taosetinequalityconstraintsroutine
     38:   #define taosetequalityconstraintsroutine_   taosetequalityconstraintsroutine
     39:   #define taosetvariableboundsroutine_        taosetvariableboundsroutine
     40:   #define taosetconstraintsroutine_           taosetconstraintsroutine
     41:   #define taomonitorset_                      taomonitorset
     42:   #define taogetconvergencehistory_           taogetconvergencehistory
     43:   #define taosetconvergencetest_              taosetconvergencetest
     44:   #define taosetupdate_                       taosetupdate
     45: #endif

     47: static struct {
     48:   PetscFortranCallbackId obj;
     49:   PetscFortranCallbackId grad;
     50:   PetscFortranCallbackId objgrad;
     51:   PetscFortranCallbackId hess;
     52:   PetscFortranCallbackId lsres;
     53:   PetscFortranCallbackId lsjac;
     54:   PetscFortranCallbackId jac;
     55:   PetscFortranCallbackId jacstate;
     56:   PetscFortranCallbackId jacdesign;
     57:   PetscFortranCallbackId bounds;
     58:   PetscFortranCallbackId mon;
     59:   PetscFortranCallbackId mondestroy;
     60:   PetscFortranCallbackId convtest;
     61:   PetscFortranCallbackId constraints;
     62:   PetscFortranCallbackId jacineq;
     63:   PetscFortranCallbackId jaceq;
     64:   PetscFortranCallbackId conineq;
     65:   PetscFortranCallbackId coneq;
     66:   PetscFortranCallbackId nfuncs;
     67:   PetscFortranCallbackId update;
     68: #if defined(PETSC_HAVE_F90_2PTR_ARG)
     69:   PetscFortranCallbackId function_pgiptr;
     70: #endif
     71: } _cb;

     73: static PetscErrorCode ourtaoobjectiveroutine(Tao tao, Vec x, PetscReal *f, void *ctx)
     74: {
     75:   PetscObjectUseFortranCallback(tao, _cb.obj, (Tao *, Vec *, PetscReal *, void *, PetscErrorCode *), (&tao, &x, f, _ctx, &ierr));
     76: }

     78: static PetscErrorCode ourtaogradientroutine(Tao tao, Vec x, Vec g, void *ctx)
     79: {
     80:   PetscObjectUseFortranCallback(tao, _cb.grad, (Tao *, Vec *, Vec *, void *, PetscErrorCode *), (&tao, &x, &g, _ctx, &ierr));
     81: }

     83: static PetscErrorCode ourtaoobjectiveandgradientroutine(Tao tao, Vec x, PetscReal *f, Vec g, void *ctx)
     84: {
     85:   PetscObjectUseFortranCallback(tao, _cb.objgrad, (Tao *, Vec *, PetscReal *, Vec *, void *, PetscErrorCode *), (&tao, &x, f, &g, _ctx, &ierr));
     86: }

     88: static PetscErrorCode ourtaohessianroutine(Tao tao, Vec x, Mat H, Mat Hpre, void *ctx)
     89: {
     90:   PetscObjectUseFortranCallback(tao, _cb.hess, (Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), (&tao, &x, &H, &Hpre, _ctx, &ierr));
     91: }

     93: static PetscErrorCode ourtaojacobianroutine(Tao tao, Vec x, Mat H, Mat Hpre, void *ctx)
     94: {
     95:   PetscObjectUseFortranCallback(tao, _cb.jac, (Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), (&tao, &x, &H, &Hpre, _ctx, &ierr));
     96: }

     98: static PetscErrorCode ourtaojacobianstateroutine(Tao tao, Vec x, Mat H, Mat Hpre, Mat Hinv, void *ctx)
     99: {
    100:   PetscObjectUseFortranCallback(tao, _cb.jacstate, (Tao *, Vec *, Mat *, Mat *, Mat *, void *, PetscErrorCode *), (&tao, &x, &H, &Hpre, &Hinv, _ctx, &ierr));
    101: }

    103: static PetscErrorCode ourtaojacobiandesignroutine(Tao tao, Vec x, Mat H, void *ctx)
    104: {
    105:   PetscObjectUseFortranCallback(tao, _cb.jacdesign, (Tao *, Vec *, Mat *, void *, PetscErrorCode *), (&tao, &x, &H, _ctx, &ierr));
    106: }

    108: static PetscErrorCode ourtaoboundsroutine(Tao tao, Vec xl, Vec xu, void *ctx)
    109: {
    110:   PetscObjectUseFortranCallback(tao, _cb.bounds, (Tao *, Vec *, Vec *, void *, PetscErrorCode *), (&tao, &xl, &xu, _ctx, &ierr));
    111: }
    112: static PetscErrorCode ourtaoresidualroutine(Tao tao, Vec x, Vec f, void *ctx)
    113: {
    114:   PetscObjectUseFortranCallback(tao, _cb.lsres, (Tao *, Vec *, Vec *, void *, PetscErrorCode *), (&tao, &x, &f, _ctx, &ierr));
    115: }

    117: static PetscErrorCode ourtaojacobianresidualroutine(Tao tao, Vec x, Mat J, Mat Jpre, void *ctx)
    118: {
    119:   PetscObjectUseFortranCallback(tao, _cb.lsjac, (Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), (&tao, &x, &J, &Jpre, _ctx, &ierr));
    120: }

    122: static PetscErrorCode ourtaomonitor(Tao tao, void *ctx)
    123: {
    124:   PetscObjectUseFortranCallback(tao, _cb.mon, (Tao *, void *, PetscErrorCode *), (&tao, _ctx, &ierr));
    125: }

    127: static PetscErrorCode ourtaomondestroy(void **ctx)
    128: {
    129:   Tao tao = (Tao)*ctx;
    130:   PetscObjectUseFortranCallback(tao, _cb.mondestroy, (void *, PetscErrorCode *), (_ctx, &ierr));
    131: }
    132: static PetscErrorCode ourtaoconvergencetest(Tao tao, void *ctx)
    133: {
    134:   PetscObjectUseFortranCallback(tao, _cb.convtest, (Tao *, void *, PetscErrorCode *), (&tao, _ctx, &ierr));
    135: }

    137: static PetscErrorCode ourtaoconstraintsroutine(Tao tao, Vec x, Vec c, void *ctx)
    138: {
    139:   PetscObjectUseFortranCallback(tao, _cb.constraints, (Tao *, Vec *, Vec *, void *, PetscErrorCode *), (&tao, &x, &c, _ctx, &ierr));
    140: }

    142: static PetscErrorCode ourtaojacobianinequalityroutine(Tao tao, Vec x, Mat J, Mat Jpre, void *ctx)
    143: {
    144:   PetscObjectUseFortranCallback(tao, _cb.jacineq, (Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), (&tao, &x, &J, &Jpre, _ctx, &ierr));
    145: }

    147: static PetscErrorCode ourtaojacobianequalityroutine(Tao tao, Vec x, Mat J, Mat Jpre, void *ctx)
    148: {
    149:   PetscObjectUseFortranCallback(tao, _cb.jaceq, (Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), (&tao, &x, &J, &Jpre, _ctx, &ierr));
    150: }

    152: static PetscErrorCode ourtaoinequalityconstraintsroutine(Tao tao, Vec x, Vec c, void *ctx)
    153: {
    154:   PetscObjectUseFortranCallback(tao, _cb.conineq, (Tao *, Vec *, Vec *, void *, PetscErrorCode *), (&tao, &x, &c, _ctx, &ierr));
    155: }

    157: static PetscErrorCode ourtaoequalityconstraintsroutine(Tao tao, Vec x, Vec c, void *ctx)
    158: {
    159:   PetscObjectUseFortranCallback(tao, _cb.coneq, (Tao *, Vec *, Vec *, void *, PetscErrorCode *), (&tao, &x, &c, _ctx, &ierr));
    160: }

    162: static PetscErrorCode ourtaoupdateroutine(Tao tao, PetscInt iter, void *ctx)
    163: {
    164:   PetscObjectUseFortranCallback(tao, _cb.update, (Tao *, PetscInt *, void *), (&tao, &iter, _ctx));
    165: }

    167: PETSC_EXTERN void taosetobjective_(Tao *tao, void (*func)(Tao *, Vec *, PetscReal *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    168: {
    169:   CHKFORTRANNULLFUNCTION(func);
    170:   *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.obj, (PetscVoidFn *)func, ctx);
    171:   if (!*ierr) *ierr = TaoSetObjective(*tao, ourtaoobjectiveroutine, ctx);
    172: }

    174: PETSC_EXTERN void taosetgradient_(Tao *tao, Vec *g, void (*func)(Tao *, Vec *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    175: {
    176:   CHKFORTRANNULLFUNCTION(func);
    177:   *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.grad, (PetscVoidFn *)func, ctx);
    178:   if (!*ierr) *ierr = TaoSetGradient(*tao, *g, ourtaogradientroutine, ctx);
    179: }

    181: PETSC_EXTERN void taosetobjectiveandgradient_(Tao *tao, Vec *g, void (*func)(Tao *, Vec *, PetscReal *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    182: {
    183:   CHKFORTRANNULLFUNCTION(func);
    184:   *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.objgrad, (PetscVoidFn *)func, ctx);
    185:   if (!*ierr) *ierr = TaoSetObjectiveAndGradient(*tao, *g, ourtaoobjectiveandgradientroutine, ctx);
    186: }

    188: PETSC_EXTERN void taosethessian_(Tao *tao, Mat *J, Mat *Jp, void (*func)(Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    189: {
    190:   CHKFORTRANNULLFUNCTION(func);
    191:   *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.hess, (PetscVoidFn *)func, ctx);
    192:   if (!*ierr) *ierr = TaoSetHessian(*tao, *J, *Jp, ourtaohessianroutine, ctx);
    193: }

    195: PETSC_EXTERN void taosetresidualroutine_(Tao *tao, Vec *F, void (*func)(Tao *, Vec *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    196: {
    197:   CHKFORTRANNULLFUNCTION(func);
    198:   *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.lsres, (PetscVoidFn *)func, ctx);
    199:   if (!*ierr) *ierr = TaoSetResidualRoutine(*tao, *F, ourtaoresidualroutine, ctx);
    200: }

    202: PETSC_EXTERN void taosetjacobianresidualroutine_(Tao *tao, Mat *J, Mat *Jpre, void (*func)(Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    203: {
    204:   CHKFORTRANNULLFUNCTION(func);
    205:   *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.lsjac, (PetscVoidFn *)func, ctx);
    206:   if (!*ierr) *ierr = TaoSetJacobianResidualRoutine(*tao, *J, *Jpre, ourtaojacobianresidualroutine, ctx);
    207: }

    209: PETSC_EXTERN void taosetjacobianroutine_(Tao *tao, Mat *J, Mat *Jp, void (*func)(Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    210: {
    211:   CHKFORTRANNULLFUNCTION(func);
    212:   *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.jac, (PetscVoidFn *)func, ctx);
    213:   if (!*ierr) *ierr = TaoSetJacobianRoutine(*tao, *J, *Jp, ourtaojacobianroutine, ctx);
    214: }

    216: PETSC_EXTERN void taosetjacobianstateroutine_(Tao *tao, Mat *J, Mat *Jp, Mat *Jinv, void (*func)(Tao *, Vec *, Mat *, Mat *, Mat *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    217: {
    218:   CHKFORTRANNULLFUNCTION(func);
    219:   *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.jacstate, (PetscVoidFn *)func, ctx);
    220:   if (!*ierr) *ierr = TaoSetJacobianStateRoutine(*tao, *J, *Jp, *Jinv, ourtaojacobianstateroutine, ctx);
    221: }

    223: PETSC_EXTERN void taosetjacobiandesignroutine_(Tao *tao, Mat *J, void (*func)(Tao *, Vec *, Mat *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    224: {
    225:   CHKFORTRANNULLFUNCTION(func);
    226:   *ierr = PetscObjectSetFortranCallback((PetscObject)tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.jacdesign, (PetscVoidFn *)func, ctx);
    227:   if (!*ierr) *ierr = TaoSetJacobianDesignRoutine(*tao, *J, ourtaojacobiandesignroutine, ctx);
    228: }

    230: PETSC_EXTERN void taosetvariableboundsroutine_(Tao *tao, void (*func)(Tao *, Vec *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    231: {
    232:   CHKFORTRANNULLFUNCTION(func);
    233:   *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.bounds, (PetscVoidFn *)func, ctx);
    234:   if (!*ierr) *ierr = TaoSetVariableBoundsRoutine(*tao, ourtaoboundsroutine, ctx);
    235: }

    237: PETSC_EXTERN void taomonitorset_(Tao *tao, void (*func)(Tao *, void *, PetscErrorCode *), void *ctx, void (*mondestroy)(void *, PetscErrorCode *), PetscErrorCode *ierr)
    238: {
    239:   CHKFORTRANNULLFUNCTION(mondestroy);
    240:   *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.mon, (PetscVoidFn *)func, ctx);
    241:   if (*ierr) return;
    242:   *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.mondestroy, (PetscVoidFn *)mondestroy, ctx);
    243:   if (*ierr) return;
    244:   *ierr = TaoMonitorSet(*tao, ourtaomonitor, *tao, ourtaomondestroy);
    245: }

    247: PETSC_EXTERN void taosetconvergencetest_(Tao *tao, void (*func)(Tao *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    248: {
    249:   CHKFORTRANNULLFUNCTION(func);
    250:   *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.convtest, (PetscVoidFn *)func, ctx);
    251:   if (!*ierr) *ierr = TaoSetConvergenceTest(*tao, ourtaoconvergencetest, ctx);
    252: }

    254: PETSC_EXTERN void taosetconstraintsroutine_(Tao *tao, Vec *C, void (*func)(Tao *, Vec *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    255: {
    256:   CHKFORTRANNULLFUNCTION(func);
    257:   *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.constraints, (PetscVoidFn *)func, ctx);
    258:   if (!*ierr) *ierr = TaoSetConstraintsRoutine(*tao, *C, ourtaoconstraintsroutine, ctx);
    259: }

    261: PETSC_EXTERN void taogetconvergencehistory_(Tao *tao, PetscInt *nhist, PetscErrorCode *ierr)
    262: {
    263:   *ierr = TaoGetConvergenceHistory(*tao, NULL, NULL, NULL, NULL, nhist);
    264: }

    266: PETSC_EXTERN void taosetjacobianinequalityroutine_(Tao *tao, Mat *J, Mat *Jp, void (*func)(Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    267: {
    268:   CHKFORTRANNULLFUNCTION(func);
    269:   *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.jacineq, (PetscVoidFn *)func, ctx);
    270:   if (!*ierr) *ierr = TaoSetJacobianInequalityRoutine(*tao, *J, *Jp, ourtaojacobianinequalityroutine, ctx);
    271: }

    273: PETSC_EXTERN void taosetjacobianequalityroutine_(Tao *tao, Mat *J, Mat *Jp, void (*func)(Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    274: {
    275:   CHKFORTRANNULLFUNCTION(func);
    276:   *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.jaceq, (PetscVoidFn *)func, ctx);
    277:   if (!*ierr) *ierr = TaoSetJacobianEqualityRoutine(*tao, *J, *Jp, ourtaojacobianequalityroutine, ctx);
    278: }

    280: PETSC_EXTERN void taosetinequalityconstraintsroutine_(Tao *tao, Vec *C, void (*func)(Tao *, Vec *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    281: {
    282:   CHKFORTRANNULLFUNCTION(func);
    283:   *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.conineq, (PetscVoidFn *)func, ctx);
    284:   if (!*ierr) *ierr = TaoSetInequalityConstraintsRoutine(*tao, *C, ourtaoinequalityconstraintsroutine, ctx);
    285: }

    287: PETSC_EXTERN void taosetequalityconstraintsroutine_(Tao *tao, Vec *C, void (*func)(Tao *, Vec *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    288: {
    289:   CHKFORTRANNULLFUNCTION(func);
    290:   *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.coneq, (PetscVoidFn *)func, ctx);
    291:   if (!*ierr) *ierr = TaoSetEqualityConstraintsRoutine(*tao, *C, ourtaoequalityconstraintsroutine, ctx);
    292: }

    294: PETSC_EXTERN void taosetupdate_(Tao *tao, void (*func)(Tao *, PetscInt *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr)
    295: {
    296:   CHKFORTRANNULLFUNCTION(func);
    297:   *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.update, (PetscVoidFn *)func, ctx);
    298:   if (!*ierr) *ierr = TaoSetUpdate(*tao, ourtaoupdateroutine, ctx);
    299: }