/*
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
SLEPc - Scalable Library for Eigenvalue Problem Computations
Copyright (c) 2002-2007, Universidad Politecnica de Valencia, Spain
This file is part of SLEPc. See the README file for conditions of use
and additional information.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*/
#include "private/fortranimpl.h"
#include "slepceps.h"
#include "private/epsimpl.h"
#ifdef PETSC_HAVE_FORTRAN_CAPS
#define epsview_ EPSVIEW
#define epssetoptionsprefix_ EPSSETOPTIONSPREFIX
#define epsappendoptionsprefix_ EPSAPPENDOPTIONSPREFIX
#define epsgetoptionsprefix_ EPSGETOPTIONSPREFIX
#define epscreate_ EPSCREATE
#define epssettype_ EPSSETTYPE
#define epsgettype_ EPSGETTYPE
#define epsmonitordefault_ EPSMONITORDEFAULT
#define epsmonitorlg_ EPSMONITORLG
#define epsmonitorset_ EPSMONITORSET
#define epsgetst_ EPSGETST
#define epsgetip_ EPSGETIP
#define epsgetwhicheigenpairs_ EPSGETWHICHEIGENPAIRS
#define epsgetproblemtype_ EPSGETPROBLEMTYPE
#define epsgetprojection_ EPSGETPROJECTION
#define epsgetclass_ EPSGETCLASS
#define epsgetconvergedreason_ EPSGETCONVERGEDREASON
#define epspowergetshifttype_ EPSPOWERGETSHIFTTYPE
#define epslanczosgetreorthog_ EPSLANCZOSGETREORTHOG
#elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
#define epsview_ epsview
#define epssetoptionsprefix_ epssetoptionsprefix
#define epsappendoptionsprefix_ epsappendoptionsprefix
#define epsgetoptionsprefix_ epsgetoptionsprefix
#define epscreate_ epscreate
#define epssettype_ epssettype
#define epsgettype_ epsgettype
#define epsmonitordefault_ epsmonitordefault
#define epsmonitorlg_ epsmonitorlg
#define epsmonitorset_ epsmonitorset
#define epsgetst_ epsgetst
#define epsgetip_ epsgetip
#define epsgetwhicheigenpairs_ epsgetwhicheigenpairs
#define epsgetproblemtype_ epsgetproblemtype
#define epsgetprojection_ epsgetprojection
#define epsgetclass_ epsgetclass
#define epsgetconvergedreason_ epsgetconvergedreason
#define epspowergetshifttype_ epspowergetshifttype
#define epslanczosgetreorthog_ epslanczosgetreorthog
#endif
EXTERN_C_BEGIN
static void (PETSC_STDCALL *f1)(EPS*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,void*,PetscErrorCode*);
static void (PETSC_STDCALL *f2)(void*,PetscErrorCode*);
/*
These are not usually called from Fortran but allow Fortran users
to transparently set these monitors from .F code, hence no STDCALL
*/
void epsmonitordefault_(EPS *eps,PetscInt *it,PetscInt *nconv,PetscScalar *eigr,PetscScalar *eigi,PetscReal *errest,PetscInt *nest,void *ctx,PetscErrorCode *ierr)
{
*ierr = EPSMonitorDefault(*eps,*it,*nconv,eigr,eigi,errest,*nest,ctx);
}
void epsmonitorlg_(EPS *eps,PetscInt *it,PetscInt *nconv,PetscScalar *eigr,PetscScalar *eigi,PetscReal *errest,PetscInt *nest,void *ctx,PetscErrorCode *ierr)
{
*ierr = EPSMonitorLG(*eps,*it,*nconv,eigr,eigi,errest,*nest,ctx);
}
EXTERN_C_END
/* These are not extern C because they are passed into non-extern C user level functions */
static PetscErrorCode ourmonitor(EPS eps,PetscInt i,PetscInt nc,PetscScalar *er,PetscScalar *ei,PetscReal *d,PetscInt l,void* ctx)
{
PetscErrorCode ierr = 0;
(*f1)(&eps,&i,&nc,er,ei,d,&l,ctx,&ierr);CHKERRQ(ierr);
return 0;
}
static PetscErrorCode ourdestroy(void* ctx)
{
PetscErrorCode ierr = 0;
(*f2)(ctx,&ierr);CHKERRQ(ierr);
return 0;
}
EXTERN_C_BEGIN
void PETSC_STDCALL epsview_(EPS *eps,PetscViewer *viewer, PetscErrorCode *ierr)
{
PetscViewer v;
PetscPatchDefaultViewers_Fortran(viewer,v);
*ierr = EPSView(*eps,v);
}
void PETSC_STDCALL epssettype_(EPS *eps,CHAR type PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
{
char *t;
FIXCHAR(type,len,t);
*ierr = EPSSetType(*eps,t);
FREECHAR(type,t);
}
void PETSC_STDCALL epsgettype_(EPS *eps,CHAR name PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
{
const EPSType tname;
*ierr = EPSGetType(*eps,&tname);if (*ierr) return;
#if defined(PETSC_USES_CPTOFCD)
{
char *t = _fcdtocp(name); int len1 = _fcdlen(name);
*ierr = PetscStrncpy(t,tname,len1);
}
#else
*ierr = PetscStrncpy(name,tname,len);
#endif
FIXRETURNCHAR(PETSC_TRUE,name,len);
}
void PETSC_STDCALL epssetoptionsprefix_(EPS *eps,CHAR prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
{
char *t;
FIXCHAR(prefix,len,t);
*ierr = EPSSetOptionsPrefix(*eps,t);
FREECHAR(prefix,t);
}
void PETSC_STDCALL epsappendoptionsprefix_(EPS *eps,CHAR prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
{
char *t;
FIXCHAR(prefix,len,t);
*ierr = EPSAppendOptionsPrefix(*eps,t);
FREECHAR(prefix,t);
}
void PETSC_STDCALL epscreate_(MPI_Fint *comm,EPS *eps,PetscErrorCode *ierr)
{
*ierr = EPSCreate(MPI_Comm_f2c(*(comm)),eps);
}
void PETSC_STDCALL epsmonitorset_(EPS *eps,void (PETSC_STDCALL *monitor)(EPS*,PetscInt*,PetscInt*,PetscScalar*,PetscScalar*,PetscReal*,PetscInt*,void*,PetscErrorCode*),
void *mctx,void (PETSC_STDCALL *monitordestroy)(void *,PetscErrorCode *),PetscErrorCode *ierr)
{
if ((void(*)())monitor == (void(*)())epsmonitordefault_) {
*ierr = EPSMonitorSet(*eps,EPSMonitorDefault,0,0);
} else if ((void(*)())monitor == (void(*)())epsmonitorlg_) {
*ierr = EPSMonitorSet(*eps,EPSMonitorLG,0,0);
} else {
f1 = monitor;
if (FORTRANNULLFUNCTION(monitordestroy)) {
*ierr = EPSMonitorSet(*eps,ourmonitor,mctx,0);
} else {
f2 = monitordestroy;
*ierr = EPSMonitorSet(*eps,ourmonitor,mctx,ourdestroy);
}
}
}
void PETSC_STDCALL epsgetoptionsprefix_(EPS *eps,CHAR prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
{
const char *tname;
*ierr = EPSGetOptionsPrefix(*eps,&tname);
#if defined(PETSC_USES_CPTOFCD)
{
char *t = _fcdtocp(prefix); int len1 = _fcdlen(prefix);
*ierr = PetscStrncpy(t,tname,len1); if (*ierr) return;
}
#else
*ierr = PetscStrncpy(prefix,tname,len); if (*ierr) return;
#endif
FIXRETURNCHAR(PETSC_TRUE,prefix,len);
}
void PETSC_STDCALL epsgetst_(EPS *eps,ST *st,PetscErrorCode *ierr)
{
*ierr = EPSGetST(*eps,st);
}
void PETSC_STDCALL epsgetip_(EPS *eps,IP *ip,PetscErrorCode *ierr)
{
*ierr = EPSGetIP(*eps,ip);
}
void PETSC_STDCALL epsgetwhicheigenpairs_(EPS *eps,EPSWhich *which,PetscErrorCode *ierr)
{
*ierr = EPSGetWhichEigenpairs(*eps,which);
}
void PETSC_STDCALL epsgetproblemtype_(EPS *eps,EPSProblemType *type,PetscErrorCode *ierr)
{
*ierr = EPSGetProblemType(*eps,type);
}
void PETSC_STDCALL epsgetprojection_(EPS *eps,EPSProjection *proj,PetscErrorCode *ierr)
{
*ierr = EPSGetProjection(*eps,proj);
}
void PETSC_STDCALL epsgetclass_(EPS *eps,EPSClass *cl,PetscErrorCode *ierr)
{
*ierr = EPSGetClass(*eps,cl);
}
void PETSC_STDCALL epsgetconvergedreason_(EPS *eps,EPSConvergedReason *reason,PetscErrorCode *ierr)
{
*ierr = EPSGetConvergedReason(*eps,reason);
}
void PETSC_STDCALL epspowergetshifttype_(EPS *eps,EPSPowerShiftType *shift,PetscErrorCode *ierr)
{
*ierr = EPSPowerGetShiftType(*eps,shift);
}
void PETSC_STDCALL epslanczosgetreorthog_(EPS *eps,EPSLanczosReorthogType *reorthog,PetscErrorCode *ierr)
{
*ierr = EPSLanczosGetReorthog(*eps,reorthog);
}
EXTERN_C_END