Actual source code: zepsf.c
1: /*
2: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3: SLEPc - Scalable Library for Eigenvalue Problem Computations
4: Copyright (c) 2002-, Universitat Politecnica de Valencia, Spain
6: This file is part of SLEPc.
7: SLEPc is distributed under a 2-clause BSD license (see LICENSE).
8: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
9: */
11: #include <petsc/private/ftnimpl.h>
12: #include <slepceps.h>
14: #if defined(PETSC_HAVE_FORTRAN_CAPS)
15: #define epsmonitorset_ EPSMONITORSET
16: #define epsmonitorall_ EPSMONITORALL
17: #define epsmonitorfirst_ EPSMONITORFIRST
18: #define epsmonitorconverged_ EPSMONITORCONVERGED
19: #define epsmonitorconvergedcreate_ EPSMONITORCONVERGEDCREATE
20: #define epsconvergedabsolute_ EPSCONVERGEDABSOLUTE
21: #define epsconvergedrelative_ EPSCONVERGEDRELATIVE
22: #define epsconvergednorm_ EPSCONVERGEDNORM
23: #define epssetconvergencetestfunction_ EPSSETCONVERGENCETESTFUNCTION
24: #define epsstoppingbasic_ EPSSTOPPINGBASIC
25: #define epsstoppingthreshold_ EPSSTOPPINGTHRESHOLD
26: #define epssetstoppingtestfunction_ EPSSETSTOPPINGTESTFUNCTION
27: #define epsseteigenvaluecomparison_ EPSSETEIGENVALUECOMPARISON
28: #define epssetarbitraryselection_ EPSSETARBITRARYSELECTION
29: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
30: #define epsmonitorset_ epsmonitorset
31: #define epsmonitorall_ epsmonitorall
32: #define epsmonitorfirst_ epsmonitorfirst
33: #define epsmonitorconverged_ epsmonitorconverged
34: #define epsmonitorconvergedcreate_ epsmonitorconvergedcreate
35: #define epsconvergedabsolute_ epsconvergedabsolute
36: #define epsconvergedrelative_ epsconvergedrelative
37: #define epsconvergednorm_ epsconvergednorm
38: #define epssetconvergencetestfunction_ epssetconvergencetestfunction
39: #define epsstoppingbasic_ epsstoppingbasic
40: #define epsstoppingthreshold_ epsstoppingthreshold
41: #define epssetstoppingtestfunction_ epssetstoppingtestfunction
42: #define epsseteigenvaluecomparison_ epsseteigenvaluecomparison
43: #define epssetarbitraryselection_ epssetarbitraryselection
44: #endif
46: /*
47: These cannot be called from Fortran but allow Fortran users
48: to transparently set these monitors from .F code
49: */
50: SLEPC_EXTERN void epsmonitorall_(EPS*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
51: SLEPC_EXTERN void epsmonitorfirst_(EPS*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
52: SLEPC_EXTERN void epsmonitorconverged_(EPS*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
54: SLEPC_EXTERN void epsmonitorconvergedcreate_(PetscViewer *vin,PetscViewerFormat *format,void *ctx,PetscViewerAndFormat **vf,PetscErrorCode *ierr)
55: {
56: PetscViewer v;
57: PetscPatchDefaultViewers_Fortran(vin,v);
58: CHKFORTRANNULLOBJECT(ctx);
59: *ierr = EPSMonitorConvergedCreate(v,*format,ctx,vf);
60: }
62: static struct {
63: PetscFortranCallbackId monitor;
64: PetscFortranCallbackId monitordestroy;
65: PetscFortranCallbackId convergence;
66: PetscFortranCallbackId convdestroy;
67: PetscFortranCallbackId stopping;
68: PetscFortranCallbackId stopdestroy;
69: PetscFortranCallbackId comparison;
70: PetscFortranCallbackId arbitrary;
71: } _cb;
73: /* These are not extern C because they are passed into non-extern C user level functions */
74: static PetscErrorCode ourmonitor(EPS eps,PetscInt i,PetscInt nc,PetscScalar *er,PetscScalar *ei,PetscReal *d,PetscInt l,void *ctx)
75: {
76: PetscObjectUseFortranCallback(eps,_cb.monitor,(EPS*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,void*,PetscErrorCode*),(&eps,&i,&nc,er,ei,d,&l,_ctx,&ierr));
77: }
79: static PetscErrorCode ourdestroy(PetscCtxRt ctx)
80: {
81: EPS eps = *(EPS*)ctx;
82: PetscObjectUseFortranCallback(eps,_cb.monitordestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
83: }
85: static PetscErrorCode ourconvergence(EPS eps,PetscScalar eigr,PetscScalar eigi,PetscReal res,PetscReal *errest,void *ctx)
86: {
87: PetscObjectUseFortranCallback(eps,_cb.convergence,(EPS*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*),(&eps,&eigr,&eigi,&res,errest,_ctx,&ierr));
88: }
90: static PetscErrorCode ourconvdestroy(PetscCtxRt ctx)
91: {
92: EPS eps = *(EPS*)ctx;
93: PetscObjectUseFortranCallback(eps,_cb.convdestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
94: }
96: static PetscErrorCode ourstopping(EPS eps,PetscInt its,PetscInt max_it,PetscInt nconv,PetscInt nev,EPSConvergedReason *reason,void *ctx)
97: {
98: PetscObjectUseFortranCallback(eps,_cb.stopping,(EPS*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,EPSConvergedReason*,void*,PetscErrorCode*),(&eps,&its,&max_it,&nconv,&nev,reason,_ctx,&ierr));
99: }
101: static PetscErrorCode ourstopdestroy(PetscCtxRt ctx)
102: {
103: EPS eps = *(EPS*)ctx;
104: PetscObjectUseFortranCallback(eps,_cb.stopdestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
105: }
107: static PetscErrorCode oureigenvaluecomparison(PetscScalar ar,PetscScalar ai,PetscScalar br,PetscScalar bi,PetscInt *r,void *ctx)
108: {
109: EPS eps = (EPS)ctx;
110: PetscObjectUseFortranCallback(eps,_cb.comparison,(PetscScalar*,PetscScalar*,PetscScalar*,PetscScalar*,PetscInt*,void*,PetscErrorCode*),(&ar,&ai,&br,&bi,r,_ctx,&ierr));
111: }
113: static PetscErrorCode ourarbitraryfunc(PetscScalar er,PetscScalar ei,Vec xr,Vec xi,PetscScalar *rr,PetscScalar *ri,void *ctx)
114: {
115: EPS eps = (EPS)ctx;
116: PetscObjectUseFortranCallback(eps,_cb.arbitrary,(PetscScalar*,PetscScalar*,Vec*,Vec*,PetscScalar*,PetscScalar*,void*,PetscErrorCode*),(&er,&ei,&xr,&xi,rr,ri,_ctx,&ierr));
117: }
119: SLEPC_EXTERN void epsmonitorset_(EPS *eps,void (*monitor)(EPS*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,void*,PetscErrorCode*),void *mctx,void (*monitordestroy)(void*,PetscErrorCode*),PetscErrorCode *ierr)
120: {
121: CHKFORTRANNULLOBJECT(mctx);
122: CHKFORTRANNULLFUNCTION(monitordestroy);
123: if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)epsmonitorall_) {
124: *ierr = EPSMonitorSet(*eps,(EPSMonitorFn*)EPSMonitorAll,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
125: } else if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)epsmonitorconverged_) {
126: *ierr = EPSMonitorSet(*eps,(EPSMonitorFn*)EPSMonitorConverged,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
127: } else if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)epsmonitorfirst_) {
128: *ierr = EPSMonitorSet(*eps,(EPSMonitorFn*)EPSMonitorFirst,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
129: } else {
130: *ierr = PetscObjectSetFortranCallback((PetscObject)*eps,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.monitor,(PetscFortranCallbackFn*)monitor,mctx); if (*ierr) return;
131: *ierr = PetscObjectSetFortranCallback((PetscObject)*eps,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.monitordestroy,(PetscFortranCallbackFn*)monitordestroy,mctx); if (*ierr) return;
132: *ierr = EPSMonitorSet(*eps,ourmonitor,*eps,ourdestroy);
133: }
134: }
136: SLEPC_EXTERN void epsconvergedabsolute_(EPS*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*);
137: SLEPC_EXTERN void epsconvergedrelative_(EPS*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*);
138: SLEPC_EXTERN void epsconvergednorm_(EPS*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*);
140: SLEPC_EXTERN void epssetconvergencetestfunction_(EPS *eps,void (*func)(EPS*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*),void *ctx,void (*destroy)(void*,PetscErrorCode*),PetscErrorCode *ierr)
141: {
142: CHKFORTRANNULLOBJECT(ctx);
143: CHKFORTRANNULLFUNCTION(destroy);
144: if (func == epsconvergedabsolute_) {
145: *ierr = EPSSetConvergenceTest(*eps,EPS_CONV_ABS);
146: } else if (func == epsconvergedrelative_) {
147: *ierr = EPSSetConvergenceTest(*eps,EPS_CONV_REL);
148: } else if (func == epsconvergednorm_) {
149: *ierr = EPSSetConvergenceTest(*eps,EPS_CONV_NORM);
150: } else {
151: *ierr = PetscObjectSetFortranCallback((PetscObject)*eps,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.convergence,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
152: *ierr = PetscObjectSetFortranCallback((PetscObject)*eps,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.convdestroy,(PetscFortranCallbackFn*)destroy,ctx); if (*ierr) return;
153: *ierr = EPSSetConvergenceTestFunction(*eps,ourconvergence,*eps,ourconvdestroy);
154: }
155: }
157: SLEPC_EXTERN void epsstoppingbasic_(EPS*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,EPSConvergedReason*,void*,PetscErrorCode*);
158: SLEPC_EXTERN void epsstoppingthreshold_(EPS*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,EPSConvergedReason*,void*,PetscErrorCode*);
160: SLEPC_EXTERN void epssetstoppingtestfunction_(EPS *eps,void (*func)(EPS*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,EPSConvergedReason*,void*,PetscErrorCode*),void *ctx,void (*destroy)(void*,PetscErrorCode*),PetscErrorCode *ierr)
161: {
162: CHKFORTRANNULLOBJECT(ctx);
163: CHKFORTRANNULLFUNCTION(destroy);
164: if (func == epsstoppingbasic_) {
165: *ierr = EPSSetStoppingTest(*eps,EPS_STOP_BASIC);
166: } else if (func == epsstoppingthreshold_) {
167: *ierr = EPSSetStoppingTest(*eps,EPS_STOP_THRESHOLD);
168: } else {
169: *ierr = PetscObjectSetFortranCallback((PetscObject)*eps,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.stopping,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
170: *ierr = PetscObjectSetFortranCallback((PetscObject)*eps,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.stopdestroy,(PetscFortranCallbackFn*)destroy,ctx); if (*ierr) return;
171: *ierr = EPSSetStoppingTestFunction(*eps,ourstopping,*eps,ourstopdestroy);
172: }
173: }
175: SLEPC_EXTERN void epsseteigenvaluecomparison_(EPS *eps,void (*func)(PetscScalar*,PetscScalar*,PetscScalar*,PetscScalar*,PetscInt*,void*),void *ctx,PetscErrorCode *ierr)
176: {
177: CHKFORTRANNULLOBJECT(ctx);
178: *ierr = PetscObjectSetFortranCallback((PetscObject)*eps,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.comparison,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
179: *ierr = EPSSetEigenvalueComparison(*eps,oureigenvaluecomparison,*eps);
180: }
182: SLEPC_EXTERN void epssetarbitraryselection_(EPS *eps,void (*func)(PetscScalar*,PetscScalar*,Vec*,Vec*,PetscScalar*,PetscScalar*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr)
183: {
184: CHKFORTRANNULLOBJECT(ctx);
185: *ierr = PetscObjectSetFortranCallback((PetscObject)*eps,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.arbitrary,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
186: *ierr = EPSSetArbitrarySelection(*eps,ourarbitraryfunc,*eps);
187: }