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