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