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 matmffdcomputejacobian_ MATMFFDCOMPUTEJACOBIAN 8 #define snessolve_ SNESSOLVE 9 #define snescomputejacobiandefault_ SNESCOMPUTEJACOBIANDEFAULT 10 #define snescomputejacobiandefaultcolor_ SNESCOMPUTEJACOBIANDEFAULTCOLOR 11 #define snessetjacobian_ SNESSETJACOBIAN 12 #define snesgetoptionsprefix_ SNESGETOPTIONSPREFIX 13 #define snesgettype_ SNESGETTYPE 14 #define snessetfunction_ SNESSETFUNCTION 15 #define snessetngs_ SNESSETNGS 16 #define snessetupdate_ SNESSETUPDATE 17 #define snesgetfunction_ SNESGETFUNCTION 18 #define snesgetngs_ SNESGETNGS 19 #define snessetconvergencetest_ SNESSETCONVERGENCETEST 20 #define snesconvergeddefault_ SNESCONVERGEDDEFAULT 21 #define snesconvergedskip_ SNESCONVERGEDSKIP 22 #define snesview_ SNESVIEW 23 #define snesgetconvergencehistory_ SNESGETCONVERGENCEHISTORY 24 #define snesgetjacobian_ SNESGETJACOBIAN 25 #define snessettype_ SNESSETTYPE 26 #define snesappendoptionsprefix_ SNESAPPENDOPTIONSPREFIX 27 #define snessetoptionsprefix_ SNESSETOPTIONSPREFIX 28 #define snesmonitordefault_ SNESMONITORDEFAULT 29 #define snesmonitorsolution_ SNESMONITORSOLUTION 30 #define snesmonitorlgresidualnorm_ SNESMONITORLGRESIDUALNORM 31 #define snesmonitorsolutionupdate_ SNESMONITORSOLUTIONUPDATE 32 #define snesmonitorset_ SNESMONITORSET 33 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 34 #define matmffdcomputejacobian_ matmffdcomputejacobian 35 #define snessolve_ snessolve 36 #define snescomputejacobiandefault_ snescomputejacobiandefault 37 #define snescomputejacobiandefaultcolor_ snescomputejacobiandefaultcolor 38 #define snessetjacobian_ snessetjacobian 39 #define snesgetoptionsprefix_ snesgetoptionsprefix 40 #define snesgettype_ snesgettype 41 #define snessetfunction_ snessetfunction 42 #define snessetngs_ snessetngs 43 #define snessetupdate_ snessetupdate 44 #define snesgetfunction_ snesgetfunction 45 #define snesgetngs_ snesgetngs 46 #define snessetconvergencetest_ snessetconvergencetest 47 #define snesconvergeddefault_ snesconvergeddefault 48 #define snesconvergedskip_ snesconvergedskip 49 #define snesview_ snesview 50 #define snesgetjacobian_ snesgetjacobian 51 #define snesgetconvergencehistory_ snesgetconvergencehistory 52 #define snessettype_ snessettype 53 #define snesappendoptionsprefix_ snesappendoptionsprefix 54 #define snessetoptionsprefix_ snessetoptionsprefix 55 #define snesmonitorlgresidualnorm_ snesmonitorlgresidualnorm 56 #define snesmonitordefault_ snesmonitordefault 57 #define snesmonitorsolution_ snesmonitorsolution 58 #define snesmonitorsolutionupdate_ snesmonitorsolutionupdate 59 #define snesmonitorset_ snesmonitorset 60 #endif 61 62 static struct { 63 PetscFortranCallbackId function; 64 PetscFortranCallbackId test; 65 PetscFortranCallbackId destroy; 66 PetscFortranCallbackId jacobian; 67 PetscFortranCallbackId monitor; 68 PetscFortranCallbackId mondestroy; 69 PetscFortranCallbackId ngs; 70 PetscFortranCallbackId update; 71 #if defined(PETSC_HAVE_F90_2PTR_ARG) 72 PetscFortranCallbackId function_pgiptr; 73 #endif 74 } _cb; 75 76 static PetscErrorCode oursnesfunction(SNES snes,Vec x,Vec f,void *ctx) 77 { 78 #if defined(PETSC_HAVE_F90_2PTR_ARG) 79 void* ptr; 80 PetscObjectGetFortranCallback((PetscObject)snes,PETSC_FORTRAN_CALLBACK_CLASS,_cb.function_pgiptr,NULL,&ptr); 81 #endif 82 PetscObjectUseFortranCallback(snes,_cb.function,(SNES*,Vec*,Vec*,void*,PetscErrorCode* PETSC_F90_2PTR_PROTO_NOVAR),(&snes,&x,&f,_ctx,&ierr PETSC_F90_2PTR_PARAM(ptr))); 83 } 84 85 static PetscErrorCode oursnestest(SNES snes,PetscInt it,PetscReal a,PetscReal d,PetscReal c,SNESConvergedReason *reason,void *ctx) 86 { 87 PetscObjectUseFortranCallback(snes,_cb.test,(SNES*,PetscInt*,PetscReal*,PetscReal*,PetscReal*,SNESConvergedReason*,void*,PetscErrorCode*),(&snes,&it,&a,&d,&c,reason,_ctx,&ierr)); 88 } 89 90 static PetscErrorCode ourdestroy(void *ctx) 91 { 92 PetscObjectUseFortranCallback(ctx,_cb.destroy,(void*,PetscErrorCode*),(_ctx,&ierr)); 93 } 94 95 static PetscErrorCode oursnesjacobian(SNES snes,Vec x,Mat m,Mat p,void *ctx) 96 { 97 PetscObjectUseFortranCallback(snes,_cb.jacobian,(SNES*,Vec*,Mat*,Mat*,void*,PetscErrorCode*),(&snes,&x,&m,&p,_ctx,&ierr)); 98 } 99 100 static PetscErrorCode oursnesupdate(SNES snes,PetscInt i) 101 { 102 PetscObjectUseFortranCallback(snes,_cb.update,(SNES*,PetscInt *,PetscErrorCode*),(&snes,&i,&ierr)); 103 } 104 static PetscErrorCode oursnesngs(SNES snes,Vec x,Vec b,void *ctx) 105 { 106 PetscObjectUseFortranCallback(snes,_cb.ngs,(SNES*,Vec*,Vec*,void*,PetscErrorCode*),(&snes,&x,&b,_ctx,&ierr)); 107 } 108 static PetscErrorCode oursnesmonitor(SNES snes,PetscInt i,PetscReal d,void *ctx) 109 { 110 PetscObjectUseFortranCallback(snes,_cb.monitor,(SNES*,PetscInt*,PetscReal*,void*,PetscErrorCode*),(&snes,&i,&d,_ctx,&ierr)); 111 } 112 static PetscErrorCode ourmondestroy(void **ctx) 113 { 114 SNES snes = (SNES)*ctx; 115 PetscObjectUseFortranCallback(snes,_cb.mondestroy,(void*,PetscErrorCode*),(_ctx,&ierr)); 116 } 117 118 /* ---------------------------------------------------------*/ 119 /* 120 snescomputejacobiandefault() and snescomputejacobiandefaultcolor() 121 These can be used directly from Fortran but are mostly so that 122 Fortran SNESSetJacobian() will properly handle the defaults being passed in. 123 124 functions, hence no STDCALL 125 */ 126 PETSC_EXTERN void matmffdcomputejacobian_(SNES *snes,Vec *x,Mat *m,Mat *p,void *ctx,PetscErrorCode *ierr) 127 { 128 *ierr = MatMFFDComputeJacobian(*snes,*x,*m,*p,ctx); 129 } 130 PETSC_EXTERN void snescomputejacobiandefault_(SNES *snes,Vec *x,Mat *m,Mat *p,void *ctx,PetscErrorCode *ierr) 131 { 132 *ierr = SNESComputeJacobianDefault(*snes,*x,*m,*p,ctx); 133 } 134 PETSC_EXTERN void snescomputejacobiandefaultcolor_(SNES *snes,Vec *x,Mat *m,Mat *p,void *ctx,PetscErrorCode *ierr) 135 { 136 *ierr = SNESComputeJacobianDefaultColor(*snes,*x,*m,*p,*(MatFDColoring*)ctx); 137 } 138 139 PETSC_EXTERN void PETSC_STDCALL snessetjacobian_(SNES *snes,Mat *A,Mat *B, 140 void (PETSC_STDCALL *func)(SNES*,Vec*,Mat*,Mat*,void*,PetscErrorCode*), 141 void *ctx,PetscErrorCode *ierr) 142 { 143 CHKFORTRANNULLFUNCTION(func); 144 if ((PetscVoidFunction)func == (PetscVoidFunction)snescomputejacobiandefault_) { 145 *ierr = SNESSetJacobian(*snes,*A,*B,SNESComputeJacobianDefault,ctx); 146 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snescomputejacobiandefaultcolor_) { 147 if (!ctx) { 148 *ierr = PETSC_ERR_ARG_NULL; 149 return; 150 } 151 *ierr = SNESSetJacobian(*snes,*A,*B,SNESComputeJacobianDefaultColor,*(MatFDColoring*)ctx); 152 } else if ((PetscVoidFunction)func == (PetscVoidFunction)matmffdcomputejacobian_) { 153 *ierr = SNESSetJacobian(*snes,*A,*B,MatMFFDComputeJacobian,ctx); 154 } else if (!func) { 155 *ierr = SNESSetJacobian(*snes,*A,*B,0,ctx); 156 } else { 157 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.jacobian,(PetscVoidFunction)func,ctx); 158 if (!*ierr) *ierr = SNESSetJacobian(*snes,*A,*B,oursnesjacobian,NULL); 159 } 160 } 161 /* -------------------------------------------------------------*/ 162 163 PETSC_EXTERN void PETSC_STDCALL snessolve_(SNES *snes,Vec *b,Vec *x, int *ierr) 164 { 165 CHKFORTRANNULLOBJECTDEREFERENCE(b); 166 CHKFORTRANNULLOBJECTDEREFERENCE(x); 167 *ierr = SNESSolve(*snes,*b,*x); 168 } 169 170 PETSC_EXTERN void PETSC_STDCALL snesgetoptionsprefix_(SNES *snes,char* prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 171 { 172 const char *tname; 173 174 *ierr = SNESGetOptionsPrefix(*snes,&tname); 175 *ierr = PetscStrncpy(prefix,tname,len);if (*ierr) return; 176 FIXRETURNCHAR(PETSC_TRUE,prefix,len); 177 } 178 179 PETSC_EXTERN void PETSC_STDCALL snesgettype_(SNES *snes,char* name PETSC_MIXED_LEN(len), PetscErrorCode *ierr PETSC_END_LEN(len)) 180 { 181 const char *tname; 182 183 *ierr = SNESGetType(*snes,&tname); 184 *ierr = PetscStrncpy(name,tname,len);if (*ierr) return; 185 FIXRETURNCHAR(PETSC_TRUE,name,len); 186 } 187 188 /* ---------------------------------------------------------*/ 189 190 /* 191 These are not usually called from Fortran but allow Fortran users 192 to transparently set these monitors from .F code 193 194 functions, hence no STDCALL 195 */ 196 197 PETSC_EXTERN void PETSC_STDCALL snessetfunction_(SNES *snes,Vec *r,void (PETSC_STDCALL *func)(SNES*,Vec*,Vec*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr PETSC_F90_2PTR_PROTO(ptr)) 198 { 199 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.function,(PetscVoidFunction)func,ctx); 200 #if defined(PETSC_HAVE_F90_2PTR_ARG) 201 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.function_pgiptr,NULL,ptr); 202 #endif 203 if (!*ierr) *ierr = SNESSetFunction(*snes,*r,oursnesfunction,NULL); 204 } 205 206 207 PETSC_EXTERN void PETSC_STDCALL snessetngs_(SNES *snes,void (PETSC_STDCALL *func)(SNES*,Vec*,Vec*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr) 208 { 209 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.ngs,(PetscVoidFunction)func,ctx); 210 if (!*ierr) *ierr = SNESSetNGS(*snes,oursnesngs,NULL); 211 } 212 PETSC_EXTERN void PETSC_STDCALL snessetupdate_(SNES *snes,void (PETSC_STDCALL *func)(SNES*,PetscInt*,PetscErrorCode*),PetscErrorCode *ierr) 213 { 214 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.update,(PetscVoidFunction)func,NULL); 215 if (!*ierr) *ierr = SNESSetUpdate(*snes,oursnesupdate); 216 } 217 /* ---------------------------------------------------------*/ 218 219 /* the func argument is ignored */ 220 PETSC_EXTERN void PETSC_STDCALL snesgetfunction_(SNES *snes,Vec *r,void *func,void **ctx,PetscErrorCode *ierr) 221 { 222 CHKFORTRANNULLOBJECT(r); 223 *ierr = SNESGetFunction(*snes,r,NULL,NULL); if (*ierr) return; 224 *ierr = PetscObjectGetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,_cb.function,NULL,ctx); 225 } 226 227 PETSC_EXTERN void PETSC_STDCALL snesgetngs_(SNES *snes,void *func,void **ctx,PetscErrorCode *ierr) 228 { 229 *ierr = PetscObjectGetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,_cb.ngs,NULL,ctx); 230 } 231 232 /*----------------------------------------------------------------------*/ 233 234 PETSC_EXTERN void snesconvergeddefault_(SNES *snes,PetscInt *it,PetscReal *a,PetscReal *b,PetscReal *c,SNESConvergedReason *r, void *ct,PetscErrorCode *ierr) 235 { 236 *ierr = SNESConvergedDefault(*snes,*it,*a,*b,*c,r,ct); 237 } 238 239 PETSC_EXTERN void snesconvergedskip_(SNES *snes,PetscInt *it,PetscReal *a,PetscReal *b,PetscReal *c,SNESConvergedReason *r,void *ct,PetscErrorCode *ierr) 240 { 241 *ierr = SNESConvergedSkip(*snes,*it,*a,*b,*c,r,ct); 242 } 243 244 PETSC_EXTERN void PETSC_STDCALL snessetconvergencetest_(SNES *snes,void (PETSC_STDCALL *func)(SNES*,PetscInt*,PetscReal*,PetscReal*,PetscReal*,SNESConvergedReason*,void*,PetscErrorCode*), void *cctx,void (PETSC_STDCALL *destroy)(void*),PetscErrorCode *ierr) 245 { 246 CHKFORTRANNULLOBJECT(cctx); 247 CHKFORTRANNULLFUNCTION(destroy); 248 249 if ((PetscVoidFunction)func == (PetscVoidFunction)snesconvergeddefault_) { 250 *ierr = SNESSetConvergenceTest(*snes,SNESConvergedDefault,0,0); 251 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesconvergedskip_) { 252 *ierr = SNESSetConvergenceTest(*snes,SNESConvergedSkip,0,0); 253 } else { 254 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.test,(PetscVoidFunction)func,cctx); 255 if (*ierr) return; 256 if (!destroy) { 257 *ierr = SNESSetConvergenceTest(*snes,oursnestest,*snes,NULL); 258 } else { 259 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.destroy,(PetscVoidFunction)destroy,cctx); 260 if (!*ierr) *ierr = SNESSetConvergenceTest(*snes,oursnestest,*snes,ourdestroy); 261 } 262 } 263 } 264 /*----------------------------------------------------------------------*/ 265 266 PETSC_EXTERN void PETSC_STDCALL snesview_(SNES *snes,PetscViewer *viewer, PetscErrorCode *ierr) 267 { 268 PetscViewer v; 269 PetscPatchDefaultViewers_Fortran(viewer,v); 270 *ierr = SNESView(*snes,v); 271 } 272 273 /* func is currently ignored from Fortran */ 274 PETSC_EXTERN void PETSC_STDCALL snesgetjacobian_(SNES *snes,Mat *A,Mat *B,int *func,void **ctx,PetscErrorCode *ierr) 275 { 276 CHKFORTRANNULLINTEGER(ctx); 277 CHKFORTRANNULLOBJECT(A); 278 CHKFORTRANNULLOBJECT(B); 279 *ierr = SNESGetJacobian(*snes,A,B,0,NULL); if (*ierr) return; 280 *ierr = PetscObjectGetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,_cb.jacobian,NULL,ctx); 281 282 } 283 284 PETSC_EXTERN void PETSC_STDCALL snesgetconvergencehistory_(SNES *snes,PetscInt *na,PetscErrorCode *ierr) 285 { 286 *ierr = SNESGetConvergenceHistory(*snes,NULL,NULL,na); 287 } 288 289 PETSC_EXTERN void PETSC_STDCALL snessettype_(SNES *snes,char* type PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 290 { 291 char *t; 292 293 FIXCHAR(type,len,t); 294 *ierr = SNESSetType(*snes,t); 295 FREECHAR(type,t); 296 } 297 298 PETSC_EXTERN void PETSC_STDCALL snesappendoptionsprefix_(SNES *snes,char* prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 299 { 300 char *t; 301 302 FIXCHAR(prefix,len,t); 303 *ierr = SNESAppendOptionsPrefix(*snes,t); 304 FREECHAR(prefix,t); 305 } 306 307 PETSC_EXTERN void PETSC_STDCALL snessetoptionsprefix_(SNES *snes,char* prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 308 { 309 char *t; 310 311 FIXCHAR(prefix,len,t); 312 *ierr = SNESSetOptionsPrefix(*snes,t); 313 FREECHAR(prefix,t); 314 } 315 316 /*----------------------------------------------------------------------*/ 317 /* functions, hence no STDCALL */ 318 319 PETSC_EXTERN void snesmonitorlgresidualnorm_(SNES *snes,PetscInt *its,PetscReal *fgnorm,PetscObject *dummy,PetscErrorCode *ierr) 320 { 321 *ierr = SNESMonitorLGResidualNorm(*snes,*its,*fgnorm,dummy); 322 } 323 324 PETSC_EXTERN void snesmonitordefault_(SNES *snes,PetscInt *its,PetscReal *fgnorm,PetscViewerAndFormat **dummy,PetscErrorCode *ierr) 325 { 326 *ierr = SNESMonitorDefault(*snes,*its,*fgnorm,*dummy); 327 } 328 329 PETSC_EXTERN void snesmonitorsolution_(SNES *snes,PetscInt *its,PetscReal *fgnorm,PetscViewerAndFormat **dummy,PetscErrorCode *ierr) 330 { 331 *ierr = SNESMonitorSolution(*snes,*its,*fgnorm,*dummy); 332 } 333 334 PETSC_EXTERN void snesmonitorsolutionupdate_(SNES *snes,PetscInt *its,PetscReal *fgnorm,PetscViewerAndFormat **dummy,PetscErrorCode *ierr) 335 { 336 *ierr = SNESMonitorSolutionUpdate(*snes,*its,*fgnorm,*dummy); 337 } 338 339 340 PETSC_EXTERN void PETSC_STDCALL snesmonitorset_(SNES *snes,void (PETSC_STDCALL *func)(SNES*,PetscInt*,PetscReal*,void*,PetscErrorCode*),void *mctx,void (PETSC_STDCALL *mondestroy)(void*,PetscErrorCode*),PetscErrorCode *ierr) 341 { 342 CHKFORTRANNULLOBJECT(mctx); 343 if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitordefault_) { 344 *ierr = SNESMonitorSet(*snes,(PetscErrorCode (*)(SNES,PetscInt,PetscReal,void*))SNESMonitorDefault,*(PetscViewerAndFormat**)mctx,(PetscErrorCode (*)(void **))PetscViewerAndFormatDestroy); 345 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitorsolution_) { 346 *ierr = SNESMonitorSet(*snes,(PetscErrorCode (*)(SNES,PetscInt,PetscReal,void*))SNESMonitorSolution,*(PetscViewerAndFormat**)mctx,(PetscErrorCode (*)(void **))PetscViewerAndFormatDestroy); 347 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitorsolutionupdate_) { 348 *ierr = SNESMonitorSet(*snes,(PetscErrorCode (*)(SNES,PetscInt,PetscReal,void*))SNESMonitorSolutionUpdate,*(PetscViewerAndFormat**)mctx,(PetscErrorCode (*)(void **))PetscViewerAndFormatDestroy); 349 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitorlgresidualnorm_) { 350 *ierr = SNESMonitorSet(*snes,(PetscErrorCode (*)(SNES,PetscInt,PetscReal,void*))SNESMonitorLGResidualNorm,0,0); 351 } else { 352 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.monitor,(PetscVoidFunction)func,mctx); 353 if (*ierr) return; 354 if (FORTRANNULLFUNCTION(mondestroy)) { 355 *ierr = SNESMonitorSet(*snes,oursnesmonitor,*snes,NULL); 356 } else { 357 CHKFORTRANNULLFUNCTION(mondestroy); 358 *ierr = PetscObjectSetFortranCallback((PetscObject)*snes,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.mondestroy,(PetscVoidFunction)mondestroy,mctx); 359 if (!*ierr) *ierr = SNESMonitorSet(*snes,oursnesmonitor,*snes,ourmondestroy); 360 } 361 } 362 } 363 364