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