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