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