xref: /petsc/src/snes/interface/ftn-custom/zsnesf.c (revision 62903a643c6f3b806cfd2df6dfd11354dcefb6c2) 
1 #include "zpetsc.h"
2 #include "petscsnes.h"
3 
4 #ifdef PETSC_HAVE_FORTRAN_UNDERSCORE_UNDERSCORE
5 #define snesconverged_tr_                snesconverged_tr__
6 #define snesconverged_ls_                snesconverged_ls__
7 #endif
8 
9 #if defined(PETSC_HAVE_FORTRAN_CAPS)
10 #define snesdefaultcomputejacobian_      SNESDEFAULTCOMPUTEJACOBIAN
11 #define snesdefaultcomputejacobiancolor_ SNESDEFAULTCOMPUTEJACOBIANCOLOR
12 #define snesdacomputejacobian_           SNESDACOMPUTEJACOBIAN
13 #define snesdacomputejacobianwithadifor_ SNESDACOMPUTEJACOBIANWITHADIFOR
14 #define snessetjacobian_                 SNESSETJACOBIAN
15 #define snesgetoptionsprefix_            SNESGETOPTIONSPREFIX
16 #define snesgettype_                     SNESGETTYPE
17 #define snesdaformfunction_              SNESDAFORMFUNCTION
18 #define snessetfunction_                 SNESSETFUNCTION
19 #define snesgetfunction_                 SNESGETFUNCTION
20 #define snessetconvergencetest_          SNESSETCONVERGENCETEST
21 #define snesconverged_tr_                SNESCONVERGED_TR
22 #define snesconverged_ls_                SNESCONVERGED_LS
23 #define snesview_                        SNESVIEW
24 #define snesgetconvergencehistory_       SNESGETCONVERGENCEHISTORY
25 #define snesgetjacobian_                 SNESGETJACOBIAN
26 #define snessettype_                     SNESSETTYPE
27 #define snesappendoptionsprefix_         SNESAPPENDOPTIONSPREFIX
28 #define snessetoptionsprefix_            SNESSETOPTIONSPREFIX
29 #define snesdefaultmonitor_              SNESDEFAULTMONITOR
30 #define snesvecviewmonitor_              SNESVECVIEWMONITOR
31 #define sneslgmonitor_                   SNESLGMONITOR
32 #define snesvecviewupdatemonitor_        SNESVECVIEWUPDATEMONITOR
33 #define snessetmonitor_                  SNESSETMONITOR
34 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
35 #define snesdefaultcomputejacobian_      snesdefaultcomputejacobian
36 #define snesdefaultcomputejacobiancolor_ snesdefaultcomputejacobiancolor
37 #define snesdacomputejacobian_           snesdacomputejacobian
38 #define snesdacomputejacobianwithadifor_ snesdacomputejacobianwithadifor
39 #define snessetjacobian_                 snessetjacobian
40 #define snesgetoptionsprefix_            snesgetoptionsprefix
41 #define snesgettype_                     snesgettype
42 #define snesdaformfunction_              snesdaformfunction
43 #define snessetfunction_                 snessetfunction
44 #define snesgetfunction_                 snesgetfunction
45 #define snessetconvergencetest_          snessetconvergencetest
46 #define snesconverged_tr_                snesconverged_tr
47 #define snesconverged_ls_                snesconverged_ls
48 #define snesview_                        snesview
49 #define snesgetjacobian_                 snesgetjacobian
50 #define snesgetconvergencehistory_       snesgetconvergencehistory
51 #define snessettype_                     snessettype
52 #define snesappendoptionsprefix_         snesappendoptionsprefix
53 #define snessetoptionsprefix_            snessetoptionsprefix
54 #define sneslgmonitor_                   sneslgmonitor
55 #define snesdefaultmonitor_              snesdefaultmonitor
56 #define snesvecviewmonitor_              snesvecviewmonitor
57 #define snesvecviewupdatemonitor_        snesvecviewupdatemonitor
58 #define snessetmonitor_                  snessetmonitor
59 #endif
60 
61 EXTERN_C_BEGIN
62 static void (PETSC_STDCALL *f3)(SNES*,Vec*,Mat*,Mat*,MatStructure*,void*,PetscErrorCode*);
63 static void (PETSC_STDCALL *f2)(SNES*,Vec*,Vec*,void*,PetscErrorCode*);
64 static void (PETSC_STDCALL *f8)(SNES*,PetscReal*,PetscReal*,PetscReal*,SNESConvergedReason*,void*,PetscErrorCode*);
65 static void (PETSC_STDCALL *f7)(SNES*,PetscInt*,PetscReal*,void*,PetscErrorCode*);
66 static void (PETSC_STDCALL *f71)(void*,PetscErrorCode*);
67 EXTERN_C_END
68 
69 static PetscErrorCode oursnesfunction(SNES snes,Vec x,Vec f,void *ctx)
70 {
71   PetscErrorCode ierr = 0;
72   (*f2)(&snes,&x,&f,ctx,&ierr);CHKERRQ(ierr);
73   return 0;
74 }
75 static PetscErrorCode oursnestest(SNES snes,PetscReal a,PetscReal d,PetscReal c,SNESConvergedReason*reason,void*ctx)
76 {
77   PetscErrorCode ierr = 0;
78 
79   (*f8)(&snes,&a,&d,&c,reason,ctx,&ierr);CHKERRQ(ierr);
80   return 0;
81 }
82 
83 static PetscErrorCode oursnesjacobian(SNES snes,Vec x,Mat* m,Mat* p,MatStructure* type,void*ctx)
84 {
85   PetscErrorCode ierr = 0;
86   (*f3)(&snes,&x,m,p,type,ctx,&ierr);CHKERRQ(ierr);
87   return 0;
88 }
89 static PetscErrorCode oursnesmonitor(SNES snes,PetscInt i,PetscReal d,void*ctx)
90 {
91   PetscErrorCode ierr = 0;
92 
93   (*f7)(&snes,&i,&d,ctx,&ierr);CHKERRQ(ierr);
94   return 0;
95 }
96 static PetscErrorCode ourmondestroy(void* ctx)
97 {
98   PetscErrorCode ierr = 0;
99 
100   (*f71)(ctx,&ierr);CHKERRQ(ierr);
101   return 0;
102 }
103 
104 EXTERN_C_BEGIN
105 /* ---------------------------------------------------------*/
106 /*
107      snesdefaultcomputejacobian() and snesdefaultcomputejacobiancolor()
108   These can be used directly from Fortran but are mostly so that
109   Fortran SNESSetJacobian() will properly handle the defaults being passed in.
110 
111   functions, hence no STDCALL
112 */
113 void snesdefaultcomputejacobian_(SNES *snes,Vec *x,Mat *m,Mat *p,MatStructure* type,void *ctx,PetscErrorCode *ierr)
114 {
115   *ierr = SNESDefaultComputeJacobian(*snes,*x,m,p,type,ctx);
116 }
117 void  snesdefaultcomputejacobiancolor_(SNES *snes,Vec *x,Mat *m,Mat *p,MatStructure* type,void *ctx,PetscErrorCode *ierr)
118 {
119   *ierr = SNESDefaultComputeJacobianColor(*snes,*x,m,p,type,*(MatFDColoring*)ctx);
120 }
121 
122 void  snesdacomputejacobianwithadifor_(SNES *snes,Vec *X,Mat *m,Mat *p,MatStructure* type,void *ctx,PetscErrorCode *ierr)
123 {
124   (*PetscErrorPrintf)("Cannot call this function from Fortran");
125   *ierr = 1;
126 }
127 
128 void  snesdacomputejacobian_(SNES *snes,Vec *X,Mat *m,Mat *p,MatStructure* type,void *ctx,PetscErrorCode *ierr)
129 {
130   (*PetscErrorPrintf)("Cannot call this function from Fortran");
131   *ierr = 1;
132 }
133 
134 void PETSC_STDCALL snessetjacobian_(SNES *snes,Mat *A,Mat *B,void (PETSC_STDCALL *func)(SNES*,Vec*,Mat*,Mat*,
135             MatStructure*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr)
136 {
137   CHKFORTRANNULLOBJECT(ctx);
138   if ((FCNVOID)func == (FCNVOID)snesdefaultcomputejacobian_) {
139     *ierr = SNESSetJacobian(*snes,*A,*B,SNESDefaultComputeJacobian,ctx);
140   } else if ((FCNVOID)func == (FCNVOID)snesdefaultcomputejacobiancolor_) {
141     *ierr = SNESSetJacobian(*snes,*A,*B,SNESDefaultComputeJacobianColor,*(MatFDColoring*)ctx);
142   } else if ((FCNVOID)func == (FCNVOID)snesdacomputejacobianwithadifor_) {
143     *ierr = SNESSetJacobian(*snes,*A,*B,SNESDAComputeJacobianWithAdifor,ctx);
144   } else if ((FCNVOID)func == (FCNVOID)snesdacomputejacobian_) {
145     *ierr = SNESSetJacobian(*snes,*A,*B,SNESDAComputeJacobian,ctx);
146   } else {
147     f3 = func;
148     *ierr = SNESSetJacobian(*snes,*A,*B,oursnesjacobian,ctx);
149   }
150 }
151 /* -------------------------------------------------------------*/
152 
153 void PETSC_STDCALL snesgetoptionsprefix_(SNES *snes,CHAR prefix PETSC_MIXED_LEN(len),
154                                          PetscErrorCode *ierr PETSC_END_LEN(len))
155 {
156   const char *tname;
157 
158   *ierr = SNESGetOptionsPrefix(*snes,&tname);
159 #if defined(PETSC_USES_CPTOFCD)
160   {
161     char *t = _fcdtocp(prefix); int len1 = _fcdlen(prefix);
162     *ierr = PetscStrncpy(t,tname,len1);if (*ierr) return;
163   }
164 #else
165   *ierr = PetscStrncpy(prefix,tname,len);if (*ierr) return;
166 #endif
167 }
168 
169 void PETSC_STDCALL snesgettype_(SNES *snes,CHAR name PETSC_MIXED_LEN(len),
170                                 PetscErrorCode *ierr PETSC_END_LEN(len))
171 {
172   const char *tname;
173 
174   *ierr = SNESGetType(*snes,&tname);
175 #if defined(PETSC_USES_CPTOFCD)
176   {
177     char *t = _fcdtocp(name); int len1 = _fcdlen(name);
178     *ierr = PetscStrncpy(t,tname,len1);if (*ierr) return;
179   }
180 #else
181   *ierr = PetscStrncpy(name,tname,len);if (*ierr) return;
182 #endif
183   FIXRETURNCHAR(name,len);
184 }
185 /* ---------------------------------------------------------*/
186 
187 /*
188         These are not usually called from Fortran but allow Fortran users
189    to transparently set these monitors from .F code
190 
191    functions, hence no STDCALL
192 */
193 void  snesdaformfunction_(SNES *snes,Vec *X, Vec *F,void *ptr,PetscErrorCode *ierr)
194 {
195   *ierr = SNESDAFormFunction(*snes,*X,*F,ptr);
196 }
197 
198 void PETSC_STDCALL snessetfunction_(SNES *snes,Vec *r,void (PETSC_STDCALL *func)(SNES*,Vec*,Vec*,void*,PetscErrorCode*),
199                       void *ctx,PetscErrorCode *ierr)
200 {
201   CHKFORTRANNULLOBJECT(ctx);
202   f2 = func;
203   if ((FCNVOID)func == (FCNVOID)snesdaformfunction_) {
204     *ierr = SNESSetFunction(*snes,*r,SNESDAFormFunction,ctx);
205   } else {
206     *ierr = SNESSetFunction(*snes,*r,oursnesfunction,ctx);
207   }
208 }
209 /* ---------------------------------------------------------*/
210 
211 /* the func argument is ignored */
212 void PETSC_STDCALL snesgetfunction_(SNES *snes,Vec *r,void *func,void **ctx,PetscErrorCode *ierr)
213 {
214   CHKFORTRANNULLINTEGER(ctx);
215   CHKFORTRANNULLOBJECT(r);
216   *ierr = SNESGetFunction(*snes,r,PETSC_NULL,ctx);
217 }
218 /*----------------------------------------------------------------------*/
219 
220 void snesconverged_tr_(SNES *snes,PetscReal *a,PetscReal *b,PetscReal *c,SNESConvergedReason *r,
221                                        void *ct,PetscErrorCode *ierr)
222 {
223   *ierr = SNESConverged_TR(*snes,*a,*b,*c,r,ct);
224 }
225 
226 void snesconverged_ls_(SNES *snes,PetscReal *a,PetscReal *b,PetscReal *c,SNESConvergedReason *r,
227                                        void *ct,PetscErrorCode *ierr)
228 {
229   *ierr = SNESConverged_LS(*snes,*a,*b,*c,r,ct);
230 }
231 
232 
233 void PETSC_STDCALL snessetconvergencetest_(SNES *snes,
234        void (PETSC_STDCALL *func)(SNES*,PetscReal*,PetscReal*,PetscReal*,SNESConvergedReason*,void*,PetscErrorCode*),
235        void *cctx,PetscErrorCode *ierr)
236 {
237   CHKFORTRANNULLOBJECT(cctx);
238   if ((FCNVOID)func == (FCNVOID)snesconverged_ls_){
239     *ierr = SNESSetConvergenceTest(*snes,SNESConverged_LS,0);
240   } else if ((FCNVOID)func == (FCNVOID)snesconverged_tr_){
241     *ierr = SNESSetConvergenceTest(*snes,SNESConverged_TR,0);
242   } else {
243     f8 = func;
244     *ierr = SNESSetConvergenceTest(*snes,oursnestest,cctx);
245   }
246 }
247 /*----------------------------------------------------------------------*/
248 
249 void PETSC_STDCALL snesview_(SNES *snes,PetscViewer *viewer, PetscErrorCode *ierr)
250 {
251   PetscViewer v;
252   PetscPatchDefaultViewers_Fortran(viewer,v);
253   *ierr = SNESView(*snes,v);
254 }
255 
256 /*  func is currently ignored from Fortran */
257 void PETSC_STDCALL snesgetjacobian_(SNES *snes,Mat *A,Mat *B,int *func,void **ctx,PetscErrorCode *ierr)
258 {
259   CHKFORTRANNULLINTEGER(ctx);
260   CHKFORTRANNULLOBJECT(A);
261   CHKFORTRANNULLOBJECT(B);
262   *ierr = SNESGetJacobian(*snes,A,B,0,ctx);
263 }
264 
265 void PETSC_STDCALL snesgetconvergencehistory_(SNES *snes,PetscInt *na,PetscErrorCode *ierr)
266 {
267   *ierr = SNESGetConvergenceHistory(*snes,PETSC_NULL,PETSC_NULL,na);
268 }
269 
270 void PETSC_STDCALL snessettype_(SNES *snes,CHAR type PETSC_MIXED_LEN(len),
271                                 PetscErrorCode *ierr PETSC_END_LEN(len))
272 {
273   char *t;
274 
275   FIXCHAR(type,len,t);
276   *ierr = SNESSetType(*snes,t);
277   FREECHAR(type,t);
278 }
279 
280 void PETSC_STDCALL snesappendoptionsprefix_(SNES *snes,CHAR prefix PETSC_MIXED_LEN(len),
281                                             PetscErrorCode *ierr PETSC_END_LEN(len))
282 {
283   char *t;
284 
285   FIXCHAR(prefix,len,t);
286   *ierr = SNESAppendOptionsPrefix(*snes,t);
287   FREECHAR(prefix,t);
288 }
289 
290 void PETSC_STDCALL snessetoptionsprefix_(SNES *snes,CHAR prefix PETSC_MIXED_LEN(len),
291                                         PetscErrorCode *ierr PETSC_END_LEN(len))
292 {
293   char *t;
294 
295   FIXCHAR(prefix,len,t);
296   *ierr = SNESSetOptionsPrefix(*snes,t);
297   FREECHAR(prefix,t);
298 }
299 
300 /*----------------------------------------------------------------------*/
301 /* functions, hence no STDCALL */
302 
303 void sneslgmonitor_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr)
304 {
305   *ierr = SNESLGMonitor(*snes,*its,*fgnorm,dummy);
306 }
307 
308 void snesdefaultmonitor_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr)
309 {
310   *ierr = SNESDefaultMonitor(*snes,*its,*fgnorm,dummy);
311 }
312 
313 void snesvecviewmonitor_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr)
314 {
315   *ierr = SNESVecViewMonitor(*snes,*its,*fgnorm,dummy);
316 }
317 
318 void snesvecviewupdatemonitor_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr)
319 {
320   *ierr = SNESVecViewUpdateMonitor(*snes,*its,*fgnorm,dummy);
321 }
322 
323 
324 void PETSC_STDCALL snessetmonitor_(SNES *snes,void (PETSC_STDCALL *func)(SNES*,PetscInt*,PetscReal*,void*,PetscErrorCode*),
325                     void *mctx,void (PETSC_STDCALL *mondestroy)(void*,PetscErrorCode*),PetscErrorCode *ierr)
326 {
327   CHKFORTRANNULLOBJECT(mctx);
328   if ((FCNVOID)func == (FCNVOID)snesdefaultmonitor_) {
329     *ierr = SNESSetMonitor(*snes,SNESDefaultMonitor,0,0);
330   } else if ((FCNVOID)func == (FCNVOID)snesvecviewmonitor_) {
331     *ierr = SNESSetMonitor(*snes,SNESVecViewMonitor,0,0);
332   } else if ((FCNVOID)func == (FCNVOID)snesvecviewupdatemonitor_) {
333     *ierr = SNESSetMonitor(*snes,SNESVecViewUpdateMonitor,0,0);
334   } else if ((FCNVOID)func == (FCNVOID)sneslgmonitor_) {
335     *ierr = SNESSetMonitor(*snes,SNESLGMonitor,0,0);
336   } else {
337     f7 = func;
338     if (FORTRANNULLFUNCTION(mondestroy)){
339       *ierr = SNESSetMonitor(*snes,oursnesmonitor,mctx,0);
340     } else {
341       f71 = mondestroy;
342       *ierr = SNESSetMonitor(*snes,oursnesmonitor,mctx,ourmondestroy);
343     }
344   }
345 }
346 
347 
348 
349 EXTERN_C_END
350