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