1 #include <petsc/private/ftnimpl.h> 2 #include <petsc/private/taoimpl.h> 3 4 #if defined(PETSC_HAVE_FORTRAN_CAPS) 5 #define taosetobjective_ TAOSETOBJECTIVE 6 #define taosetgradient_ TAOSETGRADIENT 7 #define taosetobjectiveandgradient_ TAOSETOBJECTIVEANDGRADIENT 8 #define taosethessian_ TAOSETHESSIAN 9 #define taosetresidualroutine_ TAOSETRESIDUALROUTINE 10 #define taosetjacobianresidualroutine_ TAOSETJACOBIANRESIDUALROUTINE 11 #define taosetjacobianroutine_ TAOSETJACOBIANROUTINE 12 #define taosetjacobianstateroutine_ TAOSETJACOBIANSTATEROUTINE 13 #define taosetjacobiandesignroutine_ TAOSETJACOBIANDESIGNROUTINE 14 #define taosetjacobianinequalityroutine_ TAOSETJACOBIANINEQUALITYROUTINE 15 #define taosetjacobianequalityroutine_ TAOSETJACOBIANEQUALITYROUTINE 16 #define taosetinequalityconstraintsroutine_ TAOSETINEQUALITYCONSTRAINTSROUTINE 17 #define taosetequalityconstraintsroutine_ TAOSETEQUALITYCONSTRAINTSROUTINE 18 #define taosetvariableboundsroutine_ TAOSETVARIABLEBOUNDSROUTINE 19 #define taosetconstraintsroutine_ TAOSETCONSTRAINTSROUTINE 20 #define taomonitorset_ TAOMONITORSET 21 #define taogetconvergencehistory_ TAOGETCONVERGENCEHISTORY 22 #define taosetconvergencetest_ TAOSETCONVERGENCETEST 23 #define taosetupdate_ TAOSETUPDATE 24 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 25 #define taosetobjective_ taosetobjective 26 #define taosetgradient_ taosetgradient 27 #define taosetobjectiveandgradient_ taosetobjectiveandgradient 28 #define taosethessian_ taosethessian 29 #define taosetresidualroutine_ taosetresidualroutine 30 #define taosetjacobianresidualroutine_ taosetjacobianresidualroutine 31 #define taosetjacobianroutine_ taosetjacobianroutine 32 #define taosetjacobianstateroutine_ taosetjacobianstateroutine 33 #define taosetjacobiandesignroutine_ taosetjacobiandesignroutine 34 #define taosetjacobianinequalityroutine_ taosetjacobianinequalityroutine 35 #define taosetjacobianequalityroutine_ taosetjacobianequalityroutine 36 #define taosetinequalityconstraintsroutine_ taosetinequalityconstraintsroutine 37 #define taosetequalityconstraintsroutine_ taosetequalityconstraintsroutine 38 #define taosetvariableboundsroutine_ taosetvariableboundsroutine 39 #define taosetconstraintsroutine_ taosetconstraintsroutine 40 #define taomonitorset_ taomonitorset 41 #define taogetconvergencehistory_ taogetconvergencehistory 42 #define taosetconvergencetest_ taosetconvergencetest 43 #define taosetupdate_ taosetupdate 44 #endif 45 46 static struct { 47 PetscFortranCallbackId obj; 48 PetscFortranCallbackId grad; 49 PetscFortranCallbackId objgrad; 50 PetscFortranCallbackId hess; 51 PetscFortranCallbackId lsres; 52 PetscFortranCallbackId lsjac; 53 PetscFortranCallbackId jac; 54 PetscFortranCallbackId jacstate; 55 PetscFortranCallbackId jacdesign; 56 PetscFortranCallbackId bounds; 57 PetscFortranCallbackId mon; 58 PetscFortranCallbackId mondestroy; 59 PetscFortranCallbackId convtest; 60 PetscFortranCallbackId constraints; 61 PetscFortranCallbackId jacineq; 62 PetscFortranCallbackId jaceq; 63 PetscFortranCallbackId conineq; 64 PetscFortranCallbackId coneq; 65 PetscFortranCallbackId nfuncs; 66 PetscFortranCallbackId update; 67 #if defined(PETSC_HAVE_F90_2PTR_ARG) 68 PetscFortranCallbackId function_pgiptr; 69 #endif 70 } _cb; 71 72 static PetscErrorCode ourtaoobjectiveroutine(Tao tao, Vec x, PetscReal *f, void *ctx) 73 { 74 PetscObjectUseFortranCallback(tao, _cb.obj, (Tao *, Vec *, PetscReal *, void *, PetscErrorCode *), (&tao, &x, f, _ctx, &ierr)); 75 } 76 77 static PetscErrorCode ourtaogradientroutine(Tao tao, Vec x, Vec g, void *ctx) 78 { 79 PetscObjectUseFortranCallback(tao, _cb.grad, (Tao *, Vec *, Vec *, void *, PetscErrorCode *), (&tao, &x, &g, _ctx, &ierr)); 80 } 81 82 static PetscErrorCode ourtaoobjectiveandgradientroutine(Tao tao, Vec x, PetscReal *f, Vec g, void *ctx) 83 { 84 PetscObjectUseFortranCallback(tao, _cb.objgrad, (Tao *, Vec *, PetscReal *, Vec *, void *, PetscErrorCode *), (&tao, &x, f, &g, _ctx, &ierr)); 85 } 86 87 static PetscErrorCode ourtaohessianroutine(Tao tao, Vec x, Mat H, Mat Hpre, void *ctx) 88 { 89 PetscObjectUseFortranCallback(tao, _cb.hess, (Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), (&tao, &x, &H, &Hpre, _ctx, &ierr)); 90 } 91 92 static PetscErrorCode ourtaojacobianroutine(Tao tao, Vec x, Mat H, Mat Hpre, void *ctx) 93 { 94 PetscObjectUseFortranCallback(tao, _cb.jac, (Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), (&tao, &x, &H, &Hpre, _ctx, &ierr)); 95 } 96 97 static PetscErrorCode ourtaojacobianstateroutine(Tao tao, Vec x, Mat H, Mat Hpre, Mat Hinv, void *ctx) 98 { 99 PetscObjectUseFortranCallback(tao, _cb.jacstate, (Tao *, Vec *, Mat *, Mat *, Mat *, void *, PetscErrorCode *), (&tao, &x, &H, &Hpre, &Hinv, _ctx, &ierr)); 100 } 101 102 static PetscErrorCode ourtaojacobiandesignroutine(Tao tao, Vec x, Mat H, void *ctx) 103 { 104 PetscObjectUseFortranCallback(tao, _cb.jacdesign, (Tao *, Vec *, Mat *, void *, PetscErrorCode *), (&tao, &x, &H, _ctx, &ierr)); 105 } 106 107 static PetscErrorCode ourtaoboundsroutine(Tao tao, Vec xl, Vec xu, void *ctx) 108 { 109 PetscObjectUseFortranCallback(tao, _cb.bounds, (Tao *, Vec *, Vec *, void *, PetscErrorCode *), (&tao, &xl, &xu, _ctx, &ierr)); 110 } 111 static PetscErrorCode ourtaoresidualroutine(Tao tao, Vec x, Vec f, void *ctx) 112 { 113 PetscObjectUseFortranCallback(tao, _cb.lsres, (Tao *, Vec *, Vec *, void *, PetscErrorCode *), (&tao, &x, &f, _ctx, &ierr)); 114 } 115 116 static PetscErrorCode ourtaojacobianresidualroutine(Tao tao, Vec x, Mat J, Mat Jpre, void *ctx) 117 { 118 PetscObjectUseFortranCallback(tao, _cb.lsjac, (Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), (&tao, &x, &J, &Jpre, _ctx, &ierr)); 119 } 120 121 static PetscErrorCode ourtaomonitor(Tao tao, void *ctx) 122 { 123 PetscObjectUseFortranCallback(tao, _cb.mon, (Tao *, void *, PetscErrorCode *), (&tao, _ctx, &ierr)); 124 } 125 126 static PetscErrorCode ourtaomondestroy(void **ctx) 127 { 128 Tao tao = (Tao)*ctx; 129 PetscObjectUseFortranCallback(tao, _cb.mondestroy, (void *, PetscErrorCode *), (_ctx, &ierr)); 130 } 131 static PetscErrorCode ourtaoconvergencetest(Tao tao, void *ctx) 132 { 133 PetscObjectUseFortranCallback(tao, _cb.convtest, (Tao *, void *, PetscErrorCode *), (&tao, _ctx, &ierr)); 134 } 135 136 static PetscErrorCode ourtaoconstraintsroutine(Tao tao, Vec x, Vec c, void *ctx) 137 { 138 PetscObjectUseFortranCallback(tao, _cb.constraints, (Tao *, Vec *, Vec *, void *, PetscErrorCode *), (&tao, &x, &c, _ctx, &ierr)); 139 } 140 141 static PetscErrorCode ourtaojacobianinequalityroutine(Tao tao, Vec x, Mat J, Mat Jpre, void *ctx) 142 { 143 PetscObjectUseFortranCallback(tao, _cb.jacineq, (Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), (&tao, &x, &J, &Jpre, _ctx, &ierr)); 144 } 145 146 static PetscErrorCode ourtaojacobianequalityroutine(Tao tao, Vec x, Mat J, Mat Jpre, void *ctx) 147 { 148 PetscObjectUseFortranCallback(tao, _cb.jaceq, (Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), (&tao, &x, &J, &Jpre, _ctx, &ierr)); 149 } 150 151 static PetscErrorCode ourtaoinequalityconstraintsroutine(Tao tao, Vec x, Vec c, void *ctx) 152 { 153 PetscObjectUseFortranCallback(tao, _cb.conineq, (Tao *, Vec *, Vec *, void *, PetscErrorCode *), (&tao, &x, &c, _ctx, &ierr)); 154 } 155 156 static PetscErrorCode ourtaoequalityconstraintsroutine(Tao tao, Vec x, Vec c, void *ctx) 157 { 158 PetscObjectUseFortranCallback(tao, _cb.coneq, (Tao *, Vec *, Vec *, void *, PetscErrorCode *), (&tao, &x, &c, _ctx, &ierr)); 159 } 160 161 static PetscErrorCode ourtaoupdateroutine(Tao tao, PetscInt iter, void *ctx) 162 { 163 PetscObjectUseFortranCallback(tao, _cb.update, (Tao *, PetscInt *, void *), (&tao, &iter, _ctx)); 164 } 165 166 PETSC_EXTERN void taosetobjective_(Tao *tao, void (*func)(Tao *, Vec *, PetscReal *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 167 { 168 CHKFORTRANNULLFUNCTION(func); 169 *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.obj, (PetscFortranCallbackFn *)func, ctx); 170 if (!*ierr) *ierr = TaoSetObjective(*tao, ourtaoobjectiveroutine, ctx); 171 } 172 173 PETSC_EXTERN void taosetgradient_(Tao *tao, Vec *g, void (*func)(Tao *, Vec *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 174 { 175 CHKFORTRANNULLFUNCTION(func); 176 *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.grad, (PetscFortranCallbackFn *)func, ctx); 177 if (!*ierr) *ierr = TaoSetGradient(*tao, *g, ourtaogradientroutine, ctx); 178 } 179 180 PETSC_EXTERN void taosetobjectiveandgradient_(Tao *tao, Vec *g, void (*func)(Tao *, Vec *, PetscReal *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 181 { 182 CHKFORTRANNULLFUNCTION(func); 183 *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.objgrad, (PetscFortranCallbackFn *)func, ctx); 184 if (!*ierr) *ierr = TaoSetObjectiveAndGradient(*tao, *g, ourtaoobjectiveandgradientroutine, ctx); 185 } 186 187 PETSC_EXTERN void taosethessian_(Tao *tao, Mat *J, Mat *Jp, void (*func)(Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 188 { 189 CHKFORTRANNULLFUNCTION(func); 190 *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.hess, (PetscFortranCallbackFn *)func, ctx); 191 if (!*ierr) *ierr = TaoSetHessian(*tao, *J, *Jp, ourtaohessianroutine, ctx); 192 } 193 194 PETSC_EXTERN void taosetresidualroutine_(Tao *tao, Vec *F, void (*func)(Tao *, Vec *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 195 { 196 CHKFORTRANNULLFUNCTION(func); 197 *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.lsres, (PetscFortranCallbackFn *)func, ctx); 198 if (!*ierr) *ierr = TaoSetResidualRoutine(*tao, *F, ourtaoresidualroutine, ctx); 199 } 200 201 PETSC_EXTERN void taosetjacobianresidualroutine_(Tao *tao, Mat *J, Mat *Jpre, void (*func)(Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 202 { 203 CHKFORTRANNULLFUNCTION(func); 204 *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.lsjac, (PetscFortranCallbackFn *)func, ctx); 205 if (!*ierr) *ierr = TaoSetJacobianResidualRoutine(*tao, *J, *Jpre, ourtaojacobianresidualroutine, ctx); 206 } 207 208 PETSC_EXTERN void taosetjacobianroutine_(Tao *tao, Mat *J, Mat *Jp, void (*func)(Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 209 { 210 CHKFORTRANNULLFUNCTION(func); 211 *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.jac, (PetscFortranCallbackFn *)func, ctx); 212 if (!*ierr) *ierr = TaoSetJacobianRoutine(*tao, *J, *Jp, ourtaojacobianroutine, ctx); 213 } 214 215 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) 216 { 217 CHKFORTRANNULLFUNCTION(func); 218 *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.jacstate, (PetscFortranCallbackFn *)func, ctx); 219 if (!*ierr) *ierr = TaoSetJacobianStateRoutine(*tao, *J, *Jp, *Jinv, ourtaojacobianstateroutine, ctx); 220 } 221 222 PETSC_EXTERN void taosetjacobiandesignroutine_(Tao *tao, Mat *J, void (*func)(Tao *, Vec *, Mat *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 223 { 224 CHKFORTRANNULLFUNCTION(func); 225 *ierr = PetscObjectSetFortranCallback((PetscObject)tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.jacdesign, (PetscFortranCallbackFn *)func, ctx); 226 if (!*ierr) *ierr = TaoSetJacobianDesignRoutine(*tao, *J, ourtaojacobiandesignroutine, ctx); 227 } 228 229 PETSC_EXTERN void taosetvariableboundsroutine_(Tao *tao, void (*func)(Tao *, Vec *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 230 { 231 CHKFORTRANNULLFUNCTION(func); 232 *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.bounds, (PetscFortranCallbackFn *)func, ctx); 233 if (!*ierr) *ierr = TaoSetVariableBoundsRoutine(*tao, ourtaoboundsroutine, ctx); 234 } 235 236 PETSC_EXTERN void taomonitorset_(Tao *tao, void (*func)(Tao *, void *, PetscErrorCode *), void *ctx, void (*mondestroy)(void *, PetscErrorCode *), PetscErrorCode *ierr) 237 { 238 CHKFORTRANNULLFUNCTION(mondestroy); 239 *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.mon, (PetscFortranCallbackFn *)func, ctx); 240 if (*ierr) return; 241 *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.mondestroy, (PetscFortranCallbackFn *)mondestroy, ctx); 242 if (*ierr) return; 243 *ierr = TaoMonitorSet(*tao, ourtaomonitor, *tao, ourtaomondestroy); 244 } 245 246 PETSC_EXTERN void taosetconvergencetest_(Tao *tao, void (*func)(Tao *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 247 { 248 CHKFORTRANNULLFUNCTION(func); 249 *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.convtest, (PetscFortranCallbackFn *)func, ctx); 250 if (!*ierr) *ierr = TaoSetConvergenceTest(*tao, ourtaoconvergencetest, ctx); 251 } 252 253 PETSC_EXTERN void taosetconstraintsroutine_(Tao *tao, Vec *C, void (*func)(Tao *, Vec *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 254 { 255 CHKFORTRANNULLFUNCTION(func); 256 *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.constraints, (PetscFortranCallbackFn *)func, ctx); 257 if (!*ierr) *ierr = TaoSetConstraintsRoutine(*tao, *C, ourtaoconstraintsroutine, ctx); 258 } 259 260 PETSC_EXTERN void taogetconvergencehistory_(Tao *tao, PetscInt *nhist, PetscErrorCode *ierr) 261 { 262 *ierr = TaoGetConvergenceHistory(*tao, NULL, NULL, NULL, NULL, nhist); 263 } 264 265 PETSC_EXTERN void taosetjacobianinequalityroutine_(Tao *tao, Mat *J, Mat *Jp, void (*func)(Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 266 { 267 CHKFORTRANNULLFUNCTION(func); 268 *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.jacineq, (PetscFortranCallbackFn *)func, ctx); 269 if (!*ierr) *ierr = TaoSetJacobianInequalityRoutine(*tao, *J, *Jp, ourtaojacobianinequalityroutine, ctx); 270 } 271 272 PETSC_EXTERN void taosetjacobianequalityroutine_(Tao *tao, Mat *J, Mat *Jp, void (*func)(Tao *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 273 { 274 CHKFORTRANNULLFUNCTION(func); 275 *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.jaceq, (PetscFortranCallbackFn *)func, ctx); 276 if (!*ierr) *ierr = TaoSetJacobianEqualityRoutine(*tao, *J, *Jp, ourtaojacobianequalityroutine, ctx); 277 } 278 279 PETSC_EXTERN void taosetinequalityconstraintsroutine_(Tao *tao, Vec *C, void (*func)(Tao *, Vec *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 280 { 281 CHKFORTRANNULLFUNCTION(func); 282 *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.conineq, (PetscFortranCallbackFn *)func, ctx); 283 if (!*ierr) *ierr = TaoSetInequalityConstraintsRoutine(*tao, *C, ourtaoinequalityconstraintsroutine, ctx); 284 } 285 286 PETSC_EXTERN void taosetequalityconstraintsroutine_(Tao *tao, Vec *C, void (*func)(Tao *, Vec *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 287 { 288 CHKFORTRANNULLFUNCTION(func); 289 *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.coneq, (PetscFortranCallbackFn *)func, ctx); 290 if (!*ierr) *ierr = TaoSetEqualityConstraintsRoutine(*tao, *C, ourtaoequalityconstraintsroutine, ctx); 291 } 292 293 PETSC_EXTERN void taosetupdate_(Tao *tao, void (*func)(Tao *, PetscInt *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 294 { 295 CHKFORTRANNULLFUNCTION(func); 296 *ierr = PetscObjectSetFortranCallback((PetscObject)*tao, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.update, (PetscFortranCallbackFn *)func, ctx); 297 if (!*ierr) *ierr = TaoSetUpdate(*tao, ourtaoupdateroutine, ctx); 298 } 299