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 PetscObjectAllocateFortranPointers(*snes,12); 238 239 if ((PetscVoidFunction)func == (PetscVoidFunction)snesdefaultconverged_){ 240 *ierr = SNESSetConvergenceTest(*snes,SNESDefaultConverged,0,0); 241 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesskipconverged_){ 242 *ierr = SNESSetConvergenceTest(*snes,SNESSkipConverged,0,0); 243 } else { 244 ((PetscObject)*snes)->fortran_func_pointers[1] = (PetscVoidFunction)func; 245 ((PetscObject)*snes)->fortran_func_pointers[11] = (PetscVoidFunction)cctx; 246 if (FORTRANNULLFUNCTION(destroy)) { 247 *ierr = SNESSetConvergenceTest(*snes,oursnestest,*snes,PETSC_NULL); 248 } else { 249 ((PetscObject)*snes)->fortran_func_pointers[10] = (PetscVoidFunction)destroy; 250 *ierr = SNESSetConvergenceTest(*snes,oursnestest,*snes,ourdestroy); 251 } 252 } 253 } 254 /*----------------------------------------------------------------------*/ 255 256 void PETSC_STDCALL snesview_(SNES *snes,PetscViewer *viewer, PetscErrorCode *ierr) 257 { 258 PetscViewer v; 259 PetscPatchDefaultViewers_Fortran(viewer,v); 260 *ierr = SNESView(*snes,v); 261 } 262 263 /* func is currently ignored from Fortran */ 264 void PETSC_STDCALL snesgetjacobian_(SNES *snes,Mat *A,Mat *B,int *func,void **ctx,PetscErrorCode *ierr) 265 { 266 CHKFORTRANNULLINTEGER(ctx); 267 CHKFORTRANNULLOBJECT(A); 268 CHKFORTRANNULLOBJECT(B); 269 *ierr = SNESGetJacobian(*snes,A,B,0,ctx); 270 } 271 272 void PETSC_STDCALL snesgetconvergencehistory_(SNES *snes,PetscInt *na,PetscErrorCode *ierr) 273 { 274 *ierr = SNESGetConvergenceHistory(*snes,PETSC_NULL,PETSC_NULL,na); 275 } 276 277 void PETSC_STDCALL snessettype_(SNES *snes,CHAR type PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 278 { 279 char *t; 280 281 FIXCHAR(type,len,t); 282 *ierr = SNESSetType(*snes,t); 283 FREECHAR(type,t); 284 } 285 286 void PETSC_STDCALL snesappendoptionsprefix_(SNES *snes,CHAR prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 287 { 288 char *t; 289 290 FIXCHAR(prefix,len,t); 291 *ierr = SNESAppendOptionsPrefix(*snes,t); 292 FREECHAR(prefix,t); 293 } 294 295 void PETSC_STDCALL snessetoptionsprefix_(SNES *snes,CHAR prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 296 { 297 char *t; 298 299 FIXCHAR(prefix,len,t); 300 *ierr = SNESSetOptionsPrefix(*snes,t); 301 FREECHAR(prefix,t); 302 } 303 304 /*----------------------------------------------------------------------*/ 305 /* functions, hence no STDCALL */ 306 307 void snesmonitorlg_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 308 { 309 *ierr = SNESMonitorLG(*snes,*its,*fgnorm,dummy); 310 } 311 312 void snesmonitordefault_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 313 { 314 *ierr = SNESMonitorDefault(*snes,*its,*fgnorm,dummy); 315 } 316 317 void snesmonitorsolution_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 318 { 319 *ierr = SNESMonitorSolution(*snes,*its,*fgnorm,dummy); 320 } 321 322 void snesmonitorsolutionupdate_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 323 { 324 *ierr = SNESMonitorSolutionUpdate(*snes,*its,*fgnorm,dummy); 325 } 326 327 328 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) 329 { 330 CHKFORTRANNULLOBJECT(mctx); 331 PetscObjectAllocateFortranPointers(*snes,12); 332 if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitordefault_) { 333 *ierr = SNESMonitorSet(*snes,SNESMonitorDefault,0,0); 334 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitorsolution_) { 335 *ierr = SNESMonitorSet(*snes,SNESMonitorSolution,0,0); 336 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitorsolutionupdate_) { 337 *ierr = SNESMonitorSet(*snes,SNESMonitorSolutionUpdate,0,0); 338 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitorlg_) { 339 *ierr = SNESMonitorSet(*snes,SNESMonitorLG,0,0); 340 } else { 341 ((PetscObject)*snes)->fortran_func_pointers[3] = (PetscVoidFunction)func; 342 ((PetscObject)*snes)->fortran_func_pointers[4] = (PetscVoidFunction)mctx; 343 344 if (FORTRANNULLFUNCTION(mondestroy)){ 345 *ierr = SNESMonitorSet(*snes,oursnesmonitor,*snes,PETSC_NULL); 346 } else { 347 ((PetscObject)*snes)->fortran_func_pointers[5] = (PetscVoidFunction)mondestroy; 348 *ierr = SNESMonitorSet(*snes,oursnesmonitor,*snes,ourmondestroy); 349 } 350 } 351 } 352 353 354 355 EXTERN_C_END 356