1 #include <petsc/private/fortranimpl.h> 2 #include <petsc/private/f90impl.h> 3 #include <petsc/private/taoimpl.h> 4 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 46 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; 72 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 } 77 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 } 82 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 } 87 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 } 92 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 } 97 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 } 102 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 } 107 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 } 116 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 } 121 122 static PetscErrorCode ourtaomonitor(Tao tao, void *ctx) 123 { 124 PetscObjectUseFortranCallback(tao, _cb.mon, (Tao *, void *, PetscErrorCode *), (&tao, _ctx, &ierr)); 125 } 126 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 } 136 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 } 141 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 } 146 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 } 151 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 } 156 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 } 161 162 static PetscErrorCode ourtaoupdateroutine(Tao tao, PetscInt iter, void *ctx) 163 { 164 PetscObjectUseFortranCallback(tao, _cb.update, (Tao *, PetscInt *, void *), (&tao, &iter, _ctx)); 165 } 166 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 } 173 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 } 180 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 } 187 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 } 194 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 } 201 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 } 208 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 } 215 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 } 222 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 } 229 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 } 236 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 } 246 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 } 253 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 } 260 261 PETSC_EXTERN void taogetconvergencehistory_(Tao *tao, PetscInt *nhist, PetscErrorCode *ierr) 262 { 263 *ierr = TaoGetConvergenceHistory(*tao, NULL, NULL, NULL, NULL, nhist); 264 } 265 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 } 272 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 } 279 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 } 286 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 } 293 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 } 300