// LAPACK-using version of eigensrc/eigx.f, easier to build on OS X
// Christopher Chang (chrchang@alumni.caltech.edu), BGI Cognitive Genomics Lab

#include <stdio.h>
#include <stdlib.h>

#ifdef __APPLE__
#include <Accelerate/Accelerate.h>
#else

#ifdef _WIN32

#define HAVE_LAPACK_CONFIG_H
#define LAPACK_COMPLEX_STRUCTURE
#include "lapack/lapacke/include/lapacke.h"
typedef int __CLPK_integer;

typedef double __CLPK_doublereal;

#else // begin !_WIN32
#if __LP64__
typedef int __CLPK_integer;
#else
typedef long int __CLPK_integer;
#endif
typedef double __CLPK_doublereal;

int
dspev_ (char* jobz, char* uplo, __CLPK_integer* n, __CLPK_doublereal* ap,
__CLPK_doublereal* w, __CLPK_doublereal* z__, __CLPK_integer* ldz,
__CLPK_doublereal* work, __CLPK_integer* info);

int
dpotrf_ (char* uplo, __CLPK_integer* n, __CLPK_doublereal* a,
__CLPK_integer* lda, __CLPK_integer* info);

int
dgetrf_ (__CLPK_integer* m, __CLPK_integer* n, __CLPK_doublereal* a,
__CLPK_integer* lda, __CLPK_integer* ipiv, __CLPK_integer* info);

int
dgetri_ (__CLPK_integer* n, __CLPK_doublereal* a, __CLPK_integer* lda,
__CLPK_integer* ipiv, __CLPK_doublereal* work,
__CLPK_integer* lwork, __CLPK_integer* info);

int
dgetrs_ (char* trans, __CLPK_integer* n, __CLPK_integer* nrhs,
__CLPK_doublereal* a, __CLPK_integer* lda, __CLPK_integer* ipiv,
__CLPK_doublereal* b, __CLPK_integer* ldb, __CLPK_integer* info);

int
dsygv_ (__CLPK_integer* itype, char* jobz, char* uplo, __CLPK_integer* n,
__CLPK_doublereal* a, __CLPK_integer* lda, __CLPK_doublereal* b,
__CLPK_integer* ldb, __CLPK_doublereal* w, __CLPK_doublereal* work,
__CLPK_integer* lwork, __CLPK_integer* info);
#endif // end !_WIN32
#endif // end !__APPLE__

void
mem_error ()
{
  fprintf (stderr, "CM\n");
  exit (1);
}

void
inverse_error (char* procname, int info)
{
  if (info < 0)
    {
      fprintf (stderr, "error (%s): illegal argument %d\n", procname, -info);
    }
  else
    {
      fprintf (stderr, "error (%s): singular matrix %d\n", procname, info);
    }
  exit (1);
}

void
eigx_ (double* pmat, double* ev, __CLPK_integer* n)
  {
    char jobz = 'N';
    char uplo = 'L';
    __CLPK_integer ldz = *n;
    __CLPK_integer info;
    double* z;
    double* work;
    z = (double*)malloc(ldz * ldz * sizeof(double));
    if (!z)
      {
        mem_error();
      }
    work = (double*)malloc(3 * ldz * sizeof(double));
    if (!work)
      {
        free(z);
        mem_error();
      }
    dspev_(&jobz, &uplo, n, pmat, ev, z, &ldz, work, &info);
    free(z);
    free(work);
    if (info)
      {
#if __LP64__ || _WIN32
        fprintf(stderr, "INFO: %d\n", info);
#else
        fprintf(stderr, "INFO: %ld\n", info);
#endif
        exit(1);
      }
  }

void
eigxv_ (double* pmat, double* eval, double* evec, __CLPK_integer* n)
  {
    char jobz = 'V';
    char uplo = 'L';
    __CLPK_integer ldz = *n;
    __CLPK_integer info;
    double* work = (double*)malloc(3 * ldz * sizeof(double));
    if (!work)
      {
        mem_error();
      }
    dspev_(&jobz, &uplo, n, pmat, eval, evec, &ldz, work, &info);
    free(work);
    if (info)
      {
#if __LP64__ || _WIN32
        fprintf(stderr, "INFO: %d\n", info);
#else
        fprintf(stderr, "INFO: %ld\n", info);
#endif
        exit(1);
      }
  }

void
cdc_ (double* pmat, __CLPK_integer* n)
  {
    char uplo = 'L';
    __CLPK_integer lda = *n;
    __CLPK_integer info;
    dpotrf_(&uplo, n, pmat, &lda, &info);
    if (info)
      {
        if (info < 0)
          {
#if __LP64__ || _WIN32
            fprintf(stderr, "error (CDC): illegal argument %d\n", -info);
#else
            fprintf(stderr, "error (CDC): illegal argument %ld\n", -info);
#endif
          }
        else
          {
#if __LP64__ || _WIN32
            fprintf(stderr, "error (CDC): minor not positive definite %d\n", info);
#else
            fprintf(stderr, "error (CDC): minor not positive definite %ld\n", info);
#endif
          }
        exit(1);
      }
  }

void
inverse_ (double* pmat, __CLPK_integer* n)
  {
    __CLPK_integer lwork = (*n) * (*n);
    __CLPK_integer info;
    __CLPK_integer* ipiv;
    double* work;
    ipiv = (__CLPK_integer*)malloc((*n) * sizeof(__CLPK_integer));
    if (!ipiv)
      {
        mem_error();
      }
    work = (double*)malloc(lwork * sizeof(double));
    if (!work)
      {
        free(ipiv);
        mem_error();
      }
    dgetrf_(n, n, pmat, n, ipiv, &info);
    if (info)
      {
        free(ipiv);
        free(work);
        inverse_error("INVERSE", info);
        exit(1);
      }
    dgetri_(n, pmat, n, ipiv, work, &lwork, &info);
    free(ipiv);
    free(work);
    if (info)
      {
        inverse_error("INVERSE", info);
      }
  }

void
solve_ (double* pmat, double* v, __CLPK_integer* n)
  {
    __CLPK_integer ldb = *n;
    char trans = 'N';
    __CLPK_integer nrhs = 1;
    double* work;
    __CLPK_integer* ipiv;
    __CLPK_integer info;
    ipiv = (__CLPK_integer*)malloc(ldb * sizeof(__CLPK_integer));
    if (!ipiv)
      {
        mem_error();
      }
    work = (double*)malloc(ldb * ldb * sizeof(double));
    if (!work)
      {
        free(ipiv);
        mem_error();
      }
    dgetrf_(n, n, pmat, n, ipiv, &info);
    if (info)
      {
        free(ipiv);
        free(work);
        inverse_error("SOLVE", info);
      }
    dgetrs_(&trans, n, &nrhs, pmat, n, ipiv, v, &ldb, &info);
    free(ipiv);
    free(work);
    if (info < 0)
      {
        inverse_error("SOLVE", info);
      }
  }

void
geneigsolve_ (double* pmat, double* qmat, double* eval, __CLPK_integer* n)
  {
    __CLPK_integer lwork = (*n) * (*n);
    double* work = (double*)malloc(lwork * sizeof(double));
    __CLPK_integer wood_elf = 1; // Sameer Merchant memorial temporary variable
              __CLPK_integer info;
              if (!work)
                {
                  mem_error();
                }
              dsygv_(&wood_elf, "V", "U", n, pmat, n, qmat, n, eval, work, &lwork, &info);
  free(work);
  if (info && (info <= 2 * (*n))) {
    if (info < 0) {
#if __LP64__ || _WIN32
      fprintf(stderr, "error (GENEIGSOLVE): illegal argument %d\n", -info);
#else
      fprintf(stderr, "error (GENEIGSOLVE): illegal argument %ld\n", -info);
#endif
    } else if (info <= (*n)) {
#if __LP64__ || _WIN32
      fprintf(stderr, "error (GENEIGSOLVE): failure to converge %d\n", info);
#else
      fprintf(stderr, "error (GENEIGSOLVE): failure to converge %ld\n", info);
#endif
    } else {
#if __LP64__ || _WIN32
      fprintf(stderr, "error (GENEIGSOLVE): not positive definite %d\n", info);
#else
      fprintf(stderr, "error (GENEIGSOLVE): not positive definite %ld\n", info);
#endif
    }
    exit(1);
  }
}
