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