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