1 #include "zpetsc.h" 2 #include "petscsnes.h" 3 4 #ifdef PETSC_HAVE_FORTRAN_UNDERSCORE_UNDERSCORE 5 #define snesconverged_tr_ snesconverged_tr__ 6 #define snesconverged_ls_ snesconverged_ls__ 7 #endif 8 9 #if defined(PETSC_HAVE_FORTRAN_CAPS) 10 #define snessolve_ SNESSOLVE 11 #define snesdefaultcomputejacobian_ SNESDEFAULTCOMPUTEJACOBIAN 12 #define snesdefaultcomputejacobiancolor_ SNESDEFAULTCOMPUTEJACOBIANCOLOR 13 #define snesdacomputejacobian_ SNESDACOMPUTEJACOBIAN 14 #define snesdacomputejacobianwithadifor_ SNESDACOMPUTEJACOBIANWITHADIFOR 15 #define snessetjacobian_ SNESSETJACOBIAN 16 #define snesgetoptionsprefix_ SNESGETOPTIONSPREFIX 17 #define snesgettype_ SNESGETTYPE 18 #define snesdaformfunction_ SNESDAFORMFUNCTION 19 #define snessetfunction_ SNESSETFUNCTION 20 #define snesgetfunction_ SNESGETFUNCTION 21 #define snessetconvergencetest_ SNESSETCONVERGENCETEST 22 #define snesconverged_tr_ SNESCONVERGED_TR 23 #define snesconverged_ls_ SNESCONVERGED_LS 24 #define snesview_ SNESVIEW 25 #define snesgetconvergencehistory_ SNESGETCONVERGENCEHISTORY 26 #define snesgetjacobian_ SNESGETJACOBIAN 27 #define snessettype_ SNESSETTYPE 28 #define snesappendoptionsprefix_ SNESAPPENDOPTIONSPREFIX 29 #define snessetoptionsprefix_ SNESSETOPTIONSPREFIX 30 #define snesdefaultmonitor_ SNESDEFAULTMONITOR 31 #define snesvecviewmonitor_ SNESVECVIEWMONITOR 32 #define sneslgmonitor_ SNESLGMONITOR 33 #define snesvecviewupdatemonitor_ SNESVECVIEWUPDATEMONITOR 34 #define snessetmonitor_ SNESSETMONITOR 35 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 36 #define snessolve_ snessolve 37 #define snesdefaultcomputejacobian_ snesdefaultcomputejacobian 38 #define snesdefaultcomputejacobiancolor_ snesdefaultcomputejacobiancolor 39 #define snesdacomputejacobian_ snesdacomputejacobian 40 #define snesdacomputejacobianwithadifor_ snesdacomputejacobianwithadifor 41 #define snessetjacobian_ snessetjacobian 42 #define snesgetoptionsprefix_ snesgetoptionsprefix 43 #define snesgettype_ snesgettype 44 #define snesdaformfunction_ snesdaformfunction 45 #define snessetfunction_ snessetfunction 46 #define snesgetfunction_ snesgetfunction 47 #define snessetconvergencetest_ snessetconvergencetest 48 #define snesconverged_tr_ snesconverged_tr 49 #define snesconverged_ls_ snesconverged_ls 50 #define snesview_ snesview 51 #define snesgetjacobian_ snesgetjacobian 52 #define snesgetconvergencehistory_ snesgetconvergencehistory 53 #define snessettype_ snessettype 54 #define snesappendoptionsprefix_ snesappendoptionsprefix 55 #define snessetoptionsprefix_ snessetoptionsprefix 56 #define sneslgmonitor_ sneslgmonitor 57 #define snesdefaultmonitor_ snesdefaultmonitor 58 #define snesvecviewmonitor_ snesvecviewmonitor 59 #define snesvecviewupdatemonitor_ snesvecviewupdatemonitor 60 #define snessetmonitor_ snessetmonitor 61 #endif 62 63 EXTERN_C_BEGIN 64 static void (PETSC_STDCALL *f3)(SNES*,Vec*,Mat*,Mat*,MatStructure*,void*,PetscErrorCode*); 65 static void (PETSC_STDCALL *f2)(SNES*,Vec*,Vec*,void*,PetscErrorCode*); 66 static void (PETSC_STDCALL *f8)(SNES*,PetscInt *,PetscReal*,PetscReal*,PetscReal*,SNESConvergedReason*,void*,PetscErrorCode*); 67 static void (PETSC_STDCALL *f7)(SNES*,PetscInt*,PetscReal*,void*,PetscErrorCode*); 68 static void (PETSC_STDCALL *f71)(void*,PetscErrorCode*); 69 EXTERN_C_END 70 71 static PetscErrorCode oursnesfunction(SNES snes,Vec x,Vec f,void *ctx) 72 { 73 PetscErrorCode ierr = 0; 74 (*f2)(&snes,&x,&f,ctx,&ierr);CHKERRQ(ierr); 75 return 0; 76 } 77 static PetscErrorCode oursnestest(SNES snes,PetscInt it,PetscReal a,PetscReal d,PetscReal c,SNESConvergedReason*reason,void*ctx) 78 { 79 PetscErrorCode ierr = 0; 80 81 (*f8)(&snes,&it,&a,&d,&c,reason,ctx,&ierr);CHKERRQ(ierr); 82 return 0; 83 } 84 85 static PetscErrorCode oursnesjacobian(SNES snes,Vec x,Mat* m,Mat* p,MatStructure* type,void*ctx) 86 { 87 PetscErrorCode ierr = 0; 88 (*f3)(&snes,&x,m,p,type,ctx,&ierr);CHKERRQ(ierr); 89 return 0; 90 } 91 static PetscErrorCode oursnesmonitor(SNES snes,PetscInt i,PetscReal d,void*ctx) 92 { 93 PetscErrorCode ierr = 0; 94 95 (*f7)(&snes,&i,&d,ctx,&ierr);CHKERRQ(ierr); 96 return 0; 97 } 98 static PetscErrorCode ourmondestroy(void* ctx) 99 { 100 PetscErrorCode ierr = 0; 101 102 (*f71)(ctx,&ierr);CHKERRQ(ierr); 103 return 0; 104 } 105 106 EXTERN_C_BEGIN 107 /* ---------------------------------------------------------*/ 108 /* 109 snesdefaultcomputejacobian() and snesdefaultcomputejacobiancolor() 110 These can be used directly from Fortran but are mostly so that 111 Fortran SNESSetJacobian() will properly handle the defaults being passed in. 112 113 functions, hence no STDCALL 114 */ 115 void snesdefaultcomputejacobian_(SNES *snes,Vec *x,Mat *m,Mat *p,MatStructure* type,void *ctx,PetscErrorCode *ierr) 116 { 117 *ierr = SNESDefaultComputeJacobian(*snes,*x,m,p,type,ctx); 118 } 119 void snesdefaultcomputejacobiancolor_(SNES *snes,Vec *x,Mat *m,Mat *p,MatStructure* type,void *ctx,PetscErrorCode *ierr) 120 { 121 *ierr = SNESDefaultComputeJacobianColor(*snes,*x,m,p,type,*(MatFDColoring*)ctx); 122 } 123 124 void snesdacomputejacobianwithadifor_(SNES *snes,Vec *X,Mat *m,Mat *p,MatStructure* type,void *ctx,PetscErrorCode *ierr) 125 { 126 (*PetscErrorPrintf)("Cannot call this function from Fortran"); 127 *ierr = 1; 128 } 129 130 void snesdacomputejacobian_(SNES *snes,Vec *X,Mat *m,Mat *p,MatStructure* type,void *ctx,PetscErrorCode *ierr) 131 { 132 (*PetscErrorPrintf)("Cannot call this function from Fortran"); 133 *ierr = 1; 134 } 135 136 void PETSC_STDCALL snessetjacobian_(SNES *snes,Mat *A,Mat *B,void (PETSC_STDCALL *func)(SNES*,Vec*,Mat*,Mat*, 137 MatStructure*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr) 138 { 139 CHKFORTRANNULLOBJECT(ctx); 140 if ((PetscVoidFunction)func == (PetscVoidFunction)snesdefaultcomputejacobian_) { 141 *ierr = SNESSetJacobian(*snes,*A,*B,SNESDefaultComputeJacobian,ctx); 142 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesdefaultcomputejacobiancolor_) { 143 *ierr = SNESSetJacobian(*snes,*A,*B,SNESDefaultComputeJacobianColor,*(MatFDColoring*)ctx); 144 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesdacomputejacobianwithadifor_) { 145 *ierr = SNESSetJacobian(*snes,*A,*B,SNESDAComputeJacobianWithAdifor,ctx); 146 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesdacomputejacobian_) { 147 *ierr = SNESSetJacobian(*snes,*A,*B,SNESDAComputeJacobian,ctx); 148 } else { 149 f3 = func; 150 *ierr = SNESSetJacobian(*snes,*A,*B,oursnesjacobian,ctx); 151 } 152 } 153 /* -------------------------------------------------------------*/ 154 155 void PETSC_STDCALL snessolve_(SNES *snes,Vec *b,Vec *x, int *__ierr ) 156 { 157 Vec B = *b; 158 if (*b == PETSC_NULL_OBJECT_Fortran) B = PETSC_NULL; 159 *__ierr = SNESSolve(*snes,B,*x); 160 } 161 162 void PETSC_STDCALL snesgetoptionsprefix_(SNES *snes,CHAR prefix PETSC_MIXED_LEN(len), 163 PetscErrorCode *ierr PETSC_END_LEN(len)) 164 { 165 const char *tname; 166 167 *ierr = SNESGetOptionsPrefix(*snes,&tname); 168 #if defined(PETSC_USES_CPTOFCD) 169 { 170 char *t = _fcdtocp(prefix); int len1 = _fcdlen(prefix); 171 *ierr = PetscStrncpy(t,tname,len1);if (*ierr) return; 172 } 173 #else 174 *ierr = PetscStrncpy(prefix,tname,len);if (*ierr) return; 175 #endif 176 } 177 178 void PETSC_STDCALL snesgettype_(SNES *snes,CHAR name PETSC_MIXED_LEN(len), 179 PetscErrorCode *ierr PETSC_END_LEN(len)) 180 { 181 const char *tname; 182 183 *ierr = SNESGetType(*snes,&tname); 184 #if defined(PETSC_USES_CPTOFCD) 185 { 186 char *t = _fcdtocp(name); int len1 = _fcdlen(name); 187 *ierr = PetscStrncpy(t,tname,len1);if (*ierr) return; 188 } 189 #else 190 *ierr = PetscStrncpy(name,tname,len);if (*ierr) return; 191 #endif 192 FIXRETURNCHAR(name,len); 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 snesdaformfunction_(SNES *snes,Vec *X, Vec *F,void *ptr,PetscErrorCode *ierr) 203 { 204 *ierr = SNESDAFormFunction(*snes,*X,*F,ptr); 205 } 206 207 void PETSC_STDCALL snessetfunction_(SNES *snes,Vec *r,void (PETSC_STDCALL *func)(SNES*,Vec*,Vec*,void*,PetscErrorCode*), 208 void *ctx,PetscErrorCode *ierr) 209 { 210 CHKFORTRANNULLOBJECT(ctx); 211 f2 = func; 212 if ((PetscVoidFunction)func == (PetscVoidFunction)snesdaformfunction_) { 213 *ierr = SNESSetFunction(*snes,*r,SNESDAFormFunction,ctx); 214 } else { 215 *ierr = SNESSetFunction(*snes,*r,oursnesfunction,ctx); 216 } 217 } 218 /* ---------------------------------------------------------*/ 219 220 /* the func argument is ignored */ 221 void PETSC_STDCALL snesgetfunction_(SNES *snes,Vec *r,void *func,void **ctx,PetscErrorCode *ierr) 222 { 223 CHKFORTRANNULLINTEGER(ctx); 224 CHKFORTRANNULLOBJECT(r); 225 *ierr = SNESGetFunction(*snes,r,PETSC_NULL,ctx); 226 } 227 /*----------------------------------------------------------------------*/ 228 229 void snesconverged_tr_(SNES *snes,PetscInt *it,PetscReal *a,PetscReal *b,PetscReal *c,SNESConvergedReason *r, 230 void *ct,PetscErrorCode *ierr) 231 { 232 *ierr = SNESConverged_TR(*snes,*it,*a,*b,*c,r,ct); 233 } 234 235 void snesconverged_ls_(SNES *snes,PetscInt *it, PetscReal *a,PetscReal *b,PetscReal *c,SNESConvergedReason *r, 236 void *ct,PetscErrorCode *ierr) 237 { 238 *ierr = SNESConverged_LS(*snes,*it,*a,*b,*c,r,ct); 239 } 240 241 242 void PETSC_STDCALL snessetconvergencetest_(SNES *snes, 243 void (PETSC_STDCALL *func)(SNES*,PetscInt*,PetscReal*,PetscReal*,PetscReal*,SNESConvergedReason*,void*,PetscErrorCode*), 244 void *cctx,PetscErrorCode *ierr) 245 { 246 CHKFORTRANNULLOBJECT(cctx); 247 if ((PetscVoidFunction)func == (PetscVoidFunction)snesconverged_ls_){ 248 *ierr = SNESSetConvergenceTest(*snes,SNESConverged_LS,0); 249 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesconverged_tr_){ 250 *ierr = SNESSetConvergenceTest(*snes,SNESConverged_TR,0); 251 } else { 252 f8 = func; 253 *ierr = SNESSetConvergenceTest(*snes,oursnestest,cctx); 254 } 255 } 256 /*----------------------------------------------------------------------*/ 257 258 void PETSC_STDCALL snesview_(SNES *snes,PetscViewer *viewer, PetscErrorCode *ierr) 259 { 260 PetscViewer v; 261 PetscPatchDefaultViewers_Fortran(viewer,v); 262 *ierr = SNESView(*snes,v); 263 } 264 265 /* func is currently ignored from Fortran */ 266 void PETSC_STDCALL snesgetjacobian_(SNES *snes,Mat *A,Mat *B,int *func,void **ctx,PetscErrorCode *ierr) 267 { 268 CHKFORTRANNULLINTEGER(ctx); 269 CHKFORTRANNULLOBJECT(A); 270 CHKFORTRANNULLOBJECT(B); 271 *ierr = SNESGetJacobian(*snes,A,B,0,ctx); 272 } 273 274 void PETSC_STDCALL snesgetconvergencehistory_(SNES *snes,PetscInt *na,PetscErrorCode *ierr) 275 { 276 *ierr = SNESGetConvergenceHistory(*snes,PETSC_NULL,PETSC_NULL,na); 277 } 278 279 void PETSC_STDCALL snessettype_(SNES *snes,CHAR type PETSC_MIXED_LEN(len), 280 PetscErrorCode *ierr PETSC_END_LEN(len)) 281 { 282 char *t; 283 284 FIXCHAR(type,len,t); 285 *ierr = SNESSetType(*snes,t); 286 FREECHAR(type,t); 287 } 288 289 void PETSC_STDCALL snesappendoptionsprefix_(SNES *snes,CHAR prefix PETSC_MIXED_LEN(len), 290 PetscErrorCode *ierr PETSC_END_LEN(len)) 291 { 292 char *t; 293 294 FIXCHAR(prefix,len,t); 295 *ierr = SNESAppendOptionsPrefix(*snes,t); 296 FREECHAR(prefix,t); 297 } 298 299 void PETSC_STDCALL snessetoptionsprefix_(SNES *snes,CHAR prefix PETSC_MIXED_LEN(len), 300 PetscErrorCode *ierr PETSC_END_LEN(len)) 301 { 302 char *t; 303 304 FIXCHAR(prefix,len,t); 305 *ierr = SNESSetOptionsPrefix(*snes,t); 306 FREECHAR(prefix,t); 307 } 308 309 /*----------------------------------------------------------------------*/ 310 /* functions, hence no STDCALL */ 311 312 void sneslgmonitor_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 313 { 314 *ierr = SNESLGMonitor(*snes,*its,*fgnorm,dummy); 315 } 316 317 void snesdefaultmonitor_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 318 { 319 *ierr = SNESDefaultMonitor(*snes,*its,*fgnorm,dummy); 320 } 321 322 void snesvecviewmonitor_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 323 { 324 *ierr = SNESVecViewMonitor(*snes,*its,*fgnorm,dummy); 325 } 326 327 void snesvecviewupdatemonitor_(SNES *snes,PetscInt *its,PetscReal *fgnorm,void *dummy,PetscErrorCode *ierr) 328 { 329 *ierr = SNESVecViewUpdateMonitor(*snes,*its,*fgnorm,dummy); 330 } 331 332 333 void PETSC_STDCALL snessetmonitor_(SNES *snes,void (PETSC_STDCALL *func)(SNES*,PetscInt*,PetscReal*,void*,PetscErrorCode*), 334 void *mctx,void (PETSC_STDCALL *mondestroy)(void*,PetscErrorCode*),PetscErrorCode *ierr) 335 { 336 CHKFORTRANNULLOBJECT(mctx); 337 if ((PetscVoidFunction)func == (PetscVoidFunction)snesdefaultmonitor_) { 338 *ierr = SNESSetMonitor(*snes,SNESDefaultMonitor,0,0); 339 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesvecviewmonitor_) { 340 *ierr = SNESSetMonitor(*snes,SNESVecViewMonitor,0,0); 341 } else if ((PetscVoidFunction)func == (PetscVoidFunction)snesvecviewupdatemonitor_) { 342 *ierr = SNESSetMonitor(*snes,SNESVecViewUpdateMonitor,0,0); 343 } else if ((PetscVoidFunction)func == (PetscVoidFunction)sneslgmonitor_) { 344 *ierr = SNESSetMonitor(*snes,SNESLGMonitor,0,0); 345 } else { 346 f7 = func; 347 if (FORTRANNULLFUNCTION(mondestroy)){ 348 *ierr = SNESSetMonitor(*snes,oursnesmonitor,mctx,0); 349 } else { 350 f71 = mondestroy; 351 *ierr = SNESSetMonitor(*snes,oursnesmonitor,mctx,ourmondestroy); 352 } 353 } 354 } 355 356 357 358 EXTERN_C_END 359