Actual source code: zpepf.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 <slepcpep.h>
14: #if defined(PETSC_HAVE_FORTRAN_CAPS)
15: #define pepmonitorset_ PEPMONITORSET
16: #define pepmonitorall_ PEPMONITORALL
17: #define pepmonitorfirst_ PEPMONITORFIRST
18: #define pepmonitorconverged_ PEPMONITORCONVERGED
19: #define pepmonitorconvergedcreate_ PEPMONITORCONVERGEDCREATE
20: #define pepconvergedabsolute_ PEPCONVERGEDABSOLUTE
21: #define pepconvergedrelative_ PEPCONVERGEDRELATIVE
22: #define pepsetconvergencetestfunction_ PEPSETCONVERGENCETESTFUNCTION
23: #define pepsetstoppingtestfunction_ PEPSETSTOPPINGTESTFUNCTION
24: #define pepseteigenvaluecomparison_ PEPSETEIGENVALUECOMPARISON
25: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
26: #define pepmonitorset_ pepmonitorset
27: #define pepmonitorall_ pepmonitorall
28: #define pepmonitorfirst_ pepmonitorfirst
29: #define pepmonitorconverged_ pepmonitorconverged
30: #define pepmonitorconvergedcreate_ pepmonitorconvergedcreate
31: #define pepconvergedabsolute_ pepconvergedabsolute
32: #define pepconvergedrelative_ pepconvergedrelative
33: #define pepsetconvergencetestfunction_ pepsetconvergencetestfunction
34: #define pepsetstoppingtestfunction_ pepsetstoppingtestfunction
35: #define pepseteigenvaluecomparison_ pepseteigenvaluecomparison
36: #endif
38: /*
39: These cannot be called from Fortran but allow Fortran users
40: to transparently set these monitors from .F code
41: */
42: SLEPC_EXTERN void pepmonitorall_(PEP*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
43: SLEPC_EXTERN void pepmonitorfirst_(PEP*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
44: SLEPC_EXTERN void pepmonitorconverged_(PEP*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,PetscViewerAndFormat*,PetscErrorCode*);
46: SLEPC_EXTERN void pepmonitorconvergedcreate_(PetscViewer *vin,PetscViewerFormat *format,void *ctx,PetscViewerAndFormat **vf,PetscErrorCode *ierr)
47: {
48: PetscViewer v;
49: PetscPatchDefaultViewers_Fortran(vin,v);
50: CHKFORTRANNULLOBJECT(ctx);
51: *ierr = PEPMonitorConvergedCreate(v,*format,ctx,vf);
52: }
54: static struct {
55: PetscFortranCallbackId monitor;
56: PetscFortranCallbackId monitordestroy;
57: PetscFortranCallbackId convergence;
58: PetscFortranCallbackId convdestroy;
59: PetscFortranCallbackId stopping;
60: PetscFortranCallbackId stopdestroy;
61: PetscFortranCallbackId comparison;
62: } _cb;
64: /* These are not extern C because they are passed into non-extern C user level functions */
65: static PetscErrorCode ourmonitor(PEP pep,PetscInt i,PetscInt nc,PetscScalar *er,PetscScalar *ei,PetscReal *d,PetscInt l,void *ctx)
66: {
67: PetscObjectUseFortranCallback(pep,_cb.monitor,(PEP*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,void*,PetscErrorCode*),(&pep,&i,&nc,er,ei,d,&l,_ctx,&ierr));
68: }
70: static PetscErrorCode ourdestroy(PetscCtxRt ctx)
71: {
72: PEP pep = *(PEP*)ctx;
73: PetscObjectUseFortranCallback(pep,_cb.monitordestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
74: }
76: static PetscErrorCode ourconvergence(PEP pep,PetscScalar eigr,PetscScalar eigi,PetscReal res,PetscReal *errest,void *ctx)
77: {
78: PetscObjectUseFortranCallback(pep,_cb.convergence,(PEP*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*),(&pep,&eigr,&eigi,&res,errest,_ctx,&ierr));
79: }
81: static PetscErrorCode ourconvdestroy(PetscCtxRt ctx)
82: {
83: PEP pep = *(PEP*)ctx;
84: PetscObjectUseFortranCallback(pep,_cb.convdestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
85: }
87: static PetscErrorCode ourstopping(PEP pep,PetscInt its,PetscInt max_it,PetscInt nconv,PetscInt nev,PEPConvergedReason *reason,void *ctx)
88: {
89: PetscObjectUseFortranCallback(pep,_cb.stopping,(PEP*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,PEPConvergedReason*,void*,PetscErrorCode*),(&pep,&its,&max_it,&nconv,&nev,reason,_ctx,&ierr));
90: }
92: static PetscErrorCode ourstopdestroy(PetscCtxRt ctx)
93: {
94: PEP pep = *(PEP*)ctx;
95: PetscObjectUseFortranCallback(pep,_cb.stopdestroy,(void*,PetscErrorCode*),(_ctx,&ierr));
96: }
98: static PetscErrorCode oureigenvaluecomparison(PetscScalar ar,PetscScalar ai,PetscScalar br,PetscScalar bi,PetscInt *r,void *ctx)
99: {
100: PEP pep = (PEP)ctx;
101: PetscObjectUseFortranCallback(pep,_cb.comparison,(PetscScalar*,PetscScalar*,PetscScalar*,PetscScalar*,PetscInt*,void*,PetscErrorCode*),(&ar,&ai,&br,&bi,r,_ctx,&ierr));
102: }
104: SLEPC_EXTERN void pepmonitorset_(PEP *pep,void (*monitor)(PEP*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,void*,PetscErrorCode*),void *mctx,void (*monitordestroy)(void*,PetscErrorCode*),PetscErrorCode *ierr)
105: {
106: CHKFORTRANNULLOBJECT(mctx);
107: CHKFORTRANNULLFUNCTION(monitordestroy);
108: if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)pepmonitorall_) {
109: *ierr = PEPMonitorSet(*pep,(PEPMonitorFn*)PEPMonitorAll,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
110: } else if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)pepmonitorconverged_) {
111: *ierr = PEPMonitorSet(*pep,(PEPMonitorFn*)PEPMonitorConverged,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
112: } else if ((PetscFortranCallbackFn*)monitor == (PetscFortranCallbackFn*)pepmonitorfirst_) {
113: *ierr = PEPMonitorSet(*pep,(PEPMonitorFn*)PEPMonitorFirst,*(PetscViewerAndFormat**)mctx,(PetscCtxDestroyFn*)PetscViewerAndFormatDestroy);
114: } else {
115: *ierr = PetscObjectSetFortranCallback((PetscObject)*pep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.monitor,(PetscFortranCallbackFn*)monitor,mctx); if (*ierr) return;
116: *ierr = PetscObjectSetFortranCallback((PetscObject)*pep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.monitordestroy,(PetscFortranCallbackFn*)monitordestroy,mctx); if (*ierr) return;
117: *ierr = PEPMonitorSet(*pep,ourmonitor,*pep,ourdestroy);
118: }
119: }
121: SLEPC_EXTERN void pepconvergedabsolute_(PEP*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*);
122: SLEPC_EXTERN void pepconvergedrelative_(PEP*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*);
124: SLEPC_EXTERN void pepsetconvergencetestfunction_(PEP *pep,void (*func)(PEP*,PetscScalar*,PetscScalar*,PetscReal*,PetscReal*,void*,PetscErrorCode*),void *ctx,void (*destroy)(void*,PetscErrorCode*),PetscErrorCode *ierr)
125: {
126: CHKFORTRANNULLOBJECT(ctx);
127: CHKFORTRANNULLFUNCTION(destroy);
128: if (func == pepconvergedabsolute_) {
129: *ierr = PEPSetConvergenceTest(*pep,PEP_CONV_ABS);
130: } else if (func == pepconvergedrelative_) {
131: *ierr = PEPSetConvergenceTest(*pep,PEP_CONV_REL);
132: } else {
133: *ierr = PetscObjectSetFortranCallback((PetscObject)*pep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.convergence,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
134: *ierr = PetscObjectSetFortranCallback((PetscObject)*pep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.convdestroy,(PetscFortranCallbackFn*)destroy,ctx); if (*ierr) return;
135: *ierr = PEPSetConvergenceTestFunction(*pep,ourconvergence,*pep,ourconvdestroy);
136: }
137: }
139: SLEPC_EXTERN void pepstoppingbasic_(PEP*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,PEPConvergedReason*,void*,PetscErrorCode*);
141: SLEPC_EXTERN void pepsetstoppingtestfunction_(PEP *pep,void (*func)(PEP*,PetscInt*,PetscInt*,PetscInt*,PetscInt*,PEPConvergedReason*,void*,PetscErrorCode*),void *ctx,void (*destroy)(void*,PetscErrorCode*),PetscErrorCode *ierr)
142: {
143: CHKFORTRANNULLOBJECT(ctx);
144: CHKFORTRANNULLFUNCTION(destroy);
145: if (func == pepstoppingbasic_) {
146: *ierr = PEPSetStoppingTest(*pep,PEP_STOP_BASIC);
147: } else {
148: *ierr = PetscObjectSetFortranCallback((PetscObject)*pep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.stopping,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
149: *ierr = PetscObjectSetFortranCallback((PetscObject)*pep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.stopdestroy,(PetscFortranCallbackFn*)destroy,ctx); if (*ierr) return;
150: *ierr = PEPSetStoppingTestFunction(*pep,ourstopping,*pep,ourstopdestroy);
151: }
152: }
154: SLEPC_EXTERN void pepseteigenvaluecomparison_(PEP *pep,void (*func)(PetscScalar*,PetscScalar*,PetscScalar*,PetscScalar*,PetscInt*,void*),void *ctx,PetscErrorCode *ierr)
155: {
156: CHKFORTRANNULLOBJECT(ctx);
157: *ierr = PetscObjectSetFortranCallback((PetscObject)*pep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.comparison,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
158: *ierr = PEPSetEigenvalueComparison(*pep,oureigenvaluecomparison,*pep);
159: }