// 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

#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 !__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__
    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__
    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__
      fprintf (stderr, "error (CDC): illegal argument %d\n", -info);
#else
      fprintf (stderr, "error (CDC): illegal argument %ld\n", -info);
#endif
    }
    else {
#if __LP64__
      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__
      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__
      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__
      fprintf (stderr, "error (GENEIGSOLVE): not positive definite %d\n",
	       info);
#else
      fprintf (stderr, "error (GENEIGSOLVE): not positive definite %ld\n",
	       info);
#endif
    }
    exit (1);
  }
}
