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, 221 void (*func)(SNES*,Vec*,Mat*,Mat*,void*,PetscErrorCode*), 222 void *ctx,PetscErrorCode *ierr) 223 { 224 CHKFORTRANNULLFUNCTION(func); 225 if ((PetscVoidFunction)func == (PetscVoidFunction)snescomputejacobiandefault_) { 226 *ierr = SNESSetJacobian(*snes,*A,*B,SNESComputeJacobianDefault,ctx); 227 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snescomputejacobiandefaultcolor_) { 228 if (!ctx) { 229 *ierr = PETSC_ERR_ARG_NULL; 230 return; 231 } 232 *ierr = SNESSetJacobian(*snes,*A,*B,SNESComputeJacobianDefaultColor,*(MatFDColoring*)ctx); 233 } else if ((PetscVoidFunction)func == (PetscVoidFunction)matmffdcomputejacobian_) { 234 *ierr = SNESSetJacobian(*snes,*A,*B,MatMFFDComputeJacobian,ctx); 235 } else { 236 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.jacobian,(PetscVoidFunction)func,ctx); 237 if (!*ierr) *ierr = SNESSetJacobian(*snes,*A,*B,oursnesjacobian,NULL); 238 } 239 } 240 PETSC_EXTERN void snessetjacobian1_(SNES *snes,Mat *A,Mat *B, 241 void (*func)(SNES*,Vec*,Mat*,Mat*,void*,PetscErrorCode*), 242 void *ctx,PetscErrorCode *ierr) 243 { 244 snessetjacobian_(snes,A,B,func,ctx,ierr); 245 } 246 PETSC_EXTERN void snessetjacobian2_(SNES *snes,Mat *A,Mat *B, 247 void (*func)(SNES*,Vec*,Mat*,Mat*,void*,PetscErrorCode*), 248 void *ctx,PetscErrorCode *ierr) 249 { 250 snessetjacobian_(snes,A,B,func,ctx,ierr); 251 } 252 253 static PetscErrorCode oursnespicardfunction(SNES snes, Vec x, Vec f, void *ctx) 254 { 255 #if defined(PETSC_HAVE_F90_2PTR_ARG) 256 void *ptr; 257 PetscCall(PetscObjectGetFortranCallback((PetscObject)snes, PETSC_FORTRAN_CALLBACK_CLASS, _cb.function_pgiptr, NULL, &ptr)); 258 #endif 259 PetscObjectUseFortranCallback(snes, _cb.function, (SNES *, Vec *, Vec *, void *, PetscErrorCode *PETSC_F90_2PTR_PROTO_NOVAR), (&snes, &x, &f, _ctx, &ierr PETSC_F90_2PTR_PARAM(ptr))); 260 } 261 262 static PetscErrorCode oursnespicardjacobian(SNES snes,Vec x,Mat m,Mat p,void *ctx) 263 { 264 PetscObjectUseFortranCallback(snes,_cb.jacobian,(SNES*,Vec*,Mat*,Mat*,void*,PetscErrorCode*),(&snes,&x,&m,&p,_ctx,&ierr)); 265 } 266 267 PETSC_EXTERN void snessetpicard_(SNES *snes,Vec *r,void (*func)(SNES*,Vec*,Vec *,void*,PetscErrorCode*),Mat *A,Mat *B, 268 PetscErrorCode (*J)(SNES,Vec,Mat,Mat,void*),void *ctx,PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 269 { 270 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.function,(PetscVoidFunction)func,ctx); 271 #if defined(PETSC_HAVE_F90_2PTR_ARG) 272 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.function_pgiptr,NULL,ptr);if (*ierr) return; 273 #endif 274 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.jacobian,(PetscVoidFunction)J,ctx); 275 if (!*ierr) *ierr = SNESSetPicard(*snes,*r,oursnespicardfunction,*A,*B,oursnespicardjacobian,NULL); 276 } 277 278 PETSC_EXTERN void snesgetoptionsprefix_(SNES *snes,char* prefix,PetscErrorCode *ierr,PETSC_FORTRAN_CHARLEN_T len) 279 { 280 const char *tname; 281 282 *ierr = SNESGetOptionsPrefix(*snes,&tname); 283 *ierr = PetscStrncpy(prefix,tname,len);if (*ierr) return; 284 FIXRETURNCHAR(PETSC_TRUE,prefix,len); 285 } 286 287 PETSC_EXTERN void snesgettype_(SNES *snes,char* name, PetscErrorCode *ierr,PETSC_FORTRAN_CHARLEN_T len) 288 { 289 const char *tname; 290 291 *ierr = SNESGetType(*snes,&tname); 292 *ierr = PetscStrncpy(name,tname,len);if (*ierr) return; 293 FIXRETURNCHAR(PETSC_TRUE,name,len); 294 } 295 296 /* 297 These are not usually called from Fortran but allow Fortran users 298 to transparently set these monitors from .F code 299 */ 300 301 PETSC_EXTERN void snessetfunction_(SNES *snes,Vec *r,void (*func)(SNES*,Vec*,Vec*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 302 { 303 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.function,(PetscVoidFunction)func,ctx);if (*ierr) return; 304 #if defined(PETSC_HAVE_F90_2PTR_ARG) 305 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.function_pgiptr,NULL,ptr);if (*ierr) return; 306 #endif 307 *ierr = SNESSetFunction(*snes,*r,oursnesfunction,NULL); 308 } 309 310 PETSC_EXTERN void snessetngs_(SNES *snes,void (*func)(SNES*,Vec*,Vec*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr) 311 { 312 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.ngs,(PetscVoidFunction)func,ctx);if (*ierr) return; 313 *ierr = SNESSetNGS(*snes,oursnesngs,NULL); 314 } 315 PETSC_EXTERN void snessetupdate_(SNES *snes,void (*func)(SNES*,PetscInt*,PetscErrorCode*),PetscErrorCode *ierr) 316 { 317 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.update,(PetscVoidFunction)func,NULL);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); if (*ierr) return; 326 if ((PetscVoidFunction)func == (PetscVoidFunction)PETSC_NULL_FUNCTION_Fortran) return; 327 *ierr = PetscObjectGetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,_cb.function,NULL,ctx); 328 } 329 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 *snes,PetscInt *it,PetscReal *a,PetscReal *b,PetscReal *c,SNESConvergedReason *r, void *ct,PetscErrorCode *ierr) 336 { 337 *ierr = SNESConvergedDefault(*snes,*it,*a,*b,*c,r,ct); 338 } 339 340 PETSC_EXTERN void snesconvergedskip_(SNES *snes,PetscInt *it,PetscReal *a,PetscReal *b,PetscReal *c,SNESConvergedReason *r,void *ct,PetscErrorCode *ierr) 341 { 342 *ierr = SNESConvergedSkip(*snes,*it,*a,*b,*c,r,ct); 343 } 344 345 PETSC_EXTERN void snessetconvergencetest_(SNES *snes,void (*func)(SNES*,PetscInt*,PetscReal*,PetscReal*,PetscReal*,SNESConvergedReason*,void*,PetscErrorCode*), void *cctx,void (*destroy)(void*),PetscErrorCode *ierr) 346 { 347 CHKFORTRANNULLFUNCTION(destroy); 348 349 if ((PetscVoidFunction)func == (PetscVoidFunction)snesconvergeddefault_) { 350 *ierr = SNESSetConvergenceTest(*snes,SNESConvergedDefault,0,0); 351 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesconvergedskip_) { 352 *ierr = SNESSetConvergenceTest(*snes,SNESConvergedSkip,0,0); 353 } else { 354 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.test,(PetscVoidFunction)func,cctx);if (*ierr) return; 355 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.destroy,(PetscVoidFunction)destroy,cctx);if (*ierr) return; 356 *ierr = SNESSetConvergenceTest(*snes,oursnestest,*snes,ourdestroy); 357 } 358 } 359 360 PETSC_EXTERN void snesview_(SNES *snes,PetscViewer *viewer, PetscErrorCode *ierr) 361 { 362 PetscViewer v; 363 PetscPatchDefaultViewers_Fortran(viewer,v); 364 *ierr = SNESView(*snes,v); 365 } 366 367 /* func is currently ignored from Fortran */ 368 PETSC_EXTERN void snesgetjacobian_(SNES *snes,Mat *A,Mat *B,int *func,void **ctx,PetscErrorCode *ierr) 369 { 370 CHKFORTRANNULLINTEGER(ctx); 371 CHKFORTRANNULLOBJECT(A); 372 CHKFORTRANNULLOBJECT(B); 373 *ierr = SNESGetJacobian(*snes,A,B,0,NULL); if (*ierr) return; 374 *ierr = PetscObjectGetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,_cb.jacobian,NULL,ctx); 375 376 } 377 378 PETSC_EXTERN void snesgetconvergencehistory_(SNES *snes,PetscInt *na,PetscErrorCode *ierr) 379 { 380 *ierr = SNESGetConvergenceHistory(*snes,NULL,NULL,na); 381 } 382 383 PETSC_EXTERN void snessettype_(SNES *snes,char* type,PetscErrorCode *ierr,PETSC_FORTRAN_CHARLEN_T len) 384 { 385 char *t; 386 387 FIXCHAR(type,len,t); 388 *ierr = SNESSetType(*snes,t);if (*ierr) return; 389 FREECHAR(type,t); 390 } 391 392 PETSC_EXTERN void snesappendoptionsprefix_(SNES *snes,char* prefix,PetscErrorCode *ierr,PETSC_FORTRAN_CHARLEN_T len) 393 { 394 char *t; 395 396 FIXCHAR(prefix,len,t); 397 *ierr = SNESAppendOptionsPrefix(*snes,t);if (*ierr) return; 398 FREECHAR(prefix,t); 399 } 400 401 PETSC_EXTERN void snessetoptionsprefix_(SNES *snes,char* prefix,PetscErrorCode *ierr,PETSC_FORTRAN_CHARLEN_T len) 402 { 403 char *t; 404 405 FIXCHAR(prefix,len,t); 406 *ierr = SNESSetOptionsPrefix(*snes,t);if (*ierr) return; 407 FREECHAR(prefix,t); 408 } 409 410 PETSC_EXTERN void snesmonitordefault_(SNES *snes,PetscInt *its,PetscReal *fgnorm,PetscViewerAndFormat **dummy,PetscErrorCode *ierr) 411 { 412 *ierr = SNESMonitorDefault(*snes,*its,*fgnorm,*dummy); 413 } 414 415 PETSC_EXTERN void snesmonitorsolution_(SNES *snes,PetscInt *its,PetscReal *fgnorm,PetscViewerAndFormat **dummy,PetscErrorCode *ierr) 416 { 417 *ierr = SNESMonitorSolution(*snes,*its,*fgnorm,*dummy); 418 } 419 420 PETSC_EXTERN void snesmonitorsolutionupdate_(SNES *snes,PetscInt *its,PetscReal *fgnorm,PetscViewerAndFormat **dummy,PetscErrorCode *ierr) 421 { 422 *ierr = SNESMonitorSolutionUpdate(*snes,*its,*fgnorm,*dummy); 423 } 424 425 PETSC_EXTERN void snesmonitorset_(SNES *snes,void (*func)(SNES*,PetscInt*,PetscReal*,void*,PetscErrorCode*),void *mctx,void (*mondestroy)(void*,PetscErrorCode*),PetscErrorCode *ierr) 426 { 427 CHKFORTRANNULLFUNCTION(mondestroy); 428 if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitordefault_) { 429 *ierr = SNESMonitorSet(*snes,(PetscErrorCode (*)(SNES,PetscInt,PetscReal,void*))SNESMonitorDefault,*(PetscViewerAndFormat**)mctx,(PetscErrorCode (*)(void **))PetscViewerAndFormatDestroy); 430 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitorsolution_) { 431 *ierr = SNESMonitorSet(*snes,(PetscErrorCode (*)(SNES,PetscInt,PetscReal,void*))SNESMonitorSolution,*(PetscViewerAndFormat**)mctx,(PetscErrorCode (*)(void **))PetscViewerAndFormatDestroy); 432 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitorsolutionupdate_) { 433 *ierr = SNESMonitorSet(*snes,(PetscErrorCode (*)(SNES,PetscInt,PetscReal,void*))SNESMonitorSolutionUpdate,*(PetscViewerAndFormat**)mctx,(PetscErrorCode (*)(void **))PetscViewerAndFormatDestroy); 434 } else { 435 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.monitor,(PetscVoidFunction)func,mctx);if (*ierr) return; 436 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.mondestroy,(PetscVoidFunction)mondestroy,mctx);if (*ierr) return; 437 *ierr = SNESMonitorSet(*snes,oursnesmonitor,*snes,ourmondestroy); 438 } 439 } 440 441 PETSC_EXTERN void snesviewfromoptions_(SNES *ao,PetscObject obj,char* type,PetscErrorCode *ierr,PETSC_FORTRAN_CHARLEN_T len) 442 { 443 char *t; 444 445 FIXCHAR(type,len,t); 446 CHKFORTRANNULLOBJECT(obj); 447 *ierr = SNESViewFromOptions(*ao,obj,t);if (*ierr) return; 448 FREECHAR(type,t); 449 } 450 451 PETSC_EXTERN void snesconvergedreasonview_(SNES *snes,PetscViewer *viewer, PetscErrorCode *ierr) 452 { 453 PetscViewer v; 454 PetscPatchDefaultViewers_Fortran(viewer,v); 455 *ierr = SNESConvergedReasonView(*snes,v); 456 } 457 458 PETSC_EXTERN void snesgetconvergedreasonstring_(SNES *snes, char* strreason, PetscErrorCode *ierr, PETSC_FORTRAN_CHARLEN_T len) 459 { 460 const char *tstrreason; 461 *ierr = SNESGetConvergedReasonString(*snes,&tstrreason); 462 *ierr = PetscStrncpy(strreason,tstrreason,len);if (*ierr) return; 463 FIXRETURNCHAR(PETSC_TRUE,strreason,len); 464 } 465