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