1 #include <petsc/private/fortranimpl.h> 2 #include <petscsnes.h> 3 #include <petscviewer.h> 4 #include <petsc/private/f90impl.h> 5 6 #if defined(PETSC_HAVE_FORTRAN_CAPS) 7 #define snessetpicard_ SNESSETPICARD 8 #define matmffdcomputejacobian_ MATMFFDCOMPUTEJACOBIAN 9 #define snessolve_ SNESSOLVE 10 #define snescomputejacobiandefault_ SNESCOMPUTEJACOBIANDEFAULT 11 #define snescomputejacobiandefaultcolor_ SNESCOMPUTEJACOBIANDEFAULTCOLOR 12 #define snessetjacobian_ SNESSETJACOBIAN 13 #define snessetjacobian1_ SNESSETJACOBIAN1 14 #define snessetjacobian2_ SNESSETJACOBIAN2 15 #define snessetfunction_ SNESSETFUNCTION 16 #define snessetobjective_ SNESSETOBJECTIVE 17 #define snessetngs_ SNESSETNGS 18 #define snessetupdate_ SNESSETUPDATE 19 #define snesgetfunction_ SNESGETFUNCTION 20 #define snesgetngs_ SNESGETNGS 21 #define snessetconvergencetest_ SNESSETCONVERGENCETEST 22 #define snesconvergeddefault_ SNESCONVERGEDDEFAULT 23 #define snesconvergedskip_ SNESCONVERGEDSKIP 24 #define snesgetconvergencehistory_ SNESGETCONVERGENCEHISTORY 25 #define snesgetjacobian_ SNESGETJACOBIAN 26 #define snesmonitordefault_ SNESMONITORDEFAULT 27 #define snesmonitorsolution_ SNESMONITORSOLUTION 28 #define snesmonitorsolutionupdate_ SNESMONITORSOLUTIONUPDATE 29 #define snesmonitorset_ SNESMONITORSET 30 #define snesnewtontrsetprecheck_ SNESNEWTONTRSETPRECHECK 31 #define snesnewtontrsetpostcheck_ SNESNEWTONTRSETPOSTCHECK 32 #define snesnewtontrdcsetprecheck_ SNESNEWTONTRDCSETPRECHECK 33 #define snesnewtontrdcsetpostcheck_ SNESNEWTONTRDCSETPOSTCHECK 34 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 35 #define snessetpicard_ snessetpicard 36 #define matmffdcomputejacobian_ matmffdcomputejacobian 37 #define snessolve_ snessolve 38 #define snescomputejacobiandefault_ snescomputejacobiandefault 39 #define snescomputejacobiandefaultcolor_ snescomputejacobiandefaultcolor 40 #define snessetjacobian_ snessetjacobian 41 #define snessetjacobian1_ snessetjacobian1 42 #define snessetjacobian2_ snessetjacobian2 43 #define snessetfunction_ snessetfunction 44 #define snessetobjective_ snessetobjective 45 #define snessetngs_ snessetngs 46 #define snessetupdate_ snessetupdate 47 #define snesgetfunction_ snesgetfunction 48 #define snesgetngs_ snesgetngs 49 #define snessetconvergencetest_ snessetconvergencetest 50 #define snesconvergeddefault_ snesconvergeddefault 51 #define snesconvergedskip_ snesconvergedskip 52 #define snesgetjacobian_ snesgetjacobian 53 #define snesgetconvergencehistory_ snesgetconvergencehistory 54 #define snesmonitordefault_ snesmonitordefault 55 #define snesmonitorsolution_ snesmonitorsolution 56 #define snesmonitorsolutionupdate_ snesmonitorsolutionupdate 57 #define snesmonitorset_ snesmonitorset 58 #define snesnewtontrsetprecheck_ snesnewtontrsetprecheck 59 #define snesnewtontrsetpostcheck_ snesnewtontrsetpostcheck 60 #define snesnewtontrdcsetprecheck_ snesnewtontrdcsetprecheck 61 #define snesnewtontrdcsetpostcheck_ snesnewtontrdcsetpostcheck 62 #endif 63 64 static struct { 65 PetscFortranCallbackId function; 66 PetscFortranCallbackId objective; 67 PetscFortranCallbackId test; 68 PetscFortranCallbackId destroy; 69 PetscFortranCallbackId jacobian; 70 PetscFortranCallbackId monitor; 71 PetscFortranCallbackId mondestroy; 72 PetscFortranCallbackId ngs; 73 PetscFortranCallbackId update; 74 PetscFortranCallbackId trprecheck; 75 PetscFortranCallbackId trpostcheck; 76 #if defined(PETSC_HAVE_F90_2PTR_ARG) 77 PetscFortranCallbackId function_pgiptr; 78 PetscFortranCallbackId objective_pgiptr; 79 PetscFortranCallbackId trprecheck_pgiptr; 80 PetscFortranCallbackId trpostcheck_pgiptr; 81 #endif 82 } _cb; 83 84 static PetscErrorCode ourtrprecheckfunction(SNES snes, Vec x, Vec y, PetscBool *changed_y, void *ctx) 85 { 86 #if defined(PETSC_HAVE_F90_2PTR_ARG) 87 void *ptr; 88 PetscCall(PetscObjectGetFortranCallback((PetscObject)snes, PETSC_FORTRAN_CALLBACK_CLASS, _cb.trprecheck_pgiptr, NULL, &ptr)); 89 #endif 90 PetscObjectUseFortranCallback(snes, _cb.trprecheck, (SNES *, Vec *, Vec *, PetscBool *, void *, PetscErrorCode *PETSC_F90_2PTR_PROTO_NOVAR), (&snes, &x, &y, changed_y, _ctx, &ierr PETSC_F90_2PTR_PARAM(ptr))); 91 } 92 93 PETSC_EXTERN void snesnewtontrsetprecheck_(SNES *snes, void (*func)(SNES, Vec, Vec, PetscBool *, void *), void *ctx, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 94 { 95 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.trprecheck, (PetscVoidFn *)func, ctx); 96 if (*ierr) return; 97 #if defined(PETSC_HAVE_F90_2PTR_ARG) 98 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.trprecheck_pgiptr, NULL, ptr); 99 if (*ierr) return; 100 #endif 101 *ierr = SNESNewtonTRSetPreCheck(*snes, ourtrprecheckfunction, NULL); 102 } 103 104 PETSC_EXTERN void snesnewtontrdcsetprecheck_(SNES *snes, void (*func)(SNES, Vec, Vec, PetscBool *, void *), void *ctx, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 105 { 106 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.trprecheck, (PetscVoidFn *)func, ctx); 107 if (*ierr) return; 108 #if defined(PETSC_HAVE_F90_2PTR_ARG) 109 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.trprecheck_pgiptr, NULL, ptr); 110 if (*ierr) return; 111 #endif 112 *ierr = SNESNewtonTRDCSetPreCheck(*snes, ourtrprecheckfunction, NULL); 113 } 114 115 static PetscErrorCode ourtrpostcheckfunction(SNES snes, Vec x, Vec y, Vec w, PetscBool *changed_y, PetscBool *changed_w, void *ctx) 116 { 117 #if defined(PETSC_HAVE_F90_2PTR_ARG) 118 void *ptr; 119 PetscCall(PetscObjectGetFortranCallback((PetscObject)snes, PETSC_FORTRAN_CALLBACK_CLASS, _cb.trpostcheck_pgiptr, NULL, &ptr)); 120 #endif 121 PetscObjectUseFortranCallback(snes, _cb.trpostcheck, (SNES *, Vec *, Vec *, Vec *, PetscBool *, PetscBool *, void *, PetscErrorCode *PETSC_F90_2PTR_PROTO_NOVAR), (&snes, &x, &y, &w, changed_y, changed_w, _ctx, &ierr PETSC_F90_2PTR_PARAM(ptr))); 122 } 123 124 PETSC_EXTERN void snesnewtontrsetpostcheck_(SNES *snes, void (*func)(SNES, Vec, Vec, Vec, PetscBool *, PetscBool *, void *), void *ctx, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 125 { 126 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.trpostcheck, (PetscVoidFn *)func, ctx); 127 if (*ierr) return; 128 #if defined(PETSC_HAVE_F90_2PTR_ARG) 129 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.trpostcheck_pgiptr, NULL, ptr); 130 if (*ierr) return; 131 #endif 132 *ierr = SNESNewtonTRSetPostCheck(*snes, ourtrpostcheckfunction, NULL); 133 } 134 135 PETSC_EXTERN void snesnewtontrdcsetpostcheck_(SNES *snes, void (*func)(SNES, Vec, Vec, Vec, PetscBool *, PetscBool *, void *), void *ctx, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 136 { 137 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.trpostcheck, (PetscVoidFn *)func, ctx); 138 if (*ierr) return; 139 #if defined(PETSC_HAVE_F90_2PTR_ARG) 140 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.trpostcheck_pgiptr, NULL, ptr); 141 if (*ierr) return; 142 #endif 143 *ierr = SNESNewtonTRDCSetPostCheck(*snes, ourtrpostcheckfunction, NULL); 144 } 145 146 static PetscErrorCode oursnesfunction(SNES snes, Vec x, Vec f, void *ctx) 147 { 148 #if defined(PETSC_HAVE_F90_2PTR_ARG) 149 void *ptr; 150 PetscCall(PetscObjectGetFortranCallback((PetscObject)snes, PETSC_FORTRAN_CALLBACK_CLASS, _cb.function_pgiptr, NULL, &ptr)); 151 #endif 152 PetscObjectUseFortranCallback(snes, _cb.function, (SNES *, Vec *, Vec *, void *, PetscErrorCode *PETSC_F90_2PTR_PROTO_NOVAR), (&snes, &x, &f, _ctx, &ierr PETSC_F90_2PTR_PARAM(ptr))); 153 } 154 155 static PetscErrorCode oursnesobjective(SNES snes, Vec x, PetscReal *v, void *ctx) 156 { 157 #if defined(PETSC_HAVE_F90_2PTR_ARG) 158 void *ptr; 159 PetscCall(PetscObjectGetFortranCallback((PetscObject)snes, PETSC_FORTRAN_CALLBACK_CLASS, _cb.objective_pgiptr, NULL, &ptr)); 160 #endif 161 PetscObjectUseFortranCallback(snes, _cb.objective, (SNES *, Vec *, PetscReal *, void *, PetscErrorCode *PETSC_F90_2PTR_PROTO_NOVAR), (&snes, &x, v, _ctx, &ierr PETSC_F90_2PTR_PARAM(ptr))); 162 } 163 164 static PetscErrorCode oursnestest(SNES snes, PetscInt it, PetscReal a, PetscReal d, PetscReal c, SNESConvergedReason *reason, void *ctx) 165 { 166 PetscObjectUseFortranCallback(snes, _cb.test, (SNES *, PetscInt *, PetscReal *, PetscReal *, PetscReal *, SNESConvergedReason *, void *, PetscErrorCode *), (&snes, &it, &a, &d, &c, reason, _ctx, &ierr)); 167 } 168 169 static PetscErrorCode ourdestroy(void *ctx) 170 { 171 PetscObjectUseFortranCallback(ctx, _cb.destroy, (void *, PetscErrorCode *), (_ctx, &ierr)); 172 } 173 174 static PetscErrorCode oursnesjacobian(SNES snes, Vec x, Mat m, Mat p, void *ctx) 175 { 176 PetscObjectUseFortranCallback(snes, _cb.jacobian, (SNES *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), (&snes, &x, &m, &p, _ctx, &ierr)); 177 } 178 179 static PetscErrorCode oursnesupdate(SNES snes, PetscInt i) 180 { 181 PetscObjectUseFortranCallback(snes, _cb.update, (SNES *, PetscInt *, PetscErrorCode *), (&snes, &i, &ierr)); 182 } 183 static PetscErrorCode oursnesngs(SNES snes, Vec x, Vec b, void *ctx) 184 { 185 PetscObjectUseFortranCallback(snes, _cb.ngs, (SNES *, Vec *, Vec *, void *, PetscErrorCode *), (&snes, &x, &b, _ctx, &ierr)); 186 } 187 static PetscErrorCode oursnesmonitor(SNES snes, PetscInt i, PetscReal d, void *ctx) 188 { 189 PetscObjectUseFortranCallback(snes, _cb.monitor, (SNES *, PetscInt *, PetscReal *, void *, PetscErrorCode *), (&snes, &i, &d, _ctx, &ierr)); 190 } 191 static PetscErrorCode ourmondestroy(void **ctx) 192 { 193 SNES snes = (SNES)*ctx; 194 PetscObjectUseFortranCallback(snes, _cb.mondestroy, (void *, PetscErrorCode *), (_ctx, &ierr)); 195 } 196 197 /* 198 snescomputejacobiandefault() and snescomputejacobiandefaultcolor() 199 These can be used directly from Fortran but are mostly so that 200 Fortran SNESSetJacobian() will properly handle the defaults being passed in. 201 */ 202 PETSC_EXTERN void matmffdcomputejacobian_(SNES *snes, Vec *x, Mat *m, Mat *p, void *ctx, PetscErrorCode *ierr) 203 { 204 *ierr = MatMFFDComputeJacobian(*snes, *x, *m, *p, ctx); 205 } 206 PETSC_EXTERN void snescomputejacobiandefault_(SNES *snes, Vec *x, Mat *m, Mat *p, void *ctx, PetscErrorCode *ierr) 207 { 208 *ierr = SNESComputeJacobianDefault(*snes, *x, *m, *p, ctx); 209 } 210 PETSC_EXTERN void snescomputejacobiandefaultcolor_(SNES *snes, Vec *x, Mat *m, Mat *p, void *ctx, PetscErrorCode *ierr) 211 { 212 *ierr = SNESComputeJacobianDefaultColor(*snes, *x, *m, *p, *(MatFDColoring *)ctx); 213 } 214 215 PETSC_EXTERN void snessetjacobian_(SNES *snes, Mat *A, Mat *B, void (*func)(SNES *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 216 { 217 CHKFORTRANNULLFUNCTION(func); 218 if ((PetscVoidFn *)func == (PetscVoidFn *)snescomputejacobiandefault_) { 219 *ierr = SNESSetJacobian(*snes, *A, *B, SNESComputeJacobianDefault, ctx); 220 } else if ((PetscVoidFn *)func == (PetscVoidFn *)snescomputejacobiandefaultcolor_) { 221 if (!ctx) { 222 *ierr = PETSC_ERR_ARG_NULL; 223 return; 224 } 225 *ierr = SNESSetJacobian(*snes, *A, *B, SNESComputeJacobianDefaultColor, *(MatFDColoring *)ctx); 226 } else if ((PetscVoidFn *)func == (PetscVoidFn *)matmffdcomputejacobian_) { 227 *ierr = SNESSetJacobian(*snes, *A, *B, MatMFFDComputeJacobian, ctx); 228 } else { 229 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.jacobian, (PetscVoidFn *)func, ctx); 230 if (!*ierr) *ierr = SNESSetJacobian(*snes, *A, *B, oursnesjacobian, NULL); 231 } 232 } 233 PETSC_EXTERN void snessetjacobian1_(SNES *snes, Mat *A, Mat *B, void (*func)(SNES *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 234 { 235 snessetjacobian_(snes, A, B, func, ctx, ierr); 236 } 237 PETSC_EXTERN void snessetjacobian2_(SNES *snes, Mat *A, Mat *B, void (*func)(SNES *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 238 { 239 snessetjacobian_(snes, A, B, func, ctx, ierr); 240 } 241 242 static PetscErrorCode oursnespicardfunction(SNES snes, Vec x, Vec f, void *ctx) 243 { 244 #if defined(PETSC_HAVE_F90_2PTR_ARG) 245 void *ptr; 246 PetscCall(PetscObjectGetFortranCallback((PetscObject)snes, PETSC_FORTRAN_CALLBACK_CLASS, _cb.function_pgiptr, NULL, &ptr)); 247 #endif 248 PetscObjectUseFortranCallback(snes, _cb.function, (SNES *, Vec *, Vec *, void *, PetscErrorCode *PETSC_F90_2PTR_PROTO_NOVAR), (&snes, &x, &f, _ctx, &ierr PETSC_F90_2PTR_PARAM(ptr))); 249 } 250 251 static PetscErrorCode oursnespicardjacobian(SNES snes, Vec x, Mat m, Mat p, void *ctx) 252 { 253 PetscObjectUseFortranCallback(snes, _cb.jacobian, (SNES *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), (&snes, &x, &m, &p, _ctx, &ierr)); 254 } 255 256 PETSC_EXTERN void snessetpicard_(SNES *snes, Vec *r, void (*func)(SNES *, Vec *, Vec *, void *, PetscErrorCode *), Mat *A, Mat *B, PetscErrorCode (*J)(SNES, Vec, Mat, Mat, void *), void *ctx, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 257 { 258 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.function, (PetscVoidFn *)func, ctx); 259 #if defined(PETSC_HAVE_F90_2PTR_ARG) 260 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.function_pgiptr, NULL, ptr); 261 if (*ierr) return; 262 #endif 263 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.jacobian, (PetscVoidFn *)J, ctx); 264 if (!*ierr) *ierr = SNESSetPicard(*snes, *r, oursnespicardfunction, *A, *B, oursnespicardjacobian, NULL); 265 } 266 267 /* 268 These are not usually called from Fortran but allow Fortran users 269 to transparently set these monitors from .F code 270 */ 271 272 PETSC_EXTERN void snessetfunction_(SNES *snes, Vec *r, void (*func)(SNES *, Vec *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 273 { 274 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.function, (PetscVoidFn *)func, ctx); 275 if (*ierr) return; 276 #if defined(PETSC_HAVE_F90_2PTR_ARG) 277 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.function_pgiptr, NULL, ptr); 278 if (*ierr) return; 279 #endif 280 *ierr = SNESSetFunction(*snes, *r, oursnesfunction, NULL); 281 } 282 283 PETSC_EXTERN void snessetobjective_(SNES *snes, void (*func)(SNES *, Vec *, PetscReal *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 284 { 285 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.objective, (PetscVoidFn *)func, ctx); 286 if (*ierr) return; 287 #if defined(PETSC_HAVE_F90_2PTR_ARG) 288 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.objective_pgiptr, NULL, ptr); 289 if (*ierr) return; 290 #endif 291 *ierr = SNESSetObjective(*snes, oursnesobjective, NULL); 292 } 293 294 PETSC_EXTERN void snessetngs_(SNES *snes, void (*func)(SNES *, Vec *, Vec *, void *, PetscErrorCode *), void *ctx, PetscErrorCode *ierr) 295 { 296 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.ngs, (PetscVoidFn *)func, ctx); 297 if (*ierr) return; 298 *ierr = SNESSetNGS(*snes, oursnesngs, NULL); 299 } 300 PETSC_EXTERN void snessetupdate_(SNES *snes, void (*func)(SNES *, PetscInt *, PetscErrorCode *), PetscErrorCode *ierr) 301 { 302 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.update, (PetscVoidFn *)func, NULL); 303 if (*ierr) return; 304 *ierr = SNESSetUpdate(*snes, oursnesupdate); 305 } 306 307 /* the func argument is ignored */ 308 PETSC_EXTERN void snesgetfunction_(SNES *snes, Vec *r, void (*func)(SNES, Vec, Vec, void *), void **ctx, PetscErrorCode *ierr) 309 { 310 CHKFORTRANNULLOBJECT(r); 311 *ierr = SNESGetFunction(*snes, r, NULL, NULL); 312 if (*ierr) return; 313 if ((PetscVoidFn *)func == (PetscVoidFn *)PETSC_NULL_FUNCTION_Fortran) return; 314 *ierr = PetscObjectGetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, _cb.function, NULL, ctx); 315 } 316 317 PETSC_EXTERN void snesgetngs_(SNES *snes, void *func, void **ctx, PetscErrorCode *ierr) 318 { 319 *ierr = PetscObjectGetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, _cb.ngs, NULL, ctx); 320 } 321 322 PETSC_EXTERN void snesconvergeddefault_(SNES *snes, PetscInt *it, PetscReal *a, PetscReal *b, PetscReal *c, SNESConvergedReason *r, void *ct, PetscErrorCode *ierr) 323 { 324 *ierr = SNESConvergedDefault(*snes, *it, *a, *b, *c, r, ct); 325 } 326 327 PETSC_EXTERN void snesconvergedskip_(SNES *snes, PetscInt *it, PetscReal *a, PetscReal *b, PetscReal *c, SNESConvergedReason *r, void *ct, PetscErrorCode *ierr) 328 { 329 *ierr = SNESConvergedSkip(*snes, *it, *a, *b, *c, r, ct); 330 } 331 332 PETSC_EXTERN void snessetconvergencetest_(SNES *snes, void (*func)(SNES *, PetscInt *, PetscReal *, PetscReal *, PetscReal *, SNESConvergedReason *, void *, PetscErrorCode *), void *cctx, void (*destroy)(void *), PetscErrorCode *ierr) 333 { 334 CHKFORTRANNULLFUNCTION(destroy); 335 336 if ((PetscVoidFn *)func == (PetscVoidFn *)snesconvergeddefault_) { 337 *ierr = SNESSetConvergenceTest(*snes, SNESConvergedDefault, NULL, NULL); 338 } else if ((PetscVoidFn *)func == (PetscVoidFn *)snesconvergedskip_) { 339 *ierr = SNESSetConvergenceTest(*snes, SNESConvergedSkip, NULL, NULL); 340 } else { 341 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.test, (PetscVoidFn *)func, cctx); 342 if (*ierr) return; 343 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.destroy, (PetscVoidFn *)destroy, cctx); 344 if (*ierr) return; 345 *ierr = SNESSetConvergenceTest(*snes, oursnestest, *snes, ourdestroy); 346 } 347 } 348 349 /* func is currently ignored from Fortran */ 350 PETSC_EXTERN void snesgetjacobian_(SNES *snes, Mat *A, Mat *B, int *func, void **ctx, PetscErrorCode *ierr) 351 { 352 CHKFORTRANNULLINTEGER(ctx); 353 CHKFORTRANNULLOBJECT(A); 354 CHKFORTRANNULLOBJECT(B); 355 *ierr = SNESGetJacobian(*snes, A, B, NULL, NULL); 356 if (*ierr) return; 357 *ierr = PetscObjectGetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, _cb.jacobian, NULL, ctx); 358 } 359 360 PETSC_EXTERN void snesgetconvergencehistory_(SNES *snes, PetscInt *na, PetscErrorCode *ierr) 361 { 362 *ierr = SNESGetConvergenceHistory(*snes, NULL, NULL, na); 363 } 364 365 PETSC_EXTERN void snesmonitordefault_(SNES *snes, PetscInt *its, PetscReal *fgnorm, PetscViewerAndFormat **dummy, PetscErrorCode *ierr) 366 { 367 *ierr = SNESMonitorDefault(*snes, *its, *fgnorm, *dummy); 368 } 369 370 PETSC_EXTERN void snesmonitorsolution_(SNES *snes, PetscInt *its, PetscReal *fgnorm, PetscViewerAndFormat **dummy, PetscErrorCode *ierr) 371 { 372 *ierr = SNESMonitorSolution(*snes, *its, *fgnorm, *dummy); 373 } 374 375 PETSC_EXTERN void snesmonitorsolutionupdate_(SNES *snes, PetscInt *its, PetscReal *fgnorm, PetscViewerAndFormat **dummy, PetscErrorCode *ierr) 376 { 377 *ierr = SNESMonitorSolutionUpdate(*snes, *its, *fgnorm, *dummy); 378 } 379 380 PETSC_EXTERN void snesmonitorset_(SNES *snes, void (*func)(SNES *, PetscInt *, PetscReal *, void *, PetscErrorCode *), void *mctx, void (*mondestroy)(void *, PetscErrorCode *), PetscErrorCode *ierr) 381 { 382 CHKFORTRANNULLFUNCTION(mondestroy); 383 if ((PetscVoidFn *)func == (PetscVoidFn *)snesmonitordefault_) { 384 *ierr = SNESMonitorSet(*snes, (PetscErrorCode(*)(SNES, PetscInt, PetscReal, void *))SNESMonitorDefault, *(PetscViewerAndFormat **)mctx, (PetscErrorCode(*)(void **))PetscViewerAndFormatDestroy); 385 } else if ((PetscVoidFn *)func == (PetscVoidFn *)snesmonitorsolution_) { 386 *ierr = SNESMonitorSet(*snes, (PetscErrorCode(*)(SNES, PetscInt, PetscReal, void *))SNESMonitorSolution, *(PetscViewerAndFormat **)mctx, (PetscErrorCode(*)(void **))PetscViewerAndFormatDestroy); 387 } else if ((PetscVoidFn *)func == (PetscVoidFn *)snesmonitorsolutionupdate_) { 388 *ierr = SNESMonitorSet(*snes, (PetscErrorCode(*)(SNES, PetscInt, PetscReal, void *))SNESMonitorSolutionUpdate, *(PetscViewerAndFormat **)mctx, (PetscErrorCode(*)(void **))PetscViewerAndFormatDestroy); 389 } else { 390 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.monitor, (PetscVoidFn *)func, mctx); 391 if (*ierr) return; 392 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.mondestroy, (PetscVoidFn *)mondestroy, mctx); 393 if (*ierr) return; 394 *ierr = SNESMonitorSet(*snes, oursnesmonitor, *snes, ourmondestroy); 395 } 396 } 397