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