1 #include <petsc/private/ftnimpl.h> 2 #include <petscsnes.h> 3 #include <petscviewer.h> 4 #include <petsc/private/ftnimpl.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 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 #define matmffdcomputejacobian_ MATMFFDCOMPUTEJACOBIAN 35 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 36 #define snessetpicard_ snessetpicard 37 #define snessetpicardnointerface_ snessetpicardnointerface 38 #define snessolve_ snessolve 39 #define snescomputejacobiandefault_ snescomputejacobiandefault 40 #define snescomputejacobiandefaultcolor_ snescomputejacobiandefaultcolor 41 #define snessetjacobian_ snessetjacobian 42 #define snessetjacobiannointerface_ snessetjacobiannointerface 43 #define snessetfunction_ snessetfunction 44 #define snessetfunctionnointerface_ snessetfunctionnointerface 45 #define snessetobjective_ snessetobjective 46 #define snessetobjectivenointerface_ snessetobjectivenointerface 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 snesgetjacobian_ snesgetjacobian 55 #define snesmonitordefault_ snesmonitordefault 56 #define snesmonitorsolution_ snesmonitorsolution 57 #define snesmonitorsolutionupdate_ snesmonitorsolutionupdate 58 #define snesmonitorset_ snesmonitorset 59 #define snesnewtontrsetprecheck_ snesnewtontrsetprecheck 60 #define snesnewtontrsetpostcheck_ snesnewtontrsetpostcheck 61 #define snesnewtontrdcsetprecheck_ snesnewtontrdcsetprecheck 62 #define snesnewtontrdcsetpostcheck_ snesnewtontrdcsetpostcheck 63 #define matmffdcomputejacobian_ matmffdcomputejacobian 64 #endif 65 66 static struct { 67 PetscFortranCallbackId function; 68 PetscFortranCallbackId objective; 69 PetscFortranCallbackId test; 70 PetscFortranCallbackId destroy; 71 PetscFortranCallbackId jacobian; 72 PetscFortranCallbackId monitor; 73 PetscFortranCallbackId mondestroy; 74 PetscFortranCallbackId ngs; 75 PetscFortranCallbackId update; 76 PetscFortranCallbackId trprecheck; 77 PetscFortranCallbackId trpostcheck; 78 #if defined(PETSC_HAVE_F90_2PTR_ARG) 79 PetscFortranCallbackId function_pgiptr; 80 PetscFortranCallbackId objective_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, PetscCtx 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 *), PetscCtx ctx, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 96 { 97 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.trprecheck, (PetscFortranCallbackFn *)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 *), PetscCtx ctx, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 107 { 108 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.trprecheck, (PetscFortranCallbackFn *)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, PetscCtx 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 *), PetscCtx ctx, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 127 { 128 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.trpostcheck, (PetscFortranCallbackFn *)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 *), PetscCtx ctx, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 138 { 139 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.trpostcheck, (PetscFortranCallbackFn *)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, PetscCtx 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 oursnesobjective(SNES snes, Vec x, PetscReal *v, PetscCtx ctx) 158 { 159 #if defined(PETSC_HAVE_F90_2PTR_ARG) 160 void *ptr; 161 PetscCall(PetscObjectGetFortranCallback((PetscObject)snes, PETSC_FORTRAN_CALLBACK_CLASS, _cb.objective_pgiptr, NULL, &ptr)); 162 #endif 163 PetscObjectUseFortranCallback(snes, _cb.objective, (SNES *, Vec *, PetscReal *, void *, PetscErrorCode *PETSC_F90_2PTR_PROTO_NOVAR), (&snes, &x, v, _ctx, &ierr PETSC_F90_2PTR_PARAM(ptr))); 164 } 165 166 static PetscErrorCode oursnestest(SNES snes, PetscInt it, PetscReal a, PetscReal d, PetscReal c, SNESConvergedReason *reason, PetscCtx ctx) 167 { 168 PetscObjectUseFortranCallback(snes, _cb.test, (SNES *, PetscInt *, PetscReal *, PetscReal *, PetscReal *, SNESConvergedReason *, void *, PetscErrorCode *), (&snes, &it, &a, &d, &c, reason, _ctx, &ierr)); 169 } 170 171 static PetscErrorCode ourdestroy(PetscCtxRt ctx) 172 { 173 PetscObjectUseFortranCallback(ctx, _cb.destroy, (void *, PetscErrorCode *), (_ctx, &ierr)); 174 } 175 176 static PetscErrorCode oursnesjacobian(SNES snes, Vec x, Mat m, Mat p, PetscCtx ctx) 177 { 178 PetscObjectUseFortranCallback(snes, _cb.jacobian, (SNES *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), (&snes, &x, &m, &p, _ctx, &ierr)); 179 } 180 181 static PetscErrorCode oursnesupdate(SNES snes, PetscInt i) 182 { 183 PetscObjectUseFortranCallback(snes, _cb.update, (SNES *, PetscInt *, PetscErrorCode *), (&snes, &i, &ierr)); 184 } 185 static PetscErrorCode oursnesngs(SNES snes, Vec x, Vec b, PetscCtx ctx) 186 { 187 PetscObjectUseFortranCallback(snes, _cb.ngs, (SNES *, Vec *, Vec *, void *, PetscErrorCode *), (&snes, &x, &b, _ctx, &ierr)); 188 } 189 static PetscErrorCode oursnesmonitor(SNES snes, PetscInt i, PetscReal d, PetscCtx ctx) 190 { 191 PetscObjectUseFortranCallback(snes, _cb.monitor, (SNES *, PetscInt *, PetscReal *, void *, PetscErrorCode *), (&snes, &i, &d, _ctx, &ierr)); 192 } 193 static PetscErrorCode ourmondestroy(PetscCtxRt ctx) 194 { 195 SNES snes = *(SNES *)ctx; 196 PetscObjectUseFortranCallback(snes, _cb.mondestroy, (void *, PetscErrorCode *), (_ctx, &ierr)); 197 } 198 199 PETSC_EXTERN void snescomputejacobiandefault_(SNES *, Vec *, Mat *, Mat *, void *, PetscErrorCode *); 200 PETSC_EXTERN void snescomputejacobiandefaultcolor_(SNES *, Vec *, Mat *, Mat *, void *, PetscErrorCode *); 201 PETSC_EXTERN void matmffdcomputejacobian_(SNES *, Vec *, Mat *, Mat *, void *, PetscErrorCode *); 202 203 PETSC_EXTERN void snessetjacobian_(SNES *snes, Mat *A, Mat *B, void (*func)(SNES *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), PetscCtx ctx, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 204 { 205 CHKFORTRANNULLFUNCTION(func); 206 if (func == snescomputejacobiandefault_) { 207 *ierr = SNESSetJacobian(*snes, *A, *B, SNESComputeJacobianDefault, ctx); 208 } else if (func == snescomputejacobiandefaultcolor_) { 209 if (!ctx) { 210 *ierr = PETSC_ERR_ARG_NULL; 211 return; 212 } 213 *ierr = SNESSetJacobian(*snes, *A, *B, SNESComputeJacobianDefaultColor, *(MatFDColoring *)ctx); 214 } else if (func == matmffdcomputejacobian_) { 215 *ierr = SNESSetJacobian(*snes, *A, *B, MatMFFDComputeJacobian, ctx); 216 } else { 217 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.jacobian, (PetscFortranCallbackFn *)func, ctx); 218 if (!*ierr) *ierr = SNESSetJacobian(*snes, *A, *B, oursnesjacobian, NULL); 219 } 220 } 221 222 PETSC_EXTERN void snessetjacobiannointerface_(SNES *snes, Mat *A, Mat *B, void (*func)(SNES *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), PetscCtx ctx, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 223 { 224 snessetjacobian_(snes, A, B, func, ctx, ierr PETSC_F90_2PTR_PARAM(ptr)); 225 } 226 227 /* func is currently ignored from Fortran */ 228 PETSC_EXTERN void snesgetjacobian_(SNES *snes, Mat *A, Mat *B, int *func, void **ctx, PetscErrorCode *ierr) 229 { 230 SNESJacobianFn *jfunc; 231 void *jctx; 232 233 CHKFORTRANNULL(ctx); 234 CHKFORTRANNULLOBJECT(A); 235 CHKFORTRANNULLOBJECT(B); 236 *ierr = SNESGetJacobian(*snes, A, B, &jfunc, &jctx); 237 if (*ierr) return; 238 if (jfunc == SNESComputeJacobianDefault || jfunc == SNESComputeJacobianDefaultColor || jfunc == MatMFFDComputeJacobian) { 239 if (ctx) *ctx = jctx; 240 } else { 241 *ierr = PetscObjectGetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, _cb.jacobian, NULL, ctx); 242 } 243 } 244 245 static PetscErrorCode oursnespicardfunction(SNES snes, Vec x, Vec f, PetscCtx ctx) 246 { 247 #if defined(PETSC_HAVE_F90_2PTR_ARG) 248 void *ptr; 249 PetscCall(PetscObjectGetFortranCallback((PetscObject)snes, PETSC_FORTRAN_CALLBACK_CLASS, _cb.function_pgiptr, NULL, &ptr)); 250 #endif 251 PetscObjectUseFortranCallback(snes, _cb.function, (SNES *, Vec *, Vec *, void *, PetscErrorCode *PETSC_F90_2PTR_PROTO_NOVAR), (&snes, &x, &f, _ctx, &ierr PETSC_F90_2PTR_PARAM(ptr))); 252 } 253 254 static PetscErrorCode oursnespicardjacobian(SNES snes, Vec x, Mat m, Mat p, PetscCtx ctx) 255 { 256 PetscObjectUseFortranCallback(snes, _cb.jacobian, (SNES *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), (&snes, &x, &m, &p, _ctx, &ierr)); 257 } 258 259 PETSC_EXTERN void snessetpicard_(SNES *snes, Vec *r, void (*func)(SNES, Vec, Vec, void *, PetscErrorCode *), Mat *A, Mat *B, void (*J)(SNES *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), PetscCtx ctx, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 260 { 261 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.function, (PetscFortranCallbackFn *)func, ctx); 262 #if defined(PETSC_HAVE_F90_2PTR_ARG) 263 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.function_pgiptr, NULL, ptr); 264 if (*ierr) return; 265 #endif 266 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.jacobian, (PetscFortranCallbackFn *)J, ctx); 267 if (!*ierr) *ierr = SNESSetPicard(*snes, *r, oursnespicardfunction, *A, *B, oursnespicardjacobian, NULL); 268 } 269 270 PETSC_EXTERN void snessetpicardnointerface_(SNES *snes, Vec *r, void (*func)(SNES, Vec, Vec, void *, PetscErrorCode *), Mat *A, Mat *B, void (*J)(SNES *, Vec *, Mat *, Mat *, void *, PetscErrorCode *), PetscCtx ctx, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 271 { 272 snessetpicard_(snes, r, func, A, B, J, ctx, ierr PETSC_F90_2PTR_PARAM(ptr)); 273 } 274 275 PETSC_EXTERN void snessetfunction_(SNES *snes, Vec *r, void (*func)(SNES, Vec, Vec, void *, PetscErrorCode *), PetscCtx ctx, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 276 { 277 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.function, (PetscFortranCallbackFn *)func, ctx); 278 if (*ierr) return; 279 #if defined(PETSC_HAVE_F90_2PTR_ARG) 280 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.function_pgiptr, NULL, ptr); 281 if (*ierr) return; 282 #endif 283 *ierr = SNESSetFunction(*snes, *r, oursnesfunction, NULL); 284 } 285 286 PETSC_EXTERN void snessetfunctionnointerface_(SNES *snes, Vec *r, void (*func)(SNES, Vec, Vec, void *, PetscErrorCode *), PetscCtx ctx, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 287 { 288 snessetfunction_(snes, r, func, ctx, ierr PETSC_F90_2PTR_PARAM(ptr)); 289 } 290 291 PETSC_EXTERN void snessetobjective_(SNES *snes, SNESObjectiveFn func, PetscCtx ctx, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 292 { 293 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.objective, (PetscFortranCallbackFn *)func, ctx); 294 if (*ierr) return; 295 #if defined(PETSC_HAVE_F90_2PTR_ARG) 296 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.objective_pgiptr, NULL, ptr); 297 if (*ierr) return; 298 #endif 299 *ierr = SNESSetObjective(*snes, oursnesobjective, NULL); 300 } 301 302 PETSC_EXTERN void snessetobjectivenointerface_(SNES *snes, SNESObjectiveFn func, PetscCtx ctx, PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 303 { 304 snessetobjective_(snes, func, ctx, ierr PETSC_F90_2PTR_PARAM(ptr)); 305 } 306 307 PETSC_EXTERN void snessetngs_(SNES *snes, void (*func)(SNES *, Vec *, Vec *, void *, PetscErrorCode *), PetscCtx ctx, PetscErrorCode *ierr) 308 { 309 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.ngs, (PetscFortranCallbackFn *)func, ctx); 310 if (*ierr) return; 311 *ierr = SNESSetNGS(*snes, oursnesngs, NULL); 312 } 313 PETSC_EXTERN void snessetupdate_(SNES *snes, void (*func)(SNES *, PetscInt *, PetscErrorCode *), PetscErrorCode *ierr) 314 { 315 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.update, (PetscFortranCallbackFn *)func, NULL); 316 if (*ierr) return; 317 *ierr = SNESSetUpdate(*snes, oursnesupdate); 318 } 319 320 /* the func argument is ignored */ 321 PETSC_EXTERN void snesgetfunction_(SNES *snes, Vec *r, void (*func)(SNES, Vec, Vec, void *, PetscErrorCode *), void **ctx, PetscErrorCode *ierr) 322 { 323 CHKFORTRANNULLOBJECT(r); 324 *ierr = SNESGetFunction(*snes, r, NULL, NULL); 325 if (*ierr) return; 326 if ((PetscFortranCallbackFn *)func == (PetscFortranCallbackFn *)PETSC_NULL_FUNCTION_Fortran) return; 327 *ierr = PetscObjectGetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, _cb.function, NULL, ctx); 328 } 329 330 PETSC_EXTERN void snesgetngs_(SNES *snes, void *func, void **ctx, PetscErrorCode *ierr) 331 { 332 *ierr = PetscObjectGetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, _cb.ngs, NULL, ctx); 333 } 334 335 PETSC_EXTERN void snesconvergeddefault_(SNES *, PetscInt *, PetscReal *, PetscReal *, PetscReal *, SNESConvergedReason *, void *, PetscErrorCode *); 336 PETSC_EXTERN void snesconvergedskip_(SNES *, PetscInt *, PetscReal *, PetscReal *, PetscReal *, SNESConvergedReason *, void *, PetscErrorCode *); 337 338 PETSC_EXTERN void snessetconvergencetest_(SNES *snes, void (*func)(SNES *, PetscInt *, PetscReal *, PetscReal *, PetscReal *, SNESConvergedReason *, void *, PetscErrorCode *), void *cctx, PetscCtxDestroyFn *destroy, PetscErrorCode *ierr) 339 { 340 CHKFORTRANNULLFUNCTION(destroy); 341 342 if (func == snesconvergeddefault_) { 343 *ierr = SNESSetConvergenceTest(*snes, SNESConvergedDefault, NULL, NULL); 344 } else if (func == snesconvergedskip_) { 345 *ierr = SNESSetConvergenceTest(*snes, SNESConvergedSkip, NULL, NULL); 346 } else { 347 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.test, (PetscFortranCallbackFn *)func, cctx); 348 if (*ierr) return; 349 if (destroy) { 350 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.destroy, (PetscFortranCallbackFn *)destroy, cctx); 351 if (*ierr) return; 352 *ierr = SNESSetConvergenceTest(*snes, oursnestest, *snes, ourdestroy); 353 } else *ierr = SNESSetConvergenceTest(*snes, oursnestest, *snes, NULL); 354 } 355 } 356 357 PETSC_EXTERN void snesmonitordefault_(SNES *, PetscInt *, PetscReal *, PetscViewerAndFormat **, PetscErrorCode *); 358 359 PETSC_EXTERN void snesmonitorsolution_(SNES *snes, PetscInt *its, PetscReal *fgnorm, PetscViewerAndFormat **dummy, PetscErrorCode *ierr); 360 361 PETSC_EXTERN void snesmonitorsolutionupdate_(SNES *snes, PetscInt *its, PetscReal *fgnorm, PetscViewerAndFormat **dummy, PetscErrorCode *ierr); 362 363 PETSC_EXTERN void snesmonitorset_(SNES *snes, void (*func)(SNES *, PetscInt *, PetscReal *, void *, PetscErrorCode *), void *mctx, void (*mondestroy)(void *, PetscErrorCode *), PetscErrorCode *ierr) 364 { 365 CHKFORTRANNULLFUNCTION(mondestroy); 366 if ((PetscFortranCallbackFn *)func == (PetscFortranCallbackFn *)snesmonitordefault_) { 367 *ierr = SNESMonitorSet(*snes, (PetscErrorCode (*)(SNES, PetscInt, PetscReal, void *))SNESMonitorDefault, *(PetscViewerAndFormat **)mctx, (PetscCtxDestroyFn *)PetscViewerAndFormatDestroy); 368 } else if ((PetscFortranCallbackFn *)func == (PetscFortranCallbackFn *)snesmonitorsolution_) { 369 *ierr = SNESMonitorSet(*snes, (PetscErrorCode (*)(SNES, PetscInt, PetscReal, void *))SNESMonitorSolution, *(PetscViewerAndFormat **)mctx, (PetscCtxDestroyFn *)PetscViewerAndFormatDestroy); 370 } else if ((PetscFortranCallbackFn *)func == (PetscFortranCallbackFn *)snesmonitorsolutionupdate_) { 371 *ierr = SNESMonitorSet(*snes, (PetscErrorCode (*)(SNES, PetscInt, PetscReal, void *))SNESMonitorSolutionUpdate, *(PetscViewerAndFormat **)mctx, (PetscCtxDestroyFn *)PetscViewerAndFormatDestroy); 372 } else { 373 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.monitor, (PetscFortranCallbackFn *)func, mctx); 374 if (*ierr) return; 375 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes, PETSC_FORTRAN_CALLBACK_CLASS, &_cb.mondestroy, (PetscFortranCallbackFn *)mondestroy, mctx); 376 if (*ierr) return; 377 *ierr = SNESMonitorSet(*snes, oursnesmonitor, *snes, ourmondestroy); 378 } 379 } 380