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 (PETSC_STDCALL *)(SNES*,PetscInt*,PetscReal*,PetscReal*,PetscReal*,SNESConvergedReason*,void*,PetscErrorCode*))(((PetscObject)snes)->fortran_func_pointers[1]))(&snes,&it,&a,&d,&c,reason,ctx,&ierr);CHKERRQ(ierr); 71 return 0; 72 } 73 74 static PetscErrorCode oursnesjacobian(SNES snes,Vec x,Mat* m,Mat* p,MatStructure* type,void*ctx) 75 { 76 PetscErrorCode ierr = 0; 77 (*(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); 78 return 0; 79 } 80 static PetscErrorCode oursnesmonitor(SNES snes,PetscInt i,PetscReal d,void*ctx) 81 { 82 PetscErrorCode ierr = 0; 83 84 void (*mctx)(void) = ((PetscObject)snes)->fortran_func_pointers[4]; 85 (*(void (PETSC_STDCALL *)(SNES*,PetscInt*,PetscReal*,void*,PetscErrorCode*))(((PetscObject)snes)->fortran_func_pointers[3]))(&snes,&i,&d,(void*)mctx,&ierr);CHKERRQ(ierr); 86 return 0; 87 } 88 static PetscErrorCode ourmondestroy(void* ctx) 89 { 90 PetscErrorCode ierr = 0; 91 SNES snes = (SNES)ctx; 92 void (*mctx)(void) = ((PetscObject)snes)->fortran_func_pointers[4]; 93 (*(void (PETSC_STDCALL *)(PetscVoidFunction,PetscErrorCode*))(((PetscObject)snes)->fortran_func_pointers[5]))(mctx,&ierr);CHKERRQ(ierr); 94 return 0; 95 } 96 97 EXTERN_C_BEGIN 98 /* ---------------------------------------------------------*/ 99 /* 100 snesdefaultcomputejacobian() and snesdefaultcomputejacobiancolor() 101 These can be used directly from Fortran but are mostly so that 102 Fortran SNESSetJacobian() will properly handle the defaults being passed in. 103 104 functions, hence no STDCALL 105 */ 106 void snesdefaultcomputejacobian_(SNES *snes,Vec *x,Mat *m,Mat *p,MatStructure* type,void *ctx,PetscErrorCode *ierr) 107 { 108 *ierr = SNESDefaultComputeJacobian(*snes,*x,m,p,type,ctx); 109 } 110 void snesdefaultcomputejacobiancolor_(SNES *snes,Vec *x,Mat *m,Mat *p,MatStructure* type,void *ctx,PetscErrorCode *ierr) 111 { 112 *ierr = SNESDefaultComputeJacobianColor(*snes,*x,m,p,type,*(MatFDColoring*)ctx); 113 } 114 115 void snesdacomputejacobianwithadifor_(SNES *snes,Vec *X,Mat *m,Mat *p,MatStructure* type,void *ctx,PetscErrorCode *ierr) 116 { 117 (*PetscErrorPrintf)("Cannot call this function from Fortran"); 118 *ierr = 1; 119 } 120 121 void snesdacomputejacobian_(SNES *snes,Vec *X,Mat *m,Mat *p,MatStructure* type,void *ctx,PetscErrorCode *ierr) 122 { 123 (*PetscErrorPrintf)("Cannot call this function from Fortran"); 124 *ierr = 1; 125 } 126 127 void PETSC_STDCALL snessetjacobian_(SNES *snes,Mat *A,Mat *B,void (PETSC_STDCALL *func)(SNES*,Vec*,Mat*,Mat*, 128 MatStructure*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr) 129 { 130 CHKFORTRANNULLOBJECT(ctx); 131 CHKFORTRANNULLFUNCTION(func); 132 PetscObjectAllocateFortranPointers(*snes,6); 133 if ((PetscVoidFunction)func == (PetscVoidFunction)snesdefaultcomputejacobian_) { 134 *ierr = SNESSetJacobian(*snes,*A,*B,SNESDefaultComputeJacobian,ctx); 135 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesdefaultcomputejacobiancolor_) { 136 *ierr = SNESSetJacobian(*snes,*A,*B,SNESDefaultComputeJacobianColor,*(MatFDColoring*)ctx); 137 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesdacomputejacobianwithadifor_) { 138 *ierr = SNESSetJacobian(*snes,*A,*B,SNESDAComputeJacobianWithAdifor,ctx); 139 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesdacomputejacobian_) { 140 *ierr = SNESSetJacobian(*snes,*A,*B,SNESDAComputeJacobian,ctx); 141 } else if (!func) { 142 *ierr = SNESSetJacobian(*snes,*A,*B,0,ctx); 143 } else { 144 ((PetscObject)*snes)->fortran_func_pointers[2] = (PetscVoidFunction)func; 145 *ierr = SNESSetJacobian(*snes,*A,*B,oursnesjacobian,ctx); 146 } 147 } 148 /* -------------------------------------------------------------*/ 149 150 void PETSC_STDCALL snessolve_(SNES *snes,Vec *b,Vec *x, int *__ierr ) 151 { 152 Vec B = *b; 153 if (*b == PETSC_NULL_OBJECT_Fortran) B = PETSC_NULL; 154 *__ierr = SNESSolve(*snes,B,*x); 155 } 156 157 void PETSC_STDCALL snesgetoptionsprefix_(SNES *snes,CHAR prefix PETSC_MIXED_LEN(len), 158 PetscErrorCode *ierr PETSC_END_LEN(len)) 159 { 160 const char *tname; 161 162 *ierr = SNESGetOptionsPrefix(*snes,&tname); 163 *ierr = PetscStrncpy(prefix,tname,len);if (*ierr) return; 164 } 165 166 void PETSC_STDCALL snesgettype_(SNES *snes,CHAR name PETSC_MIXED_LEN(len), 167 PetscErrorCode *ierr PETSC_END_LEN(len)) 168 { 169 const char *tname; 170 171 *ierr = SNESGetType(*snes,&tname); 172 *ierr = PetscStrncpy(name,tname,len);if (*ierr) return; 173 FIXRETURNCHAR(PETSC_TRUE,name,len); 174 } 175 176 void PETSC_STDCALL snesgetapplicationcontext_(SNES *snes,void **ctx,PetscErrorCode *ierr) 177 { 178 *ierr = SNESGetApplicationContext(*snes,ctx); 179 } 180 /* ---------------------------------------------------------*/ 181 182 /* 183 These are not usually called from Fortran but allow Fortran users 184 to transparently set these monitors from .F code 185 186 functions, hence no STDCALL 187 */ 188 void snesdaformfunction_(SNES *snes,Vec *X, Vec *F,void *ptr,PetscErrorCode *ierr) 189 { 190 *ierr = SNESDAFormFunction(*snes,*X,*F,ptr); 191 } 192 193 void PETSC_STDCALL snessetfunction_(SNES *snes,Vec *r,void (PETSC_STDCALL *func)(SNES*,Vec*,Vec*,void*,PetscErrorCode*), 194 void *ctx,PetscErrorCode *ierr) 195 { 196 CHKFORTRANNULLOBJECT(ctx); 197 PetscObjectAllocateFortranPointers(*snes,6); 198 if ((PetscVoidFunction)func == (PetscVoidFunction)snesdaformfunction_) { 199 *ierr = SNESSetFunction(*snes,*r,SNESDAFormFunction,ctx); 200 } else { 201 ((PetscObject)*snes)->fortran_func_pointers[0] = (PetscVoidFunction)func; 202 *ierr = SNESSetFunction(*snes,*r,oursnesfunction,ctx); 203 } 204 } 205 /* ---------------------------------------------------------*/ 206 207 /* the func argument is ignored */ 208 void PETSC_STDCALL snesgetfunction_(SNES *snes,Vec *r,void *func,void **ctx,PetscErrorCode *ierr) 209 { 210 CHKFORTRANNULLINTEGER(ctx); 211 CHKFORTRANNULLOBJECT(r); 212 *ierr = SNESGetFunction(*snes,r,PETSC_NULL,ctx); 213 } 214 /*----------------------------------------------------------------------*/ 215 216 void snesdefaultconverged_(SNES *snes,PetscInt *it,PetscReal *a,PetscReal *b,PetscReal *c,SNESConvergedReason *r, 217 void *ct,PetscErrorCode *ierr) 218 { 219 *ierr = SNESDefaultConverged(*snes,*it,*a,*b,*c,r,ct); 220 } 221 222 void snesskipconverged_(SNES *snes,PetscInt *it,PetscReal *a,PetscReal *b,PetscReal *c,SNESConvergedReason *r, 223 void *ct,PetscErrorCode *ierr) 224 { 225 *ierr = SNESSkipConverged(*snes,*it,*a,*b,*c,r,ct); 226 } 227 228 void PETSC_STDCALL snessetconvergencetest_(SNES *snes, 229 void (PETSC_STDCALL *func)(SNES*,PetscInt*,PetscReal*,PetscReal*,PetscReal*,SNESConvergedReason*,void*,PetscErrorCode*), 230 void *cctx,PetscErrorCode *ierr) 231 { 232 CHKFORTRANNULLOBJECT(cctx); 233 PetscObjectAllocateFortranPointers(*snes,6); 234 235 if ((PetscVoidFunction)func == (PetscVoidFunction)snesdefaultconverged_){ 236 *ierr = SNESSetConvergenceTest(*snes,SNESDefaultConverged,0); 237 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesskipconverged_){ 238 *ierr = SNESSetConvergenceTest(*snes,SNESSkipConverged,0); 239 } else { 240 ((PetscObject)*snes)->fortran_func_pointers[1] = (PetscVoidFunction)func; 241 *ierr = SNESSetConvergenceTest(*snes,oursnestest,cctx); 242 } 243 } 244 /*----------------------------------------------------------------------*/ 245 246 void PETSC_STDCALL snesview_(SNES *snes,PetscViewer *viewer, PetscErrorCode *ierr) 247 { 248 PetscViewer v; 249 PetscPatchDefaultViewers_Fortran(viewer,v); 250 *ierr = SNESView(*snes,v); 251 } 252 253 /* func is currently ignored from Fortran */ 254 void PETSC_STDCALL snesgetjacobian_(SNES *snes,Mat *A,Mat *B,int *func,void **ctx,PetscErrorCode *ierr) 255 { 256 CHKFORTRANNULLINTEGER(ctx); 257 CHKFORTRANNULLOBJECT(A); 258 CHKFORTRANNULLOBJECT(B); 259 *ierr = SNESGetJacobian(*snes,A,B,0,ctx); 260 } 261 262 void PETSC_STDCALL snesgetconvergencehistory_(SNES *snes,PetscInt *na,PetscErrorCode *ierr) 263 { 264 *ierr = SNESGetConvergenceHistory(*snes,PETSC_NULL,PETSC_NULL,na); 265 } 266 267 void PETSC_STDCALL snessettype_(SNES *snes,CHAR type PETSC_MIXED_LEN(len), 268 PetscErrorCode *ierr PETSC_END_LEN(len)) 269 { 270 char *t; 271 272 FIXCHAR(type,len,t); 273 *ierr = SNESSetType(*snes,t); 274 FREECHAR(type,t); 275 } 276 277 void PETSC_STDCALL snesappendoptionsprefix_(SNES *snes,CHAR prefix PETSC_MIXED_LEN(len), 278 PetscErrorCode *ierr PETSC_END_LEN(len)) 279 { 280 char *t; 281 282 FIXCHAR(prefix,len,t); 283 *ierr = SNESAppendOptionsPrefix(*snes,t); 284 FREECHAR(prefix,t); 285 } 286 287 void PETSC_STDCALL snessetoptionsprefix_(SNES *snes,CHAR prefix PETSC_MIXED_LEN(len), 288 PetscErrorCode *ierr PETSC_END_LEN(len)) 289 { 290 char *t; 291 292 FIXCHAR(prefix,len,t); 293 *ierr = SNESSetOptionsPrefix(*snes,t); 294 FREECHAR(prefix,t); 295 } 296 297 /*----------------------------------------------------------------------*/ 298 /* functions, hence no STDCALL */ 299 300 void snesmonitorlg_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 301 { 302 *ierr = SNESMonitorLG(*snes,*its,*fgnorm,dummy); 303 } 304 305 void snesmonitordefault_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 306 { 307 *ierr = SNESMonitorDefault(*snes,*its,*fgnorm,dummy); 308 } 309 310 void snesmonitorsolution_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 311 { 312 *ierr = SNESMonitorSolution(*snes,*its,*fgnorm,dummy); 313 } 314 315 void snesmonitorsolutionupdate_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 316 { 317 *ierr = SNESMonitorSolutionUpdate(*snes,*its,*fgnorm,dummy); 318 } 319 320 321 void PETSC_STDCALL snesmonitorset_(SNES *snes,void (PETSC_STDCALL *func)(SNES*,PetscInt*,PetscReal*,void*,PetscErrorCode*), 322 void *mctx,void (PETSC_STDCALL *mondestroy)(void*,PetscErrorCode*),PetscErrorCode *ierr) 323 { 324 CHKFORTRANNULLOBJECT(mctx); 325 PetscObjectAllocateFortranPointers(*snes,6); 326 if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitordefault_) { 327 *ierr = SNESMonitorSet(*snes,SNESMonitorDefault,0,0); 328 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitorsolution_) { 329 *ierr = SNESMonitorSet(*snes,SNESMonitorSolution,0,0); 330 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitorsolutionupdate_) { 331 *ierr = SNESMonitorSet(*snes,SNESMonitorSolutionUpdate,0,0); 332 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitorlg_) { 333 *ierr = SNESMonitorSet(*snes,SNESMonitorLG,0,0); 334 } else { 335 ((PetscObject)*snes)->fortran_func_pointers[3] = (PetscVoidFunction)func; 336 ((PetscObject)*snes)->fortran_func_pointers[4] = (PetscVoidFunction)mctx; 337 338 if (FORTRANNULLFUNCTION(mondestroy)){ 339 *ierr = SNESMonitorSet(*snes,oursnesmonitor,*snes,0); 340 } else { 341 ((PetscObject)*snes)->fortran_func_pointers[5] = (PetscVoidFunction)mondestroy; 342 *ierr = SNESMonitorSet(*snes,oursnesmonitor,*snes,ourmondestroy); 343 } 344 } 345 } 346 347 348 349 EXTERN_C_END 350