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