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