Actual source code: zsnesf.c
1: #include <petsc/private/fortranimpl.h>
2: #include <petscsnes.h>
3: #include <petscviewer.h>
4: #include <petsc/private/f90impl.h>
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
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;
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: }
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: }
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: }
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: }
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: }
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: }
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: }
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: }
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: }
187: static PetscErrorCode ourdestroy(void *ctx)
188: {
189: PetscObjectUseFortranCallback(ctx, _cb.destroy, (void *, PetscErrorCode *), (_ctx, &ierr));
190: }
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: }
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: }
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: }
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: }
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: }
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: }
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: }
285: PETSC_EXTERN void snesgetoptionsprefix_(SNES *snes, char *prefix, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len)
286: {
287: const char *tname;
289: *ierr = SNESGetOptionsPrefix(*snes, &tname);
290: *ierr = PetscStrncpy(prefix, tname, len);
291: if (*ierr) return;
292: FIXRETURNCHAR(PETSC_TRUE, prefix, len);
293: }
295: PETSC_EXTERN void snesgettype_(SNES *snes, char *name, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len)
296: {
297: const char *tname;
299: *ierr = SNESGetType(*snes, &tname);
300: *ierr = PetscStrncpy(name, tname, len);
301: if (*ierr) return;
302: FIXRETURNCHAR(PETSC_TRUE, name, len);
303: }
305: /*
306: These are not usually called from Fortran but allow Fortran users
307: to transparently set these monitors from .F code
308: */
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: }
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: }
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: }
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: }
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: }
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: }
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: }
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);
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: }
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: }
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: }
405: PETSC_EXTERN void snesgetconvergencehistory_(SNES *snes, PetscInt *na, PetscErrorCode *ierr)
406: {
407: *ierr = SNESGetConvergenceHistory(*snes, NULL, NULL, na);
408: }
410: PETSC_EXTERN void snessettype_(SNES *snes, char *type, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len)
411: {
412: char *t;
414: FIXCHAR(type, len, t);
415: *ierr = SNESSetType(*snes, t);
416: if (*ierr) return;
417: FREECHAR(type, t);
418: }
420: PETSC_EXTERN void snesappendoptionsprefix_(SNES *snes, char *prefix, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len)
421: {
422: char *t;
424: FIXCHAR(prefix, len, t);
425: *ierr = SNESAppendOptionsPrefix(*snes, t);
426: if (*ierr) return;
427: FREECHAR(prefix, t);
428: }
430: PETSC_EXTERN void snessetoptionsprefix_(SNES *snes, char *prefix, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len)
431: {
432: char *t;
434: FIXCHAR(prefix, len, t);
435: *ierr = SNESSetOptionsPrefix(*snes, t);
436: if (*ierr) return;
437: FREECHAR(prefix, t);
438: }
440: PETSC_EXTERN void snesmonitordefault_(SNES *snes, PetscInt *its, PetscReal *fgnorm, PetscViewerAndFormat **dummy, PetscErrorCode *ierr)
441: {
442: *ierr = SNESMonitorDefault(*snes, *its, *fgnorm, *dummy);
443: }
445: PETSC_EXTERN void snesmonitorsolution_(SNES *snes, PetscInt *its, PetscReal *fgnorm, PetscViewerAndFormat **dummy, PetscErrorCode *ierr)
446: {
447: *ierr = SNESMonitorSolution(*snes, *its, *fgnorm, *dummy);
448: }
450: PETSC_EXTERN void snesmonitorsolutionupdate_(SNES *snes, PetscInt *its, PetscReal *fgnorm, PetscViewerAndFormat **dummy, PetscErrorCode *ierr)
451: {
452: *ierr = SNESMonitorSolutionUpdate(*snes, *its, *fgnorm, *dummy);
453: }
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: }
473: PETSC_EXTERN void snesviewfromoptions_(SNES *ao, PetscObject obj, char *type, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len)
474: {
475: char *t;
477: FIXCHAR(type, len, t);
478: CHKFORTRANNULLOBJECT(obj);
479: *ierr = SNESViewFromOptions(*ao, obj, t);
480: if (*ierr) return;
481: FREECHAR(type, t);
482: }
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: }
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: }