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
ourtrprecheckfunction(SNES snes,Vec x,Vec y,PetscBool * changed_y,PetscCtx ctx)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
snesnewtontrsetprecheck_(SNES * snes,void (* func)(SNES,Vec,Vec,PetscBool *,void *),PetscCtx ctx,PetscErrorCode * ierr PETSC_F90_2PTR_PROTO (ptr))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
snesnewtontrdcsetprecheck_(SNES * snes,void (* func)(SNES,Vec,Vec,PetscBool *,void *),PetscCtx ctx,PetscErrorCode * ierr PETSC_F90_2PTR_PROTO (ptr))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
ourtrpostcheckfunction(SNES snes,Vec x,Vec y,Vec w,PetscBool * changed_y,PetscBool * changed_w,PetscCtx ctx)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
snesnewtontrsetpostcheck_(SNES * snes,void (* func)(SNES,Vec,Vec,Vec,PetscBool *,PetscBool *,void *),PetscCtx ctx,PetscErrorCode * ierr PETSC_F90_2PTR_PROTO (ptr))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
snesnewtontrdcsetpostcheck_(SNES * snes,void (* func)(SNES,Vec,Vec,Vec,PetscBool *,PetscBool *,void *),PetscCtx ctx,PetscErrorCode * ierr PETSC_F90_2PTR_PROTO (ptr))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
oursnesfunction(SNES snes,Vec x,Vec f,PetscCtx ctx)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
oursnesobjective(SNES snes,Vec x,PetscReal * v,PetscCtx ctx)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
oursnestest(SNES snes,PetscInt it,PetscReal a,PetscReal d,PetscReal c,SNESConvergedReason * reason,PetscCtx ctx)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
ourdestroy(PetscCtxRt ctx)171 static PetscErrorCode ourdestroy(PetscCtxRt ctx)
172 {
173 PetscObjectUseFortranCallback(ctx, _cb.destroy, (void *, PetscErrorCode *), (_ctx, &ierr));
174 }
175
oursnesjacobian(SNES snes,Vec x,Mat m,Mat p,PetscCtx ctx)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
oursnesupdate(SNES snes,PetscInt i)181 static PetscErrorCode oursnesupdate(SNES snes, PetscInt i)
182 {
183 PetscObjectUseFortranCallback(snes, _cb.update, (SNES *, PetscInt *, PetscErrorCode *), (&snes, &i, &ierr));
184 }
oursnesngs(SNES snes,Vec x,Vec b,PetscCtx ctx)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 }
oursnesmonitor(SNES snes,PetscInt i,PetscReal d,PetscCtx ctx)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 }
ourmondestroy(PetscCtxRt ctx)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
snessetjacobian_(SNES * snes,Mat * A,Mat * B,void (* func)(SNES *,Vec *,Mat *,Mat *,void *,PetscErrorCode *),PetscCtx ctx,PetscErrorCode * ierr PETSC_F90_2PTR_PROTO (ptr))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
snessetjacobiannointerface_(SNES * snes,Mat * A,Mat * B,void (* func)(SNES *,Vec *,Mat *,Mat *,void *,PetscErrorCode *),PetscCtx ctx,PetscErrorCode * ierr PETSC_F90_2PTR_PROTO (ptr))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 */
snesgetjacobian_(SNES * snes,Mat * A,Mat * B,int * func,void ** ctx,PetscErrorCode * ierr)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
oursnespicardfunction(SNES snes,Vec x,Vec f,PetscCtx ctx)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
oursnespicardjacobian(SNES snes,Vec x,Mat m,Mat p,PetscCtx ctx)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
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))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
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))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
snessetfunction_(SNES * snes,Vec * r,void (* func)(SNES,Vec,Vec,void *,PetscErrorCode *),PetscCtx ctx,PetscErrorCode * ierr PETSC_F90_2PTR_PROTO (ptr))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
snessetfunctionnointerface_(SNES * snes,Vec * r,void (* func)(SNES,Vec,Vec,void *,PetscErrorCode *),PetscCtx ctx,PetscErrorCode * ierr PETSC_F90_2PTR_PROTO (ptr))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
snessetobjective_(SNES * snes,SNESObjectiveFn func,PetscCtx ctx,PetscErrorCode * ierr PETSC_F90_2PTR_PROTO (ptr))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
snessetobjectivenointerface_(SNES * snes,SNESObjectiveFn func,PetscCtx ctx,PetscErrorCode * ierr PETSC_F90_2PTR_PROTO (ptr))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
snessetngs_(SNES * snes,void (* func)(SNES *,Vec *,Vec *,void *,PetscErrorCode *),PetscCtx ctx,PetscErrorCode * ierr)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 }
snessetupdate_(SNES * snes,void (* func)(SNES *,PetscInt *,PetscErrorCode *),PetscErrorCode * ierr)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 */
snesgetfunction_(SNES * snes,Vec * r,void (* func)(SNES,Vec,Vec,void *,PetscErrorCode *),void ** ctx,PetscErrorCode * ierr)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
snesgetngs_(SNES * snes,void * func,void ** ctx,PetscErrorCode * ierr)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
snessetconvergencetest_(SNES * snes,void (* func)(SNES *,PetscInt *,PetscReal *,PetscReal *,PetscReal *,SNESConvergedReason *,void *,PetscErrorCode *),void * cctx,PetscCtxDestroyFn * destroy,PetscErrorCode * ierr)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
snesmonitorset_(SNES * snes,void (* func)(SNES *,PetscInt *,PetscReal *,void *,PetscErrorCode *),void * mctx,void (* mondestroy)(void *,PetscErrorCode *),PetscErrorCode * ierr)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