/****************************************************************************/
/* This file is part of FreeFEM.                                            */
/*                                                                          */
/* FreeFEM is free software: you can redistribute it and/or modify          */
/* it under the terms of the GNU Lesser General Public License as           */
/* published by the Free Software Foundation, either version 3 of           */
/* the License, or (at your option) any later version.                      */
/*                                                                          */
/* FreeFEM is distributed in the hope that it will be useful,               */
/* but WITHOUT ANY WARRANTY; without even the implied warranty of           */
/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the            */
/* GNU Lesser General Public License for more details.                      */
/*                                                                          */
/* You should have received a copy of the GNU Lesser General Public License */
/* along with FreeFEM. If not, see <http://www.gnu.org/licenses/>.          */
/****************************************************************************/
// SUMMARY : The FreeFEM arpack interface without arpack++
// LICENSE : LGPLv3
// ORG     : LJLL Universite Pierre et Marie Curie, Paris, FRANCE
// AUTHORS : Frederic Hecht
// E-MAIL  : frederic.hecht@sorbonne-universite.fr

/*
  Arpack++ is too old and do too much c++ error with modern compiler
  but a tanks to arpack++ for the idea of this code
*/

// Change V[1] -> V[0]
// Change workev[1] -> workev[0]
#ifndef ARPACKFF_HPP
#define ARPACKFF_HPP
#include "error.hpp"

typedef int integer;
typedef int logical;

#define F77NAME(x) x ## _

#define HIDDEN_HBW , int, int, int
#define HIDDEN_BW , int, int
#define HIDDEN_12 , 1, 2
#define HIDDEN_112 , 1, 1, 2

extern "C" {
  /*
  // debug "common" statement.

  struct {
    integer logfil, ndigit, mgetv0;
    integer msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd;
    integer mnaupd, mnaup2, mnaitr, mneigt, mnapps, mngets, mneupd;
    integer mcaupd, mcaup2, mcaitr, mceigt, mcapps, mcgets, mceupd;
  } F77NAME(debug);

  // add FH for dynamic lib on win 32
  struct {
    integer nopx, nbx, nrorth, nitref, nrstrt;
    float tsaupd, tsaup2, tsaitr, tseigt, tsgets, tsapps, tsconv,
      tnaupd, tnaup2, tnaitr, tneigh, tngets, tnapps, tnconv,
      tcaupd, tcaup2, tcaitr, tceigh, tcgets, tcapps, tcconv,
      tmvopx, tmvbx, tgetv0, titref, trvec;
  } F77NAME(timing);
  */

  // double precision symmetric routines
  void F77NAME(dsaupd)(
    integer *ido, char *bmat, integer *n, char *which,
    integer *nev, double *tol, double *resid,
    integer *ncv, double *V, integer *ldv,
    integer *iparam, integer *ipntr, double *workd,
    double *workl, integer *lworkl, integer *info HIDDEN_BW);

  void F77NAME(dseupd)(
    logical *rvec, char *HowMny, logical *select,
    double *d, double *Z, integer *ldz,
    double *sigma, char *bmat, integer *n,
    char *which, integer *nev, double *tol,
    double *resid, integer *ncv, double *V,
    integer *ldv, integer *iparam, integer *ipntr,
    double *workd, double *workl,
    integer *lworkl, integer *info HIDDEN_HBW);

  // double precision nonsymmetric routines
  void F77NAME(dnaupd)(
    integer *ido, char *bmat, integer *n, char *which,
    integer *nev, double *tol, double *resid,
    integer *ncv, double *V, integer *ldv,
    integer *iparam, integer *ipntr, double *workd,
    double *workl, integer *lworkl, integer *info HIDDEN_BW);

  void F77NAME(dneupd)(
    logical *rvec, char *HowMny, logical *select,
    double *dr, double *di, double *Z,
    integer *ldz, double *sigmar,
    double *sigmai, double *workev,
    char *bmat, integer *n, char *which,
    integer *nev, double *tol, double *resid,
    integer *ncv, double *V, integer *ldv,
    integer *iparam, integer *ipntr,
    double *workd, double *workl,
    integer *lworkl, integer *info HIDDEN_HBW);

  // single precision symmetric routines
  void F77NAME(ssaupd)(
    integer *ido, char *bmat, integer *n, char *which,
    integer *nev, float *tol, float *resid,
    integer *ncv, float *V, integer *ldv,
    integer *iparam, integer *ipntr, float *workd,
    float *workl, integer *lworkl, integer *info HIDDEN_BW);

  void F77NAME(sseupd)(
    logical *rvec, char *HowMny, logical *select,
    float *d, float *Z, integer *ldz,
    float *sigma, char *bmat, integer *n,
    char *which, integer *nev, float *tol,
    float *resid, integer *ncv, float *V,
    integer *ldv, integer *iparam, integer *ipntr,
    float *workd, float *workl,
    integer *lworkl, integer *info HIDDEN_HBW);

  // single precision nonsymmetric routines
  void F77NAME(snaupd)(
    integer *ido, char *bmat, integer *n, char *which,
    integer *nev, float *tol, float *resid,
    integer *ncv, float *V, integer *ldv,
    integer *iparam, integer *ipntr, float *workd,
    float *workl, integer *lworkl, integer *info HIDDEN_BW);

  void F77NAME(sneupd)(
    logical *rvec, char *HowMny, logical *select,
    float *dr, float *di, float *Z,
    integer *ldz, float *sigmar,
    float *sigmai, float *workev, char *bmat,
    integer *n, char *which, integer *nev,
    float *tol, float *resid, integer *ncv,
    float *V, integer *ldv, integer *iparam,
    integer *ipntr, float *workd, float *workl,
    integer *lworkl, integer *info HIDDEN_HBW);


  void F77NAME(cnaupd)(
    integer *ido, char *bmat, integer *n, char *which,
    integer *nev, float *tol, complex<float> *resid,
    integer *ncv, complex<float> *V, integer *ldv,
    integer *iparam, integer *ipntr, complex<float> *workd,
    complex<float> *workl, integer *lworkl,
    float *rwork, integer *info HIDDEN_BW);

  void F77NAME(cneupd)(
    logical *rvec, char *HowMny, logical *select,
    complex<float> *d, complex<float> *Z, integer *ldz,
    complex<float> *sigma, complex<float> *workev,
    char *bmat, integer *n, char *which, integer *nev,
    float *tol, complex<float> *resid, integer *ncv,
    complex<float> *V, integer *ldv, integer *iparam,
    integer *ipntr, complex<float> *workd,
    complex<float> *workl, integer *lworkl,
    float *rwork, integer *info HIDDEN_HBW);

  // double precision complex routines
  void F77NAME(znaupd)(
    integer *ido, char *bmat, integer *n, char *which,
    integer *nev, double *tol, complex<double> *resid,
    integer *ncv, complex<double> *V, integer *ldv,
    integer *iparam, integer *ipntr, complex<double> *workd,
    complex<double> *workl, integer *lworkl,
    double *rwork, integer *info HIDDEN_BW);

  void F77NAME(zneupd)(
    logical *rvec, char *HowMny, logical *select,
    complex<double> *d, complex<double> *Z, integer *ldz,
    complex<double> *sigma, complex<double> *workev,
    char *bmat, integer *n, char *which, integer *nev,
    double *tol, complex<double> *resid, integer *ncv,
    complex<double> *V, integer *ldv, integer *iparam,
    integer *ipntr, complex<double> *workd,
    complex<double> *workl, integer *lworkl,
    double *rwork, integer *info HIDDEN_HBW);
}

inline void saupp (
  int& ido, char bmat, int n, char* which, int nev,
  double& tol, double resid[], int ncv, double V[],
  int ldv, int iparam[], int ipntr[], double workd[],
  double workl[], int lworkl, int& info) {

  F77NAME(dsaupd)(
    &ido, &bmat, &n, which, &nev, &tol, resid, &ncv,
    &V[0], &ldv, &iparam[1], &ipntr[1], &workd[1], &workl[1],
    &lworkl, &info HIDDEN_12);
} // saupp (double)

inline void saupp (
  int& ido, char bmat, int n, char* which, int nev,
  float& tol, float resid[], int ncv, float V[],
  int ldv, int iparam[], int ipntr[], float workd[],
  float workl[], int lworkl, int& info) {

  F77NAME(ssaupd)(
    &ido, &bmat, &n, which, &nev, &tol, resid, &ncv,
    &V[0], &ldv, &iparam[1], &ipntr[1], &workd[1], &workl[1],
    &lworkl, &info HIDDEN_12);
} // saupp (float)

inline void seupp (
  bool rvec, char HowMny, double d[], double Z[],
  int ldz, double sigma, char bmat, int n,
  char* which, int nev, double tol, double resid[],
  int ncv, double V[], int ldv, int iparam[],
  int ipntr[], double workd[], double workl[],
  int lworkl, int& info) {

  int irvec;
  logical *iselect;
  double *iZ;

  irvec = (int)rvec;
  iselect = new logical[ncv];
  iZ = (Z == NULL) ? &V[0] : Z;

  F77NAME(dseupd)(
    &irvec, &HowMny, iselect, d, iZ, &ldz, &sigma, &bmat,
    &n, which, &nev, &tol, resid, &ncv, &V[0], &ldv, &iparam[1],
    &ipntr[1], &workd[1], &workl[1], &lworkl, &info HIDDEN_112);

  delete[] iselect;
} // seupp (double)

inline void seupp (
  bool rvec, char HowMny, float d[], float Z[],
  int ldz, float sigma, char bmat, int n,
  char* which, int nev, float tol, float resid[],
  int ncv, float V[], int ldv, int iparam[],
  int ipntr[], float workd[], float workl[],
  int lworkl, int& info) {

  int irvec;
  logical *iselect;
  float *iZ;

  irvec = (int)rvec;
  iselect = new logical[ncv];
  iZ = (Z == NULL) ? &V[0] : Z;

  F77NAME(sseupd)(
    &irvec, &HowMny, iselect, d, iZ, &ldz, &sigma, &bmat,
    &n, which, &nev, &tol, resid, &ncv, &V[0], &ldv, &iparam[1],
    &ipntr[1], &workd[1], &workl[1], &lworkl, &info HIDDEN_112);

  delete[] iselect;
} // seupp (float)

inline void naupp (
  int& ido, char bmat, int n, char* which, int nev,
  double& tol, double resid[], int ncv, double V[],
  int ldv, int iparam[], int ipntr[], double workd[],
  double workl[], int lworkl, int& info) {

  F77NAME(dnaupd)(
    &ido, &bmat, &n, which, &nev, &tol, resid, &ncv,
    &V[0], &ldv, &iparam[1], &ipntr[1], &workd[1], &workl[1],
    &lworkl, &info HIDDEN_12);
} // naupp (double).

inline void naupp (
  int& ido, char bmat, int n, char* which, int nev,
  float& tol, float resid[], int ncv, float V[],
  int ldv, int iparam[], int ipntr[], float workd[],
  float workl[], int lworkl, int& info) {

  F77NAME(snaupd)(
    &ido, &bmat, &n, which, &nev, &tol, resid, &ncv,
    &V[0], &ldv, &iparam[1], &ipntr[1], &workd[1], &workl[1],
    &lworkl, &info HIDDEN_12);

} // naupp (float)

inline void caupp (
  int& ido, char bmat, int n, char* which, int nev,
  double& tol, complex<double> resid[], int ncv,
  complex<double> V[], int ldv, int iparam[], int ipntr[],
  complex<double> workd[], complex<double> workl[],
  int lworkl, double rwork[], int& info) {

  F77NAME(znaupd)(
    &ido, &bmat, &n, which, &nev, &tol, resid, &ncv,
    &V[0], &ldv, &iparam[1], &ipntr[1], &workd[1],
    &workl[1], &lworkl, &rwork[1], &info HIDDEN_12);
} // caupp

inline void caupp (
  int& ido, char bmat, int n, char* which, int nev,
  float& tol, complex<float> resid[], int ncv,
  complex<float> V[], int ldv, int iparam[], int ipntr[],
  complex<float> workd[], complex<float> workl[],
  int lworkl, float rwork[], int& info) {

  F77NAME(cnaupd)(
    &ido, &bmat, &n, which, &nev, &tol, resid, &ncv,
    &V[0], &ldv, &iparam[1], &ipntr[1], &workd[1],
    &workl[1], &lworkl, &rwork[1], &info HIDDEN_12);
} // caupp

inline void ceupp (
  bool rvec, char HowMny, complex<double> d[],
  complex<double> Z[], int ldz, complex<double> sigma,
  complex<double> workev[], char bmat, int n, char* which,
  int nev, double tol, complex<double> resid[], int ncv,
  complex<double> V[], int ldv, int iparam[], int ipntr[],
  complex<double> workd[], complex<double> workl[],
  int lworkl, double rwork[], int& info) {

  int irvec;
  logical * iselect;
  complex<double> *iZ;

  irvec = (int)rvec;
  iselect = new logical[ncv];
  iZ = (Z == NULL) ? &V[0] : Z;

  F77NAME(zneupd)(
    &irvec, &HowMny, iselect, d, iZ, &ldz, &sigma,
    &workev[0], &bmat, &n, which, &nev, &tol, resid,
    &ncv, &V[0], &ldv, &iparam[1], &ipntr[1],
    &workd[1], &workl[1], &lworkl, &rwork[1], &info HIDDEN_112);

  delete[] iselect;
} // ceupp (complex<double>)

inline void ceupp (
  bool rvec, char HowMny, complex<float> d[],
  complex<float> Z[], int ldz, complex<float> sigma,
  complex<float> workev[], char bmat, int n, char* which,
  int nev, float tol, complex<float> resid[], int ncv,
  complex<float> V[], int ldv, int iparam[], int ipntr[],
  complex<float> workd[], complex<float> workl[],
  int lworkl, float rwork[], int& info) {

  int irvec;
  logical * iselect;
  complex<float> *iZ;

  irvec = (int)rvec;
  iselect = new logical[ncv];
  iZ = (Z == NULL) ? &V[0] : Z;

  F77NAME(cneupd)(
    &irvec, &HowMny, iselect, d, iZ, &ldz, &sigma,
    &workev[0], &bmat, &n, which, &nev, &tol, resid,
    &ncv, &V[0], &ldv, &iparam[1], &ipntr[1],
    &workd[1], &workl[1], &lworkl, &rwork[1], &info HIDDEN_112);

  delete[] iselect;
} // ceupp (complex<float>)

inline void neupp (
  bool rvec, char HowMny, double dr[],
  double di[], double Z[], int ldz, double sigmar,
  double sigmai, double workv[], char bmat, int n,
  char* which, int nev, double tol, double resid[],
  int ncv, double V[], int ldv, int iparam[],
  int ipntr[], double workd[], double workl[],
  int lworkl, int& info) {

  int irvec;
  logical *iselect;
  double *iZ;

  irvec = (int)rvec;
  iselect = new logical[ncv];
  iZ = (Z == NULL) ? &V[0] : Z;

  F77NAME(dneupd)(
    &irvec, &HowMny, iselect, dr, di, iZ, &ldz, &sigmar,
    &sigmai, &workv[1], &bmat, &n, which, &nev, &tol,
    resid, &ncv, &V[0], &ldv, &iparam[1], &ipntr[1],
    &workd[1], &workl[1], &lworkl, &info HIDDEN_112);

  delete[] iselect;
} // neupp (double)

inline void neupp (
  bool rvec, char HowMny, float dr[],
  float di[], float Z[], int ldz, float sigmar,
  float sigmai, float workv[], char bmat, int n,
  char* which, int nev, float tol, float resid[],
  int ncv, float V[], int ldv, int iparam[],
  int ipntr[], float workd[], float workl[],
  int lworkl, int& info) {

  int irvec;
  logical *iselect;
  float *iZ;

  irvec = (int)rvec;
  iselect = new logical[ncv];
  iZ = (Z == NULL) ? &V[0] : Z;

  F77NAME(sneupd)(
    &irvec, &HowMny, iselect, dr, di, iZ, &ldz, &sigmar,
    &sigmai, &workv[1], &bmat, &n, which, &nev, &tol,
    resid, &ncv, &V[0], &ldv, &iparam[1], &ipntr[1],
    &workd[1], &workl[1], &lworkl, &info HIDDEN_112);

  delete[] iselect;
} // neupp (float)

inline void sauppError (int info) {
  if (info < 0)
    cerr << " Arpack error sauppError" << info << endl;
  switch (info) {
    case 0:
      return;
    case -8:
      throw ErrorExec("lapack error [sd]aupp ", info);
    case -9:
      throw ErrorExec("arpack error START_RESID_ZERO [sd]aupp ", info);
    case -9999:
      throw ErrorExec("arpack error ARNOLDI_NOT_BUILD [sd]aupp ", info);
    case 1:
      throw ErrorExec("arpack error MAX_ITERATIONS [sd]aupp ", info);
    case 3:
      throw ErrorExec("arpack error NO_SHIFTS_APPLIED [sd]aupp ", info);
    default:
      throw ErrorExec("arpack error AUPP_ERROR [sd]aupp ", info);
  }
}

inline void seuppError (int info) {
  if (info < 0)
    cerr << " Arpack error seuppError" << info << endl;
  switch (info) {
    case 0:
      return;
    case -8:
    case -9:
      throw ErrorExec("lapack LAPACK_ERROR [sd]eupp ",info);
    case -14:
      throw ErrorExec("lapack NOT_ACCURATE_EIG [sd]eupp ",info);
    case 1:
      throw ErrorExec("lapack REORDERING_ERROR [sd]eupp ",info);
    default:
      throw ErrorExec("lapack error [sd]eupp ",info);
  }
} // EuppError

#endif // ARPACKFF_HPP
