/* -*- mode: C; mode: fold; -*- */
/*
  Copyright (c) 2007 Massachusetts Institute of Technology

  This software was developed by the MIT Center for Space Research
  under contract SV1-61010 from the Smithsonian Institution.
  
  Permission to use, copy, modify, distribute, and sell this software
  and its documentation for any purpose is hereby granted without fee,
  provided that the above copyright notice appear in all copies and
  that both that copyright notice and this permission notice appear in
  the supporting documentation, and that the name of the Massachusetts
  Institute of Technology not be used in advertising or publicity
  pertaining to distribution of the software without specific, written
  prior permission.  The Massachusetts Institute of Technology makes
  no representations about the suitability of this software for any
  purpose.  It is provided "as is" without express or implied warranty.
  
  THE MASSACHUSETTS INSTITUTE OF TECHNOLOGY DISCLAIMS ALL WARRANTIES
  WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  MERCHANTABILITY AND FITNESS.  IN NO EVENT SHALL THE MASSACHUSETTS
  INSTITUTE OF TECHNOLOGY BE LIABLE FOR ANY SPECIAL, INDIRECT OR
  CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
  OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
  NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION
  WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*/

/* Author: John E. Davis (davis@space.mit.edu) */

#include <stdio.h>
#include <string.h>
#include <slang.h>

#include <gsl/gsl_blas.h>
#include <gsl/gsl_linalg.h>
#include <gsl/gsl_permutation.h>
#include <gsl/gsl_eigen.h>

#include "config.h"
#include "slgsl.h"
#include "version.h"

#ifdef __cplusplus
extern "C" 
{
#endif
/* SLANG_MODULE(gslmatrix); */
#ifdef __cplusplus
}
#endif

typedef struct Matrix_Type
{
   unsigned int size1, size2;
   union
     {
	gsl_matrix d;
	gsl_matrix_complex c;
     }
   m;
   void (*free_method)(struct Matrix_Type *);
   int (*push_method)(struct Matrix_Type *);
   SLang_Array_Type *at;
}
Matrix_Type;

typedef struct Vector_Type
{
   unsigned int size;
   union
     {
	gsl_vector d;
	gsl_vector_complex c;
     }
   v;
   void (*free_method)(struct Vector_Type *);
   int (*push_method)(struct Vector_Type *);
   SLang_Array_Type *at;
}
Vector_Type;

static int check_for_complex_args (int nargs, SLtype *tp)
{
   unsigned int i, n;

   *tp = SLANG_DOUBLE_TYPE;
   if (nargs <= 0)
     return 0;
   
   n = (unsigned int) nargs;
   for (i = 0; i < n; i++)
     {
	int type = SLang_peek_at_stack1_n (i);
	if (type == -1)
	  return -1;
	if (type == SLANG_COMPLEX_TYPE)
	  {
	     *tp = SLANG_COMPLEX_TYPE;
	     return 0;
	  }
     }
   return 0;
}

static int pop_array (SLang_Array_Type **atp, SLtype type, unsigned int ndims)
{
   SLang_Array_Type *at;

   *atp = 0;

   if (-1 == SLang_pop_array_of_type (&at, type))
     return -1;
   
   if (at->num_dims != ndims)
     {
	SLang_verror (SL_INVALID_PARM, "Context requires a %d-d array", ndims);
	SLang_free_array (at);
	return -1;
     }
   *atp = at;
   return 0;
}

static void free_double_matrix (Matrix_Type *matrix)
{
   if (matrix->at != NULL)
     SLang_free_array (matrix->at);
   else if (matrix->m.d.data != NULL)
     SLfree ((char *) matrix->m.d.data);
}

static int push_double_matrix (Matrix_Type *matrix)
{
   SLang_Array_Type *at;
   SLtype type;
   gsl_matrix *m;
   SLindex_Type dims[2];
   double *data;

   if (NULL != (at = matrix->at))
     return SLang_push_array (at, 0);

   m = &matrix->m.d;
   type = SLANG_DOUBLE_TYPE;
   data = m->data;

   dims[0] = m->size1;
   dims[1] = m->size2;
   at = SLang_create_array (type, 0, data, dims, 2);
   if (at == NULL)
     return -1;

   /* stealing the data array */
   m->data = NULL;

   return SLang_push_array (at, 1);
}

static int init_double_matrix (Matrix_Type *matrix, 
			       unsigned int n0, unsigned int n1,
			       int copy, SLang_Array_Type *at)
{
   gsl_matrix *m;

   m = &matrix->m.d;

   matrix->size1 = m->size1 = n0;
   matrix->size2 = m->size2 = n1;
   m->tda = n1;
   m->owner = 0;

   if ((at != NULL) && (copy == 0))
     {
	m->data = (double *) at->data;
	matrix->at = at;
     }
   else
     {
	unsigned int nbytes = n0*n1*sizeof(double);
	if (NULL == (m->data = (double *)SLmalloc (nbytes)))
	  return -1;
	if (at != NULL)
	  memcpy ((char *)m->data, (char *)at->data, nbytes);
	matrix->at = NULL;
     }

   matrix->free_method = free_double_matrix;
   matrix->push_method = push_double_matrix;
   return 0;
}

static void free_complex_matrix (Matrix_Type *matrix)
{
   if (matrix->at != NULL)
     SLang_free_array (matrix->at);
   else if (matrix->m.c.data != NULL)
     SLfree ((char *) matrix->m.c.data);
}

static int push_complex_matrix (Matrix_Type *matrix)
{
   SLang_Array_Type *at;
   SLtype type;
   gsl_matrix_complex *c;
   SLindex_Type dims[2];
   double *data;

   if (NULL != (at = matrix->at))
     return SLang_push_array (at, 0);

   c = &matrix->m.c;
   type = SLANG_COMPLEX_TYPE;
   data = c->data;

   dims[0] = c->size1;
   dims[1] = c->size2;
   at = SLang_create_array (type, 0, data, dims, 2);
   if (at == NULL)
     return -1;

   /* stealing the data array */
   c->data = NULL;

   return SLang_push_array (at, 1);
}

static int init_complex_matrix (Matrix_Type *matrix, 
				unsigned int n0, unsigned int n1,
				int copy, SLang_Array_Type *at)
{
   gsl_matrix_complex *c;

   c = &matrix->m.c;

   matrix->size1 = c->size1 = n0;
   matrix->size2 = c->size2 = n1;
   c->tda = n1;
   c->owner = 0;

   if ((at != NULL) && (copy == 0))
     {
	c->data = (double *) at->data;
	matrix->at = at;
     }
   else
     {
	unsigned int nbytes = 2*n0*n1*sizeof(double);
	if (NULL == (c->data = (double *)SLmalloc (nbytes)))
	  return -1;
	if (at != NULL)
	  memcpy ((char *)c->data, (char *)at->data, nbytes);
	matrix->at = NULL;
     }

   matrix->free_method = free_complex_matrix;
   matrix->push_method = push_complex_matrix;
   return 0;
}

static void free_matrix (Matrix_Type *matrix)
{
   if (matrix == NULL)
     return;
   
   (*matrix->free_method)(matrix);
   SLfree ((char *)matrix);
}

static Matrix_Type *new_matrix (SLtype type, unsigned int n0, unsigned int n1,
				int copy, SLang_Array_Type *at)
{
   Matrix_Type *matrix;
   int status;

   if (NULL == (matrix = (Matrix_Type *)SLcalloc (1, sizeof (Matrix_Type))))
     return NULL;

   if (type == SLANG_COMPLEX_TYPE)
     status = init_complex_matrix (matrix, n0, n1, copy, at);
   else 
     status = init_double_matrix (matrix, n0, n1, copy, at);
   
   if (status == -1)
     {
	SLfree ((char *) matrix);
	return NULL;
     }
   return matrix;
}

static int push_matrix (Matrix_Type *matrix)
{
   return (*matrix->push_method)(matrix);
}

static int pop_matrix (Matrix_Type **matrixp, SLtype type, int copy)
{
   SLang_Array_Type *at;
   Matrix_Type *matrix;

   *matrixp = NULL;
   if (-1 == pop_array (&at, type, 2))
     return -1;

   if (NULL == (matrix = new_matrix (type, at->dims[0], at->dims[1], copy, at)))
     {
	SLang_free_array (at);
	return -1;
     }

   if (copy)
     SLang_free_array (at);

   *matrixp = matrix;
   return 0;
}

static int pop_square_matrix (Matrix_Type **matrixp, SLtype type, int copy)
{
   Matrix_Type *matrix;

   if (-1 == pop_matrix (&matrix, type, copy))
     {
	*matrixp = NULL;
	return -1;
     }

   if (matrix->size1 != matrix->size2)
     {
	SLang_verror (SL_INVALID_PARM, "Expecting a square matrix");
	free_matrix (matrix);
	return -1;
     }

   *matrixp = matrix;
   return 0;
}


/* Functions to create/destroy vectors */
static void free_double_vector (Vector_Type *vector)
{
   if (vector->at != NULL)
     SLang_free_array (vector->at);
   else if (vector->v.d.data != NULL)
     SLfree ((char *) vector->v.d.data);
}

static int push_double_vector (Vector_Type *vector)
{
   SLang_Array_Type *at;
   SLtype type;
   gsl_vector *v;
   SLindex_Type dims[1];
   double *data;

   if (NULL != (at = vector->at))
     return SLang_push_array (at, 0);

   v = &vector->v.d;
   type = SLANG_DOUBLE_TYPE;
   data = v->data;

   dims[0] = v->size;
   at = SLang_create_array (type, 0, data, dims, 1);
   if (at == NULL)
     return -1;

   /* stealing the data array */
   v->data = NULL;

   return SLang_push_array (at, 1);
}

static int init_double_vector (Vector_Type *vector, unsigned int n,
			       int copy, SLang_Array_Type *at)
{
   gsl_vector *v;

   v = &vector->v.d;

   vector->size = v->size = n;
   v->stride = 1;
   v->owner = 0;

   if ((at != NULL) && (copy == 0))
     {
	v->data = (double *) at->data;
	vector->at = at;
     }
   else
     {
	unsigned int nbytes = n*sizeof(double);
	if (NULL == (v->data = (double *)SLmalloc (nbytes)))
	  return -1;
	if (at != NULL)
	  memcpy ((char *)v->data, (char *)at->data, nbytes);
	vector->at = NULL;
     }

   vector->free_method = free_double_vector;
   vector->push_method = push_double_vector;
   return 0;
}


static void free_complex_vector (Vector_Type *vector)
{
   if (vector->at != NULL)
     SLang_free_array (vector->at);
   else if (vector->v.c.data != NULL)
     SLfree ((char *) vector->v.c.data);
}

static int push_complex_vector (Vector_Type *vector)
{
   SLang_Array_Type *at;
   SLtype type;
   gsl_vector_complex *v;
   SLindex_Type dims[1];
   double *data;

   if (NULL != (at = vector->at))
     return SLang_push_array (at, 0);

   v = &vector->v.c;
   type = SLANG_COMPLEX_TYPE;
   data = v->data;

   dims[0] = v->size;
   at = SLang_create_array (type, 0, data, dims, 1);
   if (at == NULL)
     return -1;

   /* stealing the data array */
   v->data = NULL;

   return SLang_push_array (at, 1);
}

static int init_complex_vector (Vector_Type *vector, unsigned int n,
				int copy, SLang_Array_Type *at)
{
   gsl_vector_complex *v;

   v = &vector->v.c;

   vector->size = v->size = n;
   v->stride = 1;
   v->owner = 0;

   if ((at != NULL) && (copy == 0))
     {
	v->data = (double *) at->data;
	vector->at = at;
     }
   else
     {
	unsigned int nbytes = 2*n*sizeof(double);
	if (NULL == (v->data = (double *)SLmalloc (nbytes)))
	  return -1;
	if (at != NULL)
	  memcpy ((char *)v->data, (char *)at->data, nbytes);
	vector->at = NULL;
     }

   vector->free_method = free_complex_vector;
   vector->push_method = push_complex_vector;
   return 0;
}

static void free_vector (Vector_Type *vector)
{
   if (vector == NULL)
     return;
   (*vector->free_method)(vector);
   SLfree ((char *)vector);
}

static Vector_Type *new_vector (SLtype type, unsigned int n,
				int copy, SLang_Array_Type *at)
{
   Vector_Type *vector;
   int status;

   if (NULL == (vector = (Vector_Type *)SLcalloc (1, sizeof (Vector_Type))))
     return NULL;

   if (type == SLANG_COMPLEX_TYPE)
     status = init_complex_vector (vector, n, copy, at);
   else
     status = init_double_vector (vector, n, copy, at);
   
   if (status == -1)
     {
	SLfree ((char *) vector);
	return NULL;
     }

   return vector;
}

static int push_vector (Vector_Type *vector)
{
   return (*vector->push_method)(vector);
}

static int assign_vector_to_ref (Vector_Type *vector, SLang_Ref_Type *ref)
{
   SLang_Array_Type *at;
   int status;

   if (-1 == push_vector (vector))
     return -1;
   
   if (-1 == SLang_pop_array (&at, 0))
     return -1;
   
   status = SLang_assign_to_ref (ref, SLANG_ARRAY_TYPE, (VOID_STAR)&at);
   SLang_free_array (at);
   return status;
}

static int pop_vector (Vector_Type **vectorp, SLtype type, int copy)
{
   SLang_Array_Type *at;
   Vector_Type *vector;

   *vectorp = NULL;
   if (-1 == pop_array (&at, type, 1))
     return -1;

   if (NULL == (vector = new_vector (type, at->dims[0], copy, at)))
     {
	SLang_free_array (at);
	return -1;
     }
   
   if (copy)
     SLang_free_array (at);

   *vectorp = vector;
   return 0;
}

static int pop_permutation (gsl_permutation **pp)
{
   gsl_permutation *p;
   SLang_Array_Type *at;
   unsigned int i, n;
   unsigned int *data;
   size_t *pdata;

   *pp = NULL;

   if (-1 == SLang_pop_array_of_type (&at, SLANG_UINT_TYPE))
     return -1;
   
   data = (unsigned int *) at->data;
   n = at->num_elements;

   if (n == 0)
     {
	SLang_verror (SL_INVALID_PARM, "Empty permutation array");
	SLang_free_array (at);
	return -1;
     }
   
   if (NULL == (p = gsl_permutation_alloc (n)))
     {
	SLang_free_array (at);
	return -1;
     }
   pdata = p->data;

   for (i = 0; i < n; i++)
     {
	if (data[i] >= n)
	  {
	     SLang_verror (SL_INVALID_PARM, "Invalid permutation array");
	     SLang_free_array (at);
	     gsl_permutation_free (p);
	     return -1;
	  }
	pdata[i] = data[i];
     }
   SLang_free_array (at);
   *pp = p;
   return 0;
}

static int push_permutation (gsl_permutation *p)
{
   SLang_Array_Type *at;
   unsigned int *data;
   size_t *pdata;
   SLindex_Type i, n;

   n = p->size;

   if (NULL == (at = SLang_create_array (SLANG_UINT_TYPE, 0, NULL, &n, 1)))
     return -1;

   pdata = p->data;
   data = (unsigned int *) at->data;

   for (i = 0; i < n; i++)
     data[i] = pdata[i];
   
   return SLang_push_array (at, 1);
}

static void linalg_LU_decomp (void)
{
   SLang_Ref_Type *signum_ref = NULL;
   Matrix_Type *matrix;
   gsl_permutation *p;
   int signum;
   SLtype type;
   int nargs = SLang_Num_Function_Args;

   if (-1 == check_for_complex_args (nargs, &type))
     return;

   switch (nargs)
     {
      case 2:
	if (-1 == SLang_pop_ref (&signum_ref))
	  return;
	/* drop */
      case 1:
	if (-1 == pop_square_matrix (&matrix, type, 1))
	  {
	     if (signum_ref != NULL)
	       SLang_free_ref (signum_ref);
	     return;
	  }
	break;

      default:
	SLang_verror (SL_USAGE_ERROR, "Usage: (LU, p) = linalg_LU_decomp(A [,&signum])");
	return;
     }

   if (NULL == (p = gsl_permutation_alloc (matrix->size1)))
     {
	free_matrix (matrix);
	if (signum_ref != NULL)
	  SLang_free_ref (signum_ref);
	return;
     }

   slgsl_reset_errors ();
   if (type == SLANG_COMPLEX_TYPE)
     gsl_linalg_complex_LU_decomp (&matrix->m.c, p, &signum);
   else
     gsl_linalg_LU_decomp (&matrix->m.d, p, &signum);

   slgsl_check_errors ("linalg_LU_decomp");

   if ((0 == push_matrix (matrix))
       && (0 == push_permutation (p))
       && (signum_ref != NULL))
     (void) SLang_assign_to_ref (signum_ref, SLANG_INT_TYPE, (VOID_STAR)&signum);
   
   if (signum_ref != NULL)
     SLang_free_ref (signum_ref);

   gsl_permutation_free (p);
   free_matrix (matrix);
}

static void linalg_LU_solve (void)
{
   Matrix_Type *lu = NULL;
   Vector_Type *b = NULL;
   Vector_Type *x = NULL;
   gsl_permutation *p = NULL;
   SLtype type;
   int nargs = SLang_Num_Function_Args;

   if (-1 == check_for_complex_args (nargs, &type))
     return;

   switch (nargs)
     {
      case 3:
	if ((-1 == pop_vector (&b, type, 0))
	    || (-1 == pop_permutation (&p))
	    || (-1 == pop_square_matrix (&lu, type, 0)))
	  goto return_error;

	if ((lu->size2 != b->size)
	    || (p->size != b->size))
	  {
	     SLang_verror (SL_INVALID_PARM, "matrices have incompatible dimensions");
	     goto return_error;
	  }
	break;

      default:
	SLang_verror (SL_USAGE_ERROR, "Usage: x = linalg_LU_solve(LU, p, b);");
	return;
     }
   
   if (NULL == (x = new_vector (type, b->size, 0, NULL)))
     goto return_error;

   slgsl_reset_errors ();
   if (type == SLANG_COMPLEX_TYPE)
     gsl_linalg_complex_LU_solve (&lu->m.c, p, &b->v.c, &x->v.c);
   else
     gsl_linalg_LU_solve (&lu->m.d, p, &b->v.d, &x->v.d);
   slgsl_check_errors ("linalg_LU_solve");
   
   if (0 == SLang_get_error ())
     (void) push_vector (x);
   
   /* drop */

   return_error:

   free_vector (x);
   free_matrix (lu);
   gsl_permutation_free (p);
   free_vector (b);
}

static void do_linalg_LU_det (int nargs, int do_log)
{
   Matrix_Type *matrix;
   SLtype type;
   int signum;
   char *func;
   
   if (do_log)
     {
	func = "linalg_LU_lndet"; 
	if (nargs != 1)
	  {
	     SLang_verror (SL_USAGE_ERROR, "Usage: det = linalg_LU_lndet (LU)");
	     return;
	  }
	signum = 0;
     }
   else
     {
	func = "linalg_LU_det";
	if (nargs != 2)
	  {
	     SLang_verror (SL_USAGE_ERROR, "Usage: det = linalg_LU_det (LU, signum)");
	     return;
	  }
	if (-1 == SLang_pop_int (&signum))
	  return;
     }

   if (-1 == check_for_complex_args (1, &type))
     return;

   if (-1 == pop_square_matrix (&matrix, type, 0))
     return;
   
   slgsl_reset_errors ();
   if (type == SLANG_COMPLEX_TYPE)
     {
	if (do_log)
	  {
	     double d = gsl_linalg_complex_LU_lndet (&matrix->m.c);
	     (void) SLang_push_double (d);
	  }
	else
	  {
	     gsl_complex c = gsl_linalg_complex_LU_det (&matrix->m.c, signum);
	     (void) SLang_push_complex (c.dat[0], c.dat[1]);
	  }
     }
   else
     {
	double d;
	if (do_log)
	  d = gsl_linalg_LU_lndet (&matrix->m.d);
	else
	  d = gsl_linalg_LU_det (&matrix->m.d, signum);
	(void) SLang_push_double (d);
     }
   slgsl_check_errors (func);

   free_matrix (matrix);
}

static void linalg_LU_det (void)
{
   do_linalg_LU_det (SLang_Num_Function_Args, 0);
}

static void linalg_LU_lndet (void)
{
   do_linalg_LU_det (SLang_Num_Function_Args, 1);
}

static void linalg_LU_invert (void)
{
   Matrix_Type *lu = NULL;
   Matrix_Type *inv = NULL;
   gsl_permutation *p = NULL;
   SLtype type;
   int nargs = SLang_Num_Function_Args;
   
   if (-1 == check_for_complex_args (nargs, &type))
     return;

   if (nargs != 2)
     {
	SLang_verror (SL_USAGE_ERROR, "Usage: inv = linalg_LU_invert(LU, p);");
	return;
     }
   if ((-1 == pop_permutation (&p))
       || (-1 == pop_square_matrix (&lu, type, 1)))
     goto return_error;

   if (NULL == (inv = new_matrix (type, lu->size1, lu->size2, 0, NULL)))
     goto return_error;

   slgsl_reset_errors ();
   if (type == SLANG_COMPLEX_TYPE)
     gsl_linalg_complex_LU_invert (&lu->m.c, p, &inv->m.c);
   else
     gsl_linalg_LU_invert (&lu->m.d, p, &inv->m.d);

   slgsl_check_errors ("linalg_LU_solve");
   
   if (0 == SLang_get_error ())
     (void) push_matrix (inv);

   /* drop */

   return_error:

   free_matrix (inv);
   free_matrix (lu);
   gsl_permutation_free (p);
}

static void linalg_QR_decomp (void)
{
   Matrix_Type *matrix;
   Vector_Type *tau;
   unsigned int n;
   SLtype type = SLANG_DOUBLE_TYPE;
   int nargs = SLang_Num_Function_Args;

   if (nargs != 1)
     {
	SLang_verror (SL_USAGE_ERROR, "Usage: (QR, tau) = linalg_QR_decomp(A)");
	return;
     }

   if (-1 == pop_matrix (&matrix, type, 1))
     return;

   n = matrix->size1;
   if (matrix->size2 < n)
     n = matrix->size2;

   if (NULL == (tau = new_vector (SLANG_DOUBLE_TYPE, n, 0, NULL)))
     {
	free_matrix (matrix);
	return;
     }

   slgsl_reset_errors ();
   gsl_linalg_QR_decomp (&matrix->m.d, &tau->v.d);
   slgsl_check_errors ("linalg_LU_decomp");

   (void) push_matrix (matrix);
   (void) push_vector (tau);
   free_vector (tau);
   free_matrix (matrix);
}


static void linalg_QR_solve (void)
{
   Matrix_Type *qr = NULL;
   Vector_Type *b = NULL;
   Vector_Type *x = NULL;
   Vector_Type *tau = NULL;
   Vector_Type *residual = NULL;
   SLang_Ref_Type *ref = NULL;
   SLtype type;
   int nargs = SLang_Num_Function_Args;

   type = SLANG_DOUBLE_TYPE;

   switch (nargs)
     {
      case 4:
	if (-1 == SLang_pop_ref (&ref))
	  return;
	/* drop */
      case 3:
	if ((-1 == pop_vector (&b, type, 0))
	    || (-1 == pop_vector (&tau, type, 0))
	    || (-1 == pop_matrix (&qr, type, 0)))
	  goto return_error;
	break;

      default:
	SLang_verror (SL_USAGE_ERROR, "Usage: x = linalg_QR_solve(QR, tau, b [,&residual]);");
	return;
     }

   if (qr->size2 != b->size)
     {
	SLang_verror (SL_INVALID_PARM, "matrices have incompatible dimensions");
	goto return_error;
     }
   
   if (NULL == (x = new_vector (type, b->size, 0, NULL)))
     goto return_error;

   if ((ref != NULL)
       || (qr->size1 != qr->size2))
     {
	if (NULL == (residual = new_vector (type, b->size, 0, NULL)))
	  goto return_error;
     }

   slgsl_reset_errors ();
   if (residual == NULL)
     gsl_linalg_QR_solve (&qr->m.d, &tau->v.d, &b->v.d, &x->v.d);
   else
     gsl_linalg_QR_lssolve (&qr->m.d, &tau->v.d, &b->v.d, &x->v.d, &residual->v.d);
   slgsl_check_errors ("linalg_LU_solve");
   
   if (0 == SLang_get_error ())
     {
	(void) push_vector (x);
	if (ref != NULL)
	  (void) assign_vector_to_ref (residual, ref);
     }
   
   /* drop */
   return_error:

   free_vector (x);
   free_matrix (qr);
   free_vector (tau);
   free_vector (b);
   if (ref != NULL)
     SLang_free_ref (ref);
   if (residual != NULL)
     free_vector (residual);
}

static void linalg_SV_decomp (void)
{
   Matrix_Type *a = NULL, *v = NULL;
   Vector_Type *s = NULL;
   gsl_vector *work = NULL;
   size_t N,M;
   SLtype type;
   int nargs = SLang_Num_Function_Args;

   if (nargs != 1)
     {
	SLang_verror (SL_USAGE_ERROR, "Usage: (U,S,V) = linalg_SV_decomp(A); %% ==> A=U#S#transpose(V)");
	return;
     }
   if (-1 == check_for_complex_args (nargs, &type))
     return;

   if (type == SLANG_COMPLEX_TYPE)
     {
	SLang_verror (SL_NOT_IMPLEMENTED, "GSL does not support the SVD of complex arrays");
	return;
     }

   if (-1 == pop_matrix (&a, type, 1))
     return;

   M = a->size1;
   N = a->size2;

   if (M < N)
     {
	SLang_verror (SL_INVALID_PARM, "Expecting a matrix with nrows>=ncols");
	free_matrix (a);
     }

   if ((NULL == (s = new_vector (type, N, 0, NULL)))
       || (NULL == (v = new_matrix (type, N, N, 0, NULL)))
       || (NULL == (work = gsl_vector_alloc (N))))
     goto return_error;

   slgsl_reset_errors ();
   (void) gsl_linalg_SV_decomp (&a->m.d, &v->m.d, &s->v.d, work);
   slgsl_check_errors ("linalg_SV_decomp");
   
   if (0 == SLang_get_error ())
     {
	(void) push_matrix (a);
	(void) push_vector (s);
	(void) push_matrix (v);
     }

   /* drop */
   return_error:
   if (work != NULL)
     gsl_vector_free (work);
   free_matrix (v);
   free_vector (s);
   free_matrix (a);
}

static void linalg_SV_solve (void)
{
   Matrix_Type *u = NULL, *v = NULL;
   Vector_Type *b = NULL, *x = NULL, *s = NULL;
   size_t M, N;
   SLtype type;
   int nargs = SLang_Num_Function_Args;

   if (nargs != 4)
     {
	SLang_verror (SL_USAGE_ERROR, "Usage: x = linalg_SV_solve (U,V,S,b);");
	return;
     }

   if (-1 == check_for_complex_args (nargs, &type))
     return;

   if (type == SLANG_COMPLEX_TYPE)
     {
	SLang_verror (SL_NOT_IMPLEMENTED, "GSL does not support the SVD of complex arrays");
	return;
     }

   if ((-1 == pop_vector (&b, type, 0))      /* N */
       || (-1 == pop_vector (&s, type, 0))      /* N */
       || (-1 == pop_square_matrix (&v, type, 0))   /* N */
       || (-1 == pop_matrix (&u, type, 0)))   /* MxN */
     goto return_error;

   N = b->size;
   if ((s->size != N)
       || (v->size1 != N)
       || (u->size2 != N))
     {
	SLang_verror (SL_INVALID_PARM, "matrices have incompatible dimensions");
	goto return_error;
     }
   M = u->size1;
   if (M < N)
     {
	SLang_verror (SL_INVALID_PARM, "Context requires a matrix with nrows>=ncols");
	goto return_error;
     }
   
   if (NULL == (x = new_vector (type, N, 0, NULL)))
     goto return_error;

   slgsl_reset_errors ();
   gsl_linalg_SV_solve (&u->m.d, &v->m.d, &s->v.d, &b->v.d, &x->v.d);
   slgsl_check_errors ("linalg_SV_solve");

   if (0 == SLang_get_error ())
     (void) push_vector (x);
   
   /* drop */

   return_error:

   free_vector (x);
   free_vector (b);
   free_vector (s);
   free_matrix (v);
   free_matrix (u);
}

/* Eigenvalue Routines */
static void eigen_symmv (void)
{
   Matrix_Type *matrix;
   SLtype type = SLANG_DOUBLE_TYPE;
   Vector_Type *eigvals = NULL;
   Matrix_Type *eigvecs = NULL;
   unsigned int n;

   if (SLang_Num_Function_Args != 1)
     {
	SLang_verror (SL_USAGE_ERROR, "Usage: (eigvecs, eigvals)=eigen_symmv(A)");
	return;
     }

   if (-1 == check_for_complex_args (1, &type))
     return;

   if (-1 == pop_square_matrix (&matrix, type, 1))
     return;

   n = matrix->size1;

   if ((NULL == (eigvals = new_vector (SLANG_DOUBLE_TYPE, n, 0, NULL)))
       || (NULL == (eigvecs = new_matrix (type, n, n, 0, NULL))))
     goto return_error;

   slgsl_reset_errors ();
   if (type == SLANG_COMPLEX_TYPE)
     {
	gsl_eigen_hermv_workspace *w = gsl_eigen_hermv_alloc (n);
	if (w == NULL)
	  goto return_error;
	(void) gsl_eigen_hermv (&matrix->m.c, &eigvals->v.d, &eigvecs->m.c, w);
	gsl_eigen_hermv_free (w);
     }
   else
     {
	gsl_eigen_symmv_workspace *w = gsl_eigen_symmv_alloc (n);
	if (w == NULL)
	  goto return_error;
	(void) gsl_eigen_symmv (&matrix->m.d, &eigvals->v.d, &eigvecs->m.d, w);
	gsl_eigen_symmv_free (w);
     }   
   slgsl_check_errors ("eigen_symmv");

   if (0 == SLang_get_error ())
     {
	if (type == SLANG_COMPLEX_TYPE)
	  gsl_eigen_hermv_sort (&eigvals->v.d, &eigvecs->m.c, GSL_EIGEN_SORT_ABS_DESC);
	else
	  gsl_eigen_symmv_sort (&eigvals->v.d, &eigvecs->m.d, GSL_EIGEN_SORT_ABS_DESC);
	(void) push_matrix (eigvecs);
	(void) push_vector (eigvals);
     }
   /* drop */
   return_error:

   free_matrix (eigvecs);
   free_vector (eigvals);
   free_matrix (matrix);
}

#if GSL_VERSION_INT >= 10900
static void eigen_nonsymmv (void)
{
   Matrix_Type *matrix;
   Vector_Type *eigvals = NULL;
   Matrix_Type *eigvecs = NULL;
   gsl_eigen_nonsymmv_workspace *w = NULL;
   unsigned int n;

   if (SLang_Num_Function_Args != 1)
     {
	SLang_verror (SL_USAGE_ERROR, "Usage: (eigvecs, eigvals)=eigen_nonsymmv(A)");
	return;
     }

   if (-1 == pop_square_matrix (&matrix, SLANG_DOUBLE_TYPE, 1))
     return;

   n = matrix->size1;

   if ((NULL == (eigvals = new_vector (SLANG_COMPLEX_TYPE, n, 0, NULL)))
       || (NULL == (eigvecs = new_matrix (SLANG_COMPLEX_TYPE, n, n, 0, NULL)))
       || (NULL == (w = gsl_eigen_nonsymmv_alloc (n))))
     goto return_error;

   slgsl_reset_errors ();
   (void) gsl_eigen_nonsymmv (&matrix->m.d, &eigvals->v.c, &eigvecs->m.c, w);
   slgsl_check_errors ("eigen_nonsymmv");

   if (0 == SLang_get_error ())
     {
	gsl_eigen_nonsymmv_sort (&eigvals->v.c, &eigvecs->m.c, GSL_EIGEN_SORT_ABS_DESC);
	(void) push_matrix (eigvecs);
	(void) push_vector (eigvals);
     }
   /* drop */

   return_error:

   gsl_eigen_nonsymmv_free (w);
   free_matrix (eigvecs);
   free_vector (eigvals);
   free_matrix (matrix);
}
#endif

#define V SLANG_VOID_TYPE
static SLang_Intrin_Fun_Type Module_Intrinsics [] =
{
   MAKE_INTRINSIC_0("linalg_LU_decomp", linalg_LU_decomp, V),
   MAKE_INTRINSIC_0("linalg_LU_det", linalg_LU_det, V),
   MAKE_INTRINSIC_0("linalg_LU_lndet", linalg_LU_lndet, V),
   MAKE_INTRINSIC_0("linalg_LU_invert", linalg_LU_invert, V),
   MAKE_INTRINSIC_0("linalg_LU_solve", linalg_LU_solve, V),
   MAKE_INTRINSIC_0("linalg_QR_decomp", linalg_QR_decomp, V),
   MAKE_INTRINSIC_0("linalg_QR_solve", linalg_QR_solve, V),
   MAKE_INTRINSIC_0("linalg_SV_decomp", linalg_SV_decomp, V),
   MAKE_INTRINSIC_0("linalg_SV_solve", linalg_SV_solve, V),

   MAKE_INTRINSIC_0("eigen_symmv", eigen_symmv, V),
#if GSL_VERSION_INT >= 10900
   MAKE_INTRINSIC_0("eigen_nonsymmv", eigen_nonsymmv, V),
#endif
   SLANG_END_INTRIN_FUN_TABLE
};
#undef V

static SLang_Intrin_Var_Type Module_Variables [] =
{
   MAKE_VARIABLE("_gslmatrix_module_version_string", &Module_Version_String, SLANG_STRING_TYPE, 1),
   SLANG_END_INTRIN_VAR_TABLE
};

static SLang_IConstant_Type Module_IConstants [] =
{
   MAKE_ICONSTANT("_gslmatrix_module_version", MODULE_VERSION_NUMBER),
   SLANG_END_ICONST_TABLE
};

int init_gslmatrix_module_ns (char *ns_name)
{
   SLang_NameSpace_Type *ns = SLns_create_namespace (ns_name);
   if (ns == NULL)
     return -1;

   if (
       (-1 == SLns_add_intrin_fun_table (ns, Module_Intrinsics, NULL))
       || (-1 == SLns_add_intrin_var_table (ns, Module_Variables, NULL))
       || (-1 == SLns_add_iconstant_table (ns, Module_IConstants, NULL))
      )
     return -1;

   return 0;
}

/* This function is optional */
void deinit_gslmatrix_module (void)
{
}
