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,X = *x; 173 if (*b == PETSC_NULL_OBJECT_Fortran) B = PETSC_NULL; 174 if (*x == PETSC_NULL_OBJECT_Fortran) X = PETSC_NULL; 175 *__ierr = SNESSolve(*snes,B,X); 176 } 177 178 void PETSC_STDCALL snesgetoptionsprefix_(SNES *snes,CHAR prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 179 { 180 const char *tname; 181 182 *ierr = SNESGetOptionsPrefix(*snes,&tname); 183 *ierr = PetscStrncpy(prefix,tname,len);if (*ierr) return; 184 } 185 186 void PETSC_STDCALL snesgettype_(SNES *snes,CHAR name PETSC_MIXED_LEN(len), PetscErrorCode *ierr PETSC_END_LEN(len)) 187 { 188 const char *tname; 189 190 *ierr = SNESGetType(*snes,&tname); 191 *ierr = PetscStrncpy(name,tname,len);if (*ierr) return; 192 FIXRETURNCHAR(PETSC_TRUE,name,len); 193 } 194 195 /* ---------------------------------------------------------*/ 196 197 /* 198 These are not usually called from Fortran but allow Fortran users 199 to transparently set these monitors from .F code 200 201 functions, hence no STDCALL 202 */ 203 void snesdmdacomputefunction_(SNES *snes,Vec *X, Vec *F,void *ptr,PetscErrorCode *ierr) 204 { 205 *ierr = SNESDMDAComputeFunction(*snes,*X,*F,ptr); 206 } 207 208 void PETSC_STDCALL snessetfunction_(SNES *snes,Vec *r,void (PETSC_STDCALL *func)(SNES*,Vec*,Vec*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr) 209 { 210 CHKFORTRANNULLOBJECT(ctx); 211 PetscObjectAllocateFortranPointers(*snes,12); 212 if ((PetscVoidFunction)func == (PetscVoidFunction)snesdmdacomputefunction_) { 213 *ierr = SNESSetFunction(*snes,*r,SNESDMDAComputeFunction,ctx); 214 } else { 215 ((PetscObject)*snes)->fortran_func_pointers[0] = (PetscVoidFunction)func; 216 *ierr = SNESSetFunction(*snes,*r,oursnesfunction,ctx); 217 } 218 } 219 220 221 void PETSC_STDCALL snessetgs_(SNES *snes,void (PETSC_STDCALL *func)(SNES*,Vec*,Vec*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr) 222 { 223 CHKFORTRANNULLOBJECT(ctx); 224 PetscObjectAllocateFortranPointers(*snes,12); 225 if ((PetscVoidFunction)func == (PetscVoidFunction)snesdmdacomputefunction_) { 226 *ierr = SNESSetGS(*snes,SNESDMDAComputeFunction,ctx); 227 } else { 228 ((PetscObject)*snes)->fortran_func_pointers[0] = (PetscVoidFunction)func; 229 *ierr = SNESSetGS(*snes,oursnesfunction,ctx); 230 } 231 } 232 /* ---------------------------------------------------------*/ 233 234 /* the func argument is ignored */ 235 void PETSC_STDCALL snesgetfunction_(SNES *snes,Vec *r,void *func,void **ctx,PetscErrorCode *ierr) 236 { 237 CHKFORTRANNULLINTEGER(ctx); 238 CHKFORTRANNULLOBJECT(r); 239 *ierr = SNESGetFunction(*snes,r,PETSC_NULL,ctx); 240 } 241 242 void PETSC_STDCALL snesgetgs_(SNES *snes,void *func,void **ctx,PetscErrorCode *ierr) 243 { 244 CHKFORTRANNULLINTEGER(ctx); 245 *ierr = SNESGetGS(*snes,PETSC_NULL,ctx); 246 } 247 248 /*----------------------------------------------------------------------*/ 249 250 void snesdefaultconverged_(SNES *snes,PetscInt *it,PetscReal *a,PetscReal *b,PetscReal *c,SNESConvergedReason *r, void *ct,PetscErrorCode *ierr) 251 { 252 *ierr = SNESDefaultConverged(*snes,*it,*a,*b,*c,r,ct); 253 } 254 255 void snesskipconverged_(SNES *snes,PetscInt *it,PetscReal *a,PetscReal *b,PetscReal *c,SNESConvergedReason *r, 256 void *ct,PetscErrorCode *ierr) 257 { 258 *ierr = SNESSkipConverged(*snes,*it,*a,*b,*c,r,ct); 259 } 260 261 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) 262 { 263 CHKFORTRANNULLOBJECT(cctx); 264 CHKFORTRANNULLFUNCTION(destroy); 265 PetscObjectAllocateFortranPointers(*snes,12); 266 267 if ((PetscVoidFunction)func == (PetscVoidFunction)snesdefaultconverged_){ 268 *ierr = SNESSetConvergenceTest(*snes,SNESDefaultConverged,0,0); 269 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesskipconverged_){ 270 *ierr = SNESSetConvergenceTest(*snes,SNESSkipConverged,0,0); 271 } else { 272 ((PetscObject)*snes)->fortran_func_pointers[1] = (PetscVoidFunction)func; 273 ((PetscObject)*snes)->fortran_func_pointers[11] = (PetscVoidFunction)cctx; 274 if (!destroy) { 275 *ierr = SNESSetConvergenceTest(*snes,oursnestest,*snes,PETSC_NULL); 276 } else { 277 ((PetscObject)*snes)->fortran_func_pointers[10] = (PetscVoidFunction)destroy; 278 *ierr = SNESSetConvergenceTest(*snes,oursnestest,*snes,ourdestroy); 279 } 280 } 281 } 282 /*----------------------------------------------------------------------*/ 283 284 void PETSC_STDCALL snesview_(SNES *snes,PetscViewer *viewer, PetscErrorCode *ierr) 285 { 286 PetscViewer v; 287 PetscPatchDefaultViewers_Fortran(viewer,v); 288 *ierr = SNESView(*snes,v); 289 } 290 291 /* func is currently ignored from Fortran */ 292 void PETSC_STDCALL snesgetjacobian_(SNES *snes,Mat *A,Mat *B,int *func,void **ctx,PetscErrorCode *ierr) 293 { 294 CHKFORTRANNULLINTEGER(ctx); 295 CHKFORTRANNULLOBJECT(A); 296 CHKFORTRANNULLOBJECT(B); 297 *ierr = SNESGetJacobian(*snes,A,B,0,ctx); 298 } 299 300 void PETSC_STDCALL snesgetconvergencehistory_(SNES *snes,PetscInt *na,PetscErrorCode *ierr) 301 { 302 *ierr = SNESGetConvergenceHistory(*snes,PETSC_NULL,PETSC_NULL,na); 303 } 304 305 void PETSC_STDCALL snessettype_(SNES *snes,CHAR type PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 306 { 307 char *t; 308 309 FIXCHAR(type,len,t); 310 *ierr = SNESSetType(*snes,t); 311 FREECHAR(type,t); 312 } 313 314 void PETSC_STDCALL snesappendoptionsprefix_(SNES *snes,CHAR prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 315 { 316 char *t; 317 318 FIXCHAR(prefix,len,t); 319 *ierr = SNESAppendOptionsPrefix(*snes,t); 320 FREECHAR(prefix,t); 321 } 322 323 void PETSC_STDCALL snessetoptionsprefix_(SNES *snes,CHAR prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 324 { 325 char *t; 326 327 FIXCHAR(prefix,len,t); 328 *ierr = SNESSetOptionsPrefix(*snes,t); 329 FREECHAR(prefix,t); 330 } 331 332 /*----------------------------------------------------------------------*/ 333 /* functions, hence no STDCALL */ 334 335 void snesmonitorlg_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 336 { 337 *ierr = SNESMonitorLG(*snes,*its,*fgnorm,dummy); 338 } 339 340 void snesmonitordefault_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 341 { 342 *ierr = SNESMonitorDefault(*snes,*its,*fgnorm,dummy); 343 } 344 345 void snesmonitorsolution_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 346 { 347 *ierr = SNESMonitorSolution(*snes,*its,*fgnorm,dummy); 348 } 349 350 void snesmonitorsolutionupdate_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 351 { 352 *ierr = SNESMonitorSolutionUpdate(*snes,*its,*fgnorm,dummy); 353 } 354 355 356 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) 357 { 358 CHKFORTRANNULLOBJECT(mctx); 359 PetscObjectAllocateFortranPointers(*snes,12); 360 if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitordefault_) { 361 *ierr = SNESMonitorSet(*snes,SNESMonitorDefault,0,0); 362 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitorsolution_) { 363 *ierr = SNESMonitorSet(*snes,SNESMonitorSolution,0,0); 364 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitorsolutionupdate_) { 365 *ierr = SNESMonitorSet(*snes,SNESMonitorSolutionUpdate,0,0); 366 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesmonitorlg_) { 367 *ierr = SNESMonitorSet(*snes,SNESMonitorLG,0,0); 368 } else { 369 ((PetscObject)*snes)->fortran_func_pointers[3] = (PetscVoidFunction)func; 370 ((PetscObject)*snes)->fortran_func_pointers[4] = (PetscVoidFunction)mctx; 371 372 if (FORTRANNULLFUNCTION(mondestroy)){ 373 *ierr = SNESMonitorSet(*snes,oursnesmonitor,*snes,PETSC_NULL); 374 } else { 375 CHKFORTRANNULLFUNCTION(mondestroy); 376 ((PetscObject)*snes)->fortran_func_pointers[5] = (PetscVoidFunction)mondestroy; 377 *ierr = SNESMonitorSet(*snes,oursnesmonitor,*snes,ourmondestroy); 378 } 379 } 380 } 381 382 383 384 EXTERN_C_END 385