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