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