1 #include "private/fortranimpl.h" 2 #include "petscsnes.h" 3 4 #if defined(PETSC_HAVE_FORTRAN_CAPS) 5 #define snessolve_ SNESSOLVE 6 #define snesdefaultcomputejacobian_ SNESDEFAULTCOMPUTEJACOBIAN 7 #define snesdefaultcomputejacobiancolor_ SNESDEFAULTCOMPUTEJACOBIANCOLOR 8 #define snesdacomputejacobian_ SNESDACOMPUTEJACOBIAN 9 #define snesdacomputejacobianwithadifor_ SNESDACOMPUTEJACOBIANWITHADIFOR 10 #define snessetjacobian_ SNESSETJACOBIAN 11 #define snesgetoptionsprefix_ SNESGETOPTIONSPREFIX 12 #define snesgettype_ SNESGETTYPE 13 #define snesdaformfunction_ SNESDAFORMFUNCTION 14 #define snessetfunction_ SNESSETFUNCTION 15 #define snesgetfunction_ SNESGETFUNCTION 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 snesmonitorlg_ SNESMONITORLG 28 #define snesmonitorsolutionupdate_ SNESMONITORSOLUTIONUPDATE 29 #define snesmonitorset_ SNESMONITORSET 30 #define snesgetapplicationcontext_ SNESGETAPPLICATIONCONTEXT 31 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 32 #define snessolve_ snessolve 33 #define snesdefaultcomputejacobian_ snesdefaultcomputejacobian 34 #define snesdefaultcomputejacobiancolor_ snesdefaultcomputejacobiancolor 35 #define snesdacomputejacobian_ snesdacomputejacobian 36 #define snesdacomputejacobianwithadifor_ snesdacomputejacobianwithadifor 37 #define snessetjacobian_ snessetjacobian 38 #define snesgetoptionsprefix_ snesgetoptionsprefix 39 #define snesgettype_ snesgettype 40 #define snesdaformfunction_ snesdaformfunction 41 #define snessetfunction_ snessetfunction 42 #define snesgetfunction_ snesgetfunction 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 snesmonitorlg_ snesmonitorlg 53 #define snesmonitordefault_ snesmonitordefault 54 #define snesmonitorsolution_ snesmonitorsolution 55 #define snesmonitorsolutionupdate_ snesmonitorsolutionupdate 56 #define snesmonitorset_ snesmonitorset 57 #define snesgetapplicationcontext_ snesgetapplicationcontext 58 #endif 59 60 static PetscErrorCode oursnesfunction(SNES snes,Vec x,Vec f,void *ctx) 61 { 62 PetscErrorCode ierr = 0; 63 (*(void (PETSC_STDCALL *)(SNES*,Vec*,Vec*,void*,PetscErrorCode*))(((PetscObject)snes)->fortran_func_pointers[0]))(&snes,&x,&f,ctx,&ierr);CHKERRQ(ierr); 64 return 0; 65 } 66 67 static PetscErrorCode oursnestest(SNES snes,PetscInt it,PetscReal a,PetscReal d,PetscReal c,SNESConvergedReason*reason,void*ctx) 68 { 69 PetscErrorCode ierr = 0; 70 void *mctx = (void*) ((PetscObject)snes)->fortran_func_pointers[11]; 71 (*(void (PETSC_STDCALL *)(SNES*,PetscInt*,PetscReal*,PetscReal*,PetscReal*,SNESConvergedReason*,void*,PetscErrorCode*))(((PetscObject)snes)->fortran_func_pointers[1]))(&snes,&it,&a,&d,&c,reason,mctx,&ierr);CHKERRQ(ierr); 72 return 0; 73 } 74 75 static PetscErrorCode ourdestroy(void*ctx) 76 { 77 PetscErrorCode ierr = 0; 78 SNES snes = (SNES)ctx; 79 void *mctx = (void*) ((PetscObject)snes)->fortran_func_pointers[11]; 80 (*(void (PETSC_STDCALL *)(void*,PetscErrorCode*))(((PetscObject)snes)->fortran_func_pointers[10]))(mctx,&ierr);CHKERRQ(ierr); 81 return 0; 82 } 83 84 static PetscErrorCode oursnesjacobian(SNES snes,Vec x,Mat* m,Mat* p,MatStructure* type,void*ctx) 85 { 86 PetscErrorCode ierr = 0; 87 (*(void (PETSC_STDCALL *)(SNES*,Vec*,Mat*,Mat*,MatStructure*,void*,PetscErrorCode*))(((PetscObject)snes)->fortran_func_pointers[2]))(&snes,&x,m,p,type,ctx,&ierr);CHKERRQ(ierr); 88 return 0; 89 } 90 static PetscErrorCode oursnesmonitor(SNES snes,PetscInt i,PetscReal d,void*ctx) 91 { 92 PetscErrorCode ierr = 0; 93 94 void *mctx = (void*)((PetscObject)snes)->fortran_func_pointers[4]; 95 (*(void (PETSC_STDCALL *)(SNES*,PetscInt*,PetscReal*,void*,PetscErrorCode*))(((PetscObject)snes)->fortran_func_pointers[3]))(&snes,&i,&d,mctx,&ierr);CHKERRQ(ierr); 96 return 0; 97 } 98 static PetscErrorCode ourmondestroy(void* ctx) 99 { 100 PetscErrorCode ierr = 0; 101 SNES snes = (SNES)ctx; 102 void *mctx = (void*) ((PetscObject)snes)->fortran_func_pointers[4]; 103 (*(void (PETSC_STDCALL *)(void*,PetscErrorCode*))(((PetscObject)snes)->fortran_func_pointers[5]))(mctx,&ierr);CHKERRQ(ierr); 104 return 0; 105 } 106 107 EXTERN_C_BEGIN 108 /* ---------------------------------------------------------*/ 109 /* 110 snesdefaultcomputejacobian() and snesdefaultcomputejacobiancolor() 111 These can be used directly from Fortran but are mostly so that 112 Fortran SNESSetJacobian() will properly handle the defaults being passed in. 113 114 functions, hence no STDCALL 115 */ 116 void snesdefaultcomputejacobian_(SNES *snes,Vec *x,Mat *m,Mat *p,MatStructure* type,void *ctx,PetscErrorCode *ierr) 117 { 118 *ierr = SNESDefaultComputeJacobian(*snes,*x,m,p,type,ctx); 119 } 120 void snesdefaultcomputejacobiancolor_(SNES *snes,Vec *x,Mat *m,Mat *p,MatStructure* type,void *ctx,PetscErrorCode *ierr) 121 { 122 *ierr = SNESDefaultComputeJacobianColor(*snes,*x,m,p,type,*(MatFDColoring*)ctx); 123 } 124 125 void snesdacomputejacobianwithadifor_(SNES *snes,Vec *X,Mat *m,Mat *p,MatStructure* type,void *ctx,PetscErrorCode *ierr) 126 { 127 (*PetscErrorPrintf)("Cannot call this function from Fortran"); 128 *ierr = 1; 129 } 130 131 void snesdacomputejacobian_(SNES *snes,Vec *X,Mat *m,Mat *p,MatStructure* type,void *ctx,PetscErrorCode *ierr) 132 { 133 (*PetscErrorPrintf)("Cannot call this function from Fortran"); 134 *ierr = 1; 135 } 136 137 void PETSC_STDCALL snessetjacobian_(SNES *snes,Mat *A,Mat *B,void (PETSC_STDCALL *func)(SNES*,Vec*,Mat*,Mat*, 138 MatStructure*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr) 139 { 140 CHKFORTRANNULLOBJECT(ctx); 141 CHKFORTRANNULLFUNCTION(func); 142 PetscObjectAllocateFortranPointers(*snes,12); 143 if ((PetscVoidFunction)func == (PetscVoidFunction)snesdefaultcomputejacobian_) { 144 *ierr = SNESSetJacobian(*snes,*A,*B,SNESDefaultComputeJacobian,ctx); 145 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesdefaultcomputejacobiancolor_) { 146 *ierr = SNESSetJacobian(*snes,*A,*B,SNESDefaultComputeJacobianColor,*(MatFDColoring*)ctx); 147 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesdacomputejacobianwithadifor_) { 148 *ierr = SNESSetJacobian(*snes,*A,*B,SNESDAComputeJacobianWithAdifor,ctx); 149 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesdacomputejacobian_) { 150 *ierr = SNESSetJacobian(*snes,*A,*B,SNESDAComputeJacobian,ctx); 151 } else if (!func) { 152 *ierr = SNESSetJacobian(*snes,*A,*B,0,ctx); 153 } else { 154 ((PetscObject)*snes)->fortran_func_pointers[2] = (PetscVoidFunction)func; 155 *ierr = SNESSetJacobian(*snes,*A,*B,oursnesjacobian,ctx); 156 } 157 } 158 /* -------------------------------------------------------------*/ 159 160 void PETSC_STDCALL snessolve_(SNES *snes,Vec *b,Vec *x, int *__ierr ) 161 { 162 Vec B = *b; 163 if (*b == PETSC_NULL_OBJECT_Fortran) B = PETSC_NULL; 164 *__ierr = SNESSolve(*snes,B,*x); 165 } 166 167 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 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 void PETSC_STDCALL snesgetapplicationcontext_(SNES *snes,void **ctx,PetscErrorCode *ierr) 185 { 186 *ierr = SNESGetApplicationContext(*snes,ctx); 187 } 188 /* ---------------------------------------------------------*/ 189 190 /* 191 These are not usually called from Fortran but allow Fortran users 192 to transparently set these monitors from .F code 193 194 functions, hence no STDCALL 195 */ 196 void snesdaformfunction_(SNES *snes,Vec *X, Vec *F,void *ptr,PetscErrorCode *ierr) 197 { 198 *ierr = SNESDAFormFunction(*snes,*X,*F,ptr); 199 } 200 201 void PETSC_STDCALL snessetfunction_(SNES *snes,Vec *r,void (PETSC_STDCALL *func)(SNES*,Vec*,Vec*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr) 202 { 203 CHKFORTRANNULLOBJECT(ctx); 204 PetscObjectAllocateFortranPointers(*snes,12); 205 if ((PetscVoidFunction)func == (PetscVoidFunction)snesdaformfunction_) { 206 *ierr = SNESSetFunction(*snes,*r,SNESDAFormFunction,ctx); 207 } else { 208 ((PetscObject)*snes)->fortran_func_pointers[0] = (PetscVoidFunction)func; 209 *ierr = SNESSetFunction(*snes,*r,oursnesfunction,ctx); 210 } 211 } 212 /* ---------------------------------------------------------*/ 213 214 /* the func argument is ignored */ 215 void PETSC_STDCALL snesgetfunction_(SNES *snes,Vec *r,void *func,void **ctx,PetscErrorCode *ierr) 216 { 217 CHKFORTRANNULLINTEGER(ctx); 218 CHKFORTRANNULLOBJECT(r); 219 *ierr = SNESGetFunction(*snes,r,PETSC_NULL,ctx); 220 } 221 /*----------------------------------------------------------------------*/ 222 223 void snesdefaultconverged_(SNES *snes,PetscInt *it,PetscReal *a,PetscReal *b,PetscReal *c,SNESConvergedReason *r, void *ct,PetscErrorCode *ierr) 224 { 225 *ierr = SNESDefaultConverged(*snes,*it,*a,*b,*c,r,ct); 226 } 227 228 void snesskipconverged_(SNES *snes,PetscInt *it,PetscReal *a,PetscReal *b,PetscReal *c,SNESConvergedReason *r, 229 void *ct,PetscErrorCode *ierr) 230 { 231 *ierr = SNESSkipConverged(*snes,*it,*a,*b,*c,r,ct); 232 } 233 234 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) 235 { 236 CHKFORTRANNULLOBJECT(cctx); 237 CHKFORTRANNULLFUNCTION(destroy); 238 PetscObjectAllocateFortranPointers(*snes,12); 239 240 if ((PetscVoidFunction)func == (PetscVoidFunction)snesdefaultconverged_){ 241 *ierr = SNESSetConvergenceTest(*snes,SNESDefaultConverged,0,0); 242 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesskipconverged_){ 243 *ierr = SNESSetConvergenceTest(*snes,SNESSkipConverged,0,0); 244 } else { 245 ((PetscObject)*snes)->fortran_func_pointers[1] = (PetscVoidFunction)func; 246 ((PetscObject)*snes)->fortran_func_pointers[11] = (PetscVoidFunction)cctx; 247 if (!destroy) { 248 *ierr = SNESSetConvergenceTest(*snes,oursnestest,*snes,PETSC_NULL); 249 } else { 250 ((PetscObject)*snes)->fortran_func_pointers[10] = (PetscVoidFunction)destroy; 251 *ierr = SNESSetConvergenceTest(*snes,oursnestest,*snes,ourdestroy); 252 } 253 } 254 } 255 /*----------------------------------------------------------------------*/ 256 257 void PETSC_STDCALL snesview_(SNES *snes,PetscViewer *viewer, PetscErrorCode *ierr) 258 { 259 PetscViewer v; 260 PetscPatchDefaultViewers_Fortran(viewer,v); 261 *ierr = SNESView(*snes,v); 262 } 263 264 /* func is currently ignored from Fortran */ 265 void PETSC_STDCALL snesgetjacobian_(SNES *snes,Mat *A,Mat *B,int *func,void **ctx,PetscErrorCode *ierr) 266 { 267 CHKFORTRANNULLINTEGER(ctx); 268 CHKFORTRANNULLOBJECT(A); 269 CHKFORTRANNULLOBJECT(B); 270 *ierr = SNESGetJacobian(*snes,A,B,0,ctx); 271 } 272 273 void PETSC_STDCALL snesgetconvergencehistory_(SNES *snes,PetscInt *na,PetscErrorCode *ierr) 274 { 275 *ierr = SNESGetConvergenceHistory(*snes,PETSC_NULL,PETSC_NULL,na); 276 } 277 278 void PETSC_STDCALL snessettype_(SNES *snes,CHAR type PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 279 { 280 char *t; 281 282 FIXCHAR(type,len,t); 283 *ierr = SNESSetType(*snes,t); 284 FREECHAR(type,t); 285 } 286 287 void PETSC_STDCALL snesappendoptionsprefix_(SNES *snes,CHAR prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 288 { 289 char *t; 290 291 FIXCHAR(prefix,len,t); 292 *ierr = SNESAppendOptionsPrefix(*snes,t); 293 FREECHAR(prefix,t); 294 } 295 296 void PETSC_STDCALL snessetoptionsprefix_(SNES *snes,CHAR prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 297 { 298 char *t; 299 300 FIXCHAR(prefix,len,t); 301 *ierr = SNESSetOptionsPrefix(*snes,t); 302 FREECHAR(prefix,t); 303 } 304 305 /*----------------------------------------------------------------------*/ 306 /* functions, hence no STDCALL */ 307 308 void snesmonitorlg_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 309 { 310 *ierr = SNESMonitorLG(*snes,*its,*fgnorm,dummy); 311 } 312 313 void snesmonitordefault_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 314 { 315 *ierr = SNESMonitorDefault(*snes,*its,*fgnorm,dummy); 316 } 317 318 void snesmonitorsolution_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 319 { 320 *ierr = SNESMonitorSolution(*snes,*its,*fgnorm,dummy); 321 } 322 323 void snesmonitorsolutionupdate_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 324 { 325 *ierr = SNESMonitorSolutionUpdate(*snes,*its,*fgnorm,dummy); 326 } 327 328 329 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) 330 { 331 CHKFORTRANNULLOBJECT(mctx); 332 PetscObjectAllocateFortranPointers(*snes,12); 333 if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitordefault_) { 334 *ierr = SNESMonitorSet(*snes,SNESMonitorDefault,0,0); 335 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitorsolution_) { 336 *ierr = SNESMonitorSet(*snes,SNESMonitorSolution,0,0); 337 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitorsolutionupdate_) { 338 *ierr = SNESMonitorSet(*snes,SNESMonitorSolutionUpdate,0,0); 339 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitorlg_) { 340 *ierr = SNESMonitorSet(*snes,SNESMonitorLG,0,0); 341 } else { 342 ((PetscObject)*snes)->fortran_func_pointers[3] = (PetscVoidFunction)func; 343 ((PetscObject)*snes)->fortran_func_pointers[4] = (PetscVoidFunction)mctx; 344 345 if (FORTRANNULLFUNCTION(mondestroy)){ 346 *ierr = SNESMonitorSet(*snes,oursnesmonitor,*snes,PETSC_NULL); 347 } else { 348 ((PetscObject)*snes)->fortran_func_pointers[5] = (PetscVoidFunction)mondestroy; 349 *ierr = SNESMonitorSet(*snes,oursnesmonitor,*snes,ourmondestroy); 350 } 351 } 352 } 353 354 355 356 EXTERN_C_END 357