#include <stdio.h>
#include<stdlib.h>
#include <math.h>
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_linalg.h>
#include <gsl/gsl_blas.h>

void *xcalloc(int items, int size)
{
	void *ptr = calloc(items, size);
	if (ptr == NULL)
	{
		printf("Unable to allocate memory\n");
		exit(EXIT_FAILURE);
	}
	return ptr;
}

void GetLGLPoints(int N, double *x)
{
	if (N == 0)
	{
		printf("Support for constants doesn't exist\n");
		exit(1);
	}
	else if (N == 1)
	{
		x[0] = -1.0;
		x[1] = 1.0;
	}
	else if (N==2)
	{
		x[0] = -1.0;
		x[1] = 0.0;
		x[2] = 1.0;
	}
	else if (N==3)
	{
		x[0] = -1.0;
		x[1] = -0.4472;
		x[2] = 0.4472;
		x[3] = 1.0;
	}
	else if (N==4)
	{
		x[0] = -1.0;
		x[1] = -0.6547;
		x[2] = 0;
		x[3] = 0.6547;
		x[4] = 1.0;
	}
	else
	{
		printf("Currently only have up to fourth order polynomial encoded for LGL points\n");
		exit(1);
	}
}

void GetLGLWeights(int N, double *w)
{
	if (N == 0)
	{
		printf("Support for constants doesn't exist\n");
		exit(1);
	}
	else if (N == 1)
	{
		w[0] = 1.0;
		w[1] = 1.0;
	}
	else if (N==2)
	{
		w[0] = 0.3333333333333;
		w[1] = 1.3333333333333;
		w[2] = 0.3333333333333;
	}
	else if (N==3)
	{
		w[0] = 0.16666666666667;
		w[1] = 0.83333333333333;
		w[2] = 0.83333333333333;
		w[3] = 0.16666666666667;
	}
	else if (N==4)
	{
		w[0] = 0.1;
		w[1] = 0.5444444;
		w[2] = 0.7111111;
		w[3] = 0.5444444;
		w[4] = 0.1;
	}
	else
	{
		printf("Currently only have up to fourth order polynomial encoded for LGL points\n");
		exit(1);
	}

}

void calculateNodalCoordinates(int N, int NumEl, double* X, double* Xnodes)
{
	double r[N+1];
	GetLGLPoints(N, r);
	for(int i = 0; i < NumEl; i++)
	{
		for (int j = 0; j < N+1; j++)
		{
			Xnodes[i*(N+1)+j] = X[i] + 0.5*(r[j]+1)*(X[i+1]-X[i]);
		}
	}

}

void LegendrePoly(double *x, int Np, int N, double* P)
{
	// Purpose: Evaluates the normalized Legendre polynomials
	// 					at points x for order N and returns the values in the
	// 					array P that is Np long

	double aold = 0.0, anew=0.0;

	double **PL = xcalloc(N+1, sizeof(double*));
	for (int i =0; i < N+1; i++)
	{
		PL[i] =  xcalloc(Np, sizeof(double));
	}

	// Initial values P_0(x) and P_1(x)
	if (N==0)
	{
		double constVal = 1.0/sqrt(2);
		for (int j = 0; j < Np; j++)
		{
			P[j] = constVal;
		}

		free(PL[0]);
		free(PL);
		return;
	}
	else
	{
		for (int j = 0; j < Np; j++)
		{
			PL[0][j] = 1.0/sqrt(2);
		}
	}

	double *prow = xcalloc(Np, sizeof(double));
	double coeff = sqrt(1.5);
	for (int i = 0; i < Np; i++)
	{
		prow[i] = coeff*x[i];
	}

	if(N==1)
	{
		for (int i = 0; i < Np; i++)
		{
			P[i] = prow[i];
		}
		free(prow);
		free(PL[0]);
		free(PL[1]);
		free(PL);
		return;
	}
	else
	{
		for (int j =0; j < Np; j++)
		{
			PL[1][j] = coeff*x[j];
		}

	}

	// Repeat value in recurrence
	aold = sqrt(1.0/3);

	// Forward recurrence
	for (int i = 2; i <= N; i++)
	{
		anew = sqrt(i*i/((2.0*i+1)*(2*i-1)));
		for (int j = 0; j < Np; j++)
		{
			PL[i][j] = (x[j]*PL[i-1][j]-aold*PL[i-2][j])/anew;
		}
		aold = anew;
	}

	for (int j = 0; j < Np; j++)
	{
		P[j] = PL[N][j];
	}

	for (int i =0; i < N; i++)
	{
		free(PL[i]);
	}
	free(PL);

	return;
}

void Vandermonde1D(double *x, int Np, int N, gsl_matrix** V1D)
{
	// Purpose: Evaluates the Vandermonde matrix V_{ij} = phi_i(r_j);

	*V1D = gsl_matrix_alloc(Np, N+1);
	double V1DT[Np];
	for(int i = 0; i < N+1; i++)
	{
			LegendrePoly(x, Np, i, V1DT);
			for (int j = 0; j < Np; j++)
			{
				gsl_matrix_set(*V1D, i, j, V1DT[j]);
				//gsl_matrix_set(*V1D, j, i, V1DT[j]);
			}
	}
}

void GradLegendrePoly(double *x, int Np, int N, double* DP)
{
	// Purpose: Evaluates the derivatives of normalized Legendre polynomial
	// 					at points x for order N and returns the values in the
	// 					array P that is Np long
	//

	double aold, anew;

	double **DPL = xcalloc(N+1, sizeof(double*));
	for (int i =0; i < N+1; i++)
	{
		DPL[i] =  xcalloc(Np, sizeof(double));
	}

	// Initial values P_0(x) and P_1(x)
	if (N==0)
	{
		for (int j = 0; j < Np; j++)
		{
			DP[0] = 0;
		}
		free(DPL[0]);
		free(DPL);
		return;
	}
	else
	{
		for (int j = 0; j < Np; j++)
		{
			DPL[0][j] = 0;
		}
	}

	double *dprow = xcalloc(Np, sizeof(double));
	double deriv = sqrt(1.5);
	for (int i = 0; i < Np; i++)
	{
		dprow[i] = deriv;
	}

	if(N==1)
	{
		for (int i = 0; i < Np; i++)
		{
			DP[i] = deriv;
		}
		free(dprow);
		free(DPL[0]);
		free(DPL[1]);
		free(DPL);
		return;
	}
	else
	{
		for (int j =0; j < Np; j++)
		{
			DPL[1][j] = deriv;
		}

	}

	// Repeat value in recurrence
	aold = sqrt(1.0/3);

	// Forward recurrence
	for (int i = 2; i <= N; i++)
	{
		anew = sqrt(i*i/((2.0*i+1)*(2*i-1)));
		double P[Np];
		LegendrePoly(x, Np, i-1, P);
		for (int j = 0; j < Np; j++)
		{
			DPL[i][j] = 1.0/(anew)*(P[j] + x[j]*DPL[i-1][j] - aold*DPL[i-2][j]);
		}
		aold = anew;
	}

	for (int j = 0; j < Np; j++)
	{
		DP[j] = DPL[N][j];
	}

	for (int i =0; i < N; i++)
	{
		free(DPL[i]);
	}
	free(DPL);

	return;

}

void GradVandermonde1D(double *r, int Np, int N, gsl_matrix** GV)
{
	// Purpose: Evaluates the gradient of modal basis (i) at (r)
	// 					at order N and return them in GV whose size is
	// 					ixNp
	//
	*GV = gsl_matrix_alloc(Np, N+1);
	double GVT[Np];
	for (int i =0; i < N+1; i++)
	{
		GradLegendrePoly(r, Np, i, GVT);
		for (int j = 0; j < Np; j++)
			gsl_matrix_set(*GV,i,j, GVT[j]);
			//gsl_matrix_set(*GV,j,i,GVT[j]);
	}

}

void VolIntMat1D(double *x, int N, gsl_matrix* V, gsl_matrix *Vr, gsl_matrix** VolMat)
{

	gsl_permutation *p = gsl_permutation_alloc(N+1);
	gsl_matrix *Vcopy = gsl_matrix_alloc(N+1, N+1);
	gsl_matrix_memcpy(Vcopy, V);

	gsl_matrix *Vinv = gsl_matrix_alloc(N+1, N+1);

	int s;
	gsl_linalg_LU_decomp(Vcopy, p, &s);
	gsl_linalg_LU_invert(Vcopy, p, Vinv);

	gsl_matrix *tmp1 = gsl_matrix_alloc(N+1, N+1);
	gsl_blas_dgemm(CblasNoTrans, CblasTrans, 1.0, Vinv, Vinv, 0.0, tmp1);

	gsl_matrix *tmp2 = gsl_matrix_alloc(N+1, N+1);
	gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Vr, tmp1, 0.0, tmp2);

	*VolMat = gsl_matrix_alloc(N+1, N+1);
	gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1.0, V, tmp2, 0.0, *
VolMat);
	//gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Vr, Vinv, 0.0, *Dr);

	gsl_permutation_free(p);
	gsl_matrix_free(Vcopy);
	gsl_matrix_free(Vinv);
	gsl_matrix_free(tmp1);
	gsl_matrix_free(tmp2);

}

void Lift1D(int Np, gsl_matrix *V, gsl_matrix **LIFT)
{
	*LIFT = gsl_matrix_alloc(Np,2);

	gsl_matrix *EMAT = gsl_matrix_calloc(Np, 2);
	gsl_matrix_set(EMAT, 0, 0, 1.0);
	gsl_matrix_set(EMAT, Np-1, 1, -1.0);

	gsl_matrix *tmp = gsl_matrix_alloc(Np,2);
	gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, V, EMAT, 0.0, tmp);
	gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1.0, V, tmp, 0.0, *LIFT);

	gsl_matrix_free(EMAT);
	gsl_matrix_free(tmp);

}

void calculateMassMatrix(int Np, gsl_matrix* V, gsl_matrix** MassMatrix)
{
	*MassMatrix = gsl_matrix_alloc(Np,Np);
	gsl_matrix *MassMatrixInv = gsl_matrix_alloc(Np,Np);
	gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1.0, V, V, 0.0, MassMatrixInv);

	int s = 0;
	gsl_permutation *p = gsl_permutation_alloc(Np);
	gsl_linalg_LU_decomp(MassMatrixInv, p, &s);
	gsl_linalg_LU_invert(MassMatrixInv, p, *MassMatrix);

	gsl_matrix_free(MassMatrixInv);
	gsl_permutation_free(p);

}

void calculateLIFTVolMat(int N, int Np, gsl_matrix **LIFT, gsl_matrix **VolMat,gsl_matrix **MassMatrix)
{
	double r[Np];
	GetLGLPoints(N,r);

	gsl_matrix *V;
	gsl_matrix *GV;

	Vandermonde1D(r,Np,N,&V);
	GradVandermonde1D(r, Np, N, &GV);
	VolIntMat1D(r, N, V, GV, VolMat);
	Lift1D(Np, V, LIFT);
	calculateMassMatrix(Np, V,MassMatrix);

	gsl_matrix_free(V);
	gsl_matrix_free(GV);

}


#include <stdlib.h>
#include <stdio.h>
#include <math.h>
#include <assert.h>
#include <gsl/gsl_math.h>

#include "cosmocalc.h"

double weff(double a)
{
  if(a != 1.0)
    return cosmoData.w0 + cosmoData.wa - cosmoData.wa*(a - 1.0)/log(a);
  else
    return cosmoData.w0;
}

double hubble_noscale(double a)
{
  return sqrt(cosmoData.OmegaM/a/a/a + cosmoData.OmegaK/a/a + cosmoData.OmegaL/pow(a,3.0*(1.0 + weff(a))));
}


#include <stdio.h>
#include <stdlib.h>
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_blas.h>
#include <gsl/gsl_permutation.h>
#include <gsl/gsl_linalg.h>

void test_matmul(){
    int i, j;

    gsl_matrix * m1 = gsl_matrix_alloc(10, 4);
    gsl_matrix * m2 = gsl_matrix_alloc(10, 4);
    for(i=0; i<10; i++){
        for(j=0; j<4; j++){
            gsl_matrix_set(m1, i, j, rand() % 10);
        }
    }

    for(i=0; i<10; i++){
        for(j=0; j<4; j++){
            gsl_matrix_set(m2, i, j, rand() % 10);
        }
    }

    printf("m1 before matmul:\n");
    for (i = 0; i < 10; i++){
        for (j = 0; j < 4; j++){
            printf ("%g  ", gsl_matrix_get (m1, i, j));
        }
        printf("\n");
    }

    gsl_matrix * result = gsl_matrix_alloc(4, 4);

    gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1.0, m1, m2, 0.0, result);

    printf("m1 after matmul:\n");
    for (i = 0; i < 10; i++){
        for (j = 0; j < 4; j++){
            printf ("%g  ", gsl_matrix_get (m1, i, j));
        }
        printf("\n");
    }

    printf("matmul result:\n");
    for (i = 0; i < 4; i++){
        for (j = 0; j < 4; j++){
            printf ("%g ", gsl_matrix_get (result, i, j));
        }
        printf("\n");
    }

    // gsl_matrix_fprintf(stdout, result, "%g");

    gsl_matrix_free(m1);
    gsl_matrix_free(m2);
    gsl_matrix_free(result);

}

void test_mat_inverse(){
    int i, j;
    double m1_data[] = {4, 7,
                        2, 6};
    gsl_matrix_view m1 = gsl_matrix_view_array(m1_data, 2, 2);
    int s;
    gsl_permutation * p1 = gsl_permutation_alloc(2);
    gsl_matrix * m1_inv = gsl_matrix_alloc(2, 2);
    gsl_linalg_LU_decomp(&m1.matrix, p1, &s);
    gsl_linalg_LU_invert(&m1.matrix, p1, m1_inv);
    printf("Inverse of 2x2 matrix:\n");
    for (i = 0; i < 2; i++){
        for (j = 0; j < 2; j++){
            printf ("%g ", gsl_matrix_get (m1_inv, i, j));
        }
        printf("\n");
    }

    double m2_data[] = {7, 2, 1,
                        0, 3, -1,
                        -3, 4, -2};
    gsl_matrix_view m2 = gsl_matrix_view_array(m2_data, 3, 3);
    gsl_permutation * p2 = gsl_permutation_alloc(3);
    gsl_matrix * m2_inv = gsl_matrix_alloc(3, 3);
    gsl_linalg_LU_decomp(&m2.matrix, p2, &s);
    gsl_linalg_LU_invert(&m2.matrix, p2, m2_inv);
    printf("Inverse of 3x3 matrix:\n");
    for (i = 0; i < 3; i++){
        for (j = 0; j < 3; j++){
            printf ("%g ", gsl_matrix_get (m2_inv, i, j));
        }
        printf("\n");
    }

    double m3_data[] = {6, 4, 2, 8,
                        1, 3, 5, 7,
                        2, 3, 5, 6,
                        4, 2, 6, 3};
    gsl_matrix_view m3 = gsl_matrix_view_array(m3_data, 4, 4);
    gsl_permutation * p3 = gsl_permutation_alloc(4);
    gsl_matrix * m3_inv = gsl_matrix_alloc(4, 4);
    gsl_linalg_LU_decomp(&m3.matrix, p3, &s);
    gsl_linalg_LU_invert(&m3.matrix, p3, m3_inv);
    printf("Inverse of 4x4 matrix:\n");
    for (i = 0; i < 4; i++){
        for (j = 0; j < 4; j++){
            printf ("%g ", gsl_matrix_get (m3_inv, i, j));
        }
        printf("\n");
    }

    // gsl_matrix_fprintf(stdout, m3_inv, "%g");

}

int main(){
    test_matmul();
    //test_mat_inverse();
}


/** @file */
#ifndef __CCL_UTILS_H_INCLUDED__
#define __CCL_UTILS_H_INCLUDED__

#include <gsl/gsl_spline.h>

#define CCL_MIN(a, b)  (((a) < (b)) ? (a) : (b))
#define CCL_MAX(a, b)  (((a) > (b)) ? (a) : (b))

CCL_BEGIN_DECLS

/**
 * Compute bin edges of N-1 linearly spaced bins on the interval [xmin,xmax]
 * @param xmin minimum value of spacing
 * @param xmax maximum value of spacing
 * @param N number of bins plus one (number of bin edges)
 * @return x, bin edges in range [xmin, xmax]
 */
double * ccl_linear_spacing(double xmin, double xmax, int N);

/**
 * Compute bin edges of N-1 logarithmically and then linearly spaced bins on the interval [xmin,xmax]
 * @param xminlog minimum value of spacing
 * @param xmin value when logarithmical ends and linear spacing begins
 * @param xmax maximum value of spacing
 * @param Nlin number of linear bins plus one (number of bin edges)
 * @param Nlog number of logarithmic bins plus one (number of bin edges)
 * @return x, bin edges in range [xminlog, xmax]
 */
double * ccl_linlog_spacing(double xminlog, double xmin, double xmax, int Nlin, int Nlog);

/**
 * Compute bin edges of N-1 logarithmically spaced bins on the interval [xmin,xmax]
 * @param xmin minimum value of spacing
 * @param xmax maximum value of spacing
 * @param N number of bins plus one (number of bin edges)
 * @return x, bin edges in range [xmin, xmax]
 */
double * ccl_log_spacing(double xmin, double xmax, int N);
//Returns array of N logarithmically-spaced values between xmin and xmax

double ccl_j_bessel(int l,double x);
//Spherical Bessel function of order l (adapted from CAMB)

CCL_END_DECLS

#endif


/* multimin/test_funcs.c
 *
 * Copyright (C) 1996, 1997, 1998, 1999, 2000 Fabrice Rossi
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or (at
 * your option) any later version.
 *
 * This program 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
 * General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 */

#include <config.h>
#include <gsl/gsl_multimin.h>

#include "test_funcs.h"

gsl_multimin_function_fdf rosenbrock =
{&rosenbrock_f,
 &rosenbrock_df,
 &rosenbrock_fdf,
 2, 0};

gsl_multimin_function rosenbrock_fmin =
{&rosenbrock_f,
 2, 0};

void rosenbrock_initpt (gsl_vector * x)
{
  gsl_vector_set (x, 0, -1.2);
  gsl_vector_set (x, 1, 1.0);
}

double rosenbrock_f (const gsl_vector * x, void *params)
{
  double u = gsl_vector_get(x,0);
  double v = gsl_vector_get(x,1);
  double a = u - 1;
  double b = u * u - v;
  fcount++;
  return a * a + 10 * b * b;
}

void rosenbrock_df (const gsl_vector * x, void *params, gsl_vector * df)
{
  double u = gsl_vector_get(x,0);
  double v = gsl_vector_get(x,1);
  double b = u * u - v;
  gcount++;
  gsl_vector_set(df,0,2 * (u - 1) + 40 * u * b);
  gsl_vector_set(df,1,-20 * b);
}

void rosenbrock_fdf (const gsl_vector * x, void *params, double * f,
                     gsl_vector * df)
{
  double u = gsl_vector_get(x,0);
  double v = gsl_vector_get(x,1);
  double a = u - 1;
  double b = u * u - v;
  gcount++;
  *f = a * a + 10 * b * b;
  gsl_vector_set(df,0,2 * (u - 1) + 40 * u * b);
  gsl_vector_set(df,1,-20 * b);
}

gsl_multimin_function_fdf roth =
{&roth_f,
 &roth_df,
 &roth_fdf,
 2, 0};

gsl_multimin_function roth_fmin =
{&roth_f,
 2, 0};

void roth_initpt (gsl_vector * x)
{
  gsl_vector_set (x, 0, 4.5);
  gsl_vector_set (x, 1, 3.5);
}

double roth_f (const gsl_vector * x, void *params)
{
  double u = gsl_vector_get(x,0);
  double v = gsl_vector_get(x,1);
  double a = -13.0 + u + ((5.0 - v)*v - 2.0)*v;
  double b = -29.0 + u + ((v + 1.0)*v - 14.0)*v;
  fcount++;
  return a * a + b * b;
}

void roth_df (const gsl_vector * x, void *params, gsl_vector * df)
{
  double u = gsl_vector_get(x,0);
  double v = gsl_vector_get(x,1);
  double a = -13.0 + u + ((5.0 - v)*v - 2.0)*v;
  double b = -29.0 + u + ((v + 1.0)*v - 14.0)*v;
  double c = -2 + v * (10 - 3 * v);
  double d = -14 + v * (2 + 3 * v);
  gcount++;
  gsl_vector_set(df,0,2 * a + 2 * b);
  gsl_vector_set(df,1,2 * a * c + 2 * b * d);
}

void roth_fdf (const gsl_vector * x, void *params, double * f,
               gsl_vector * df)
{
  *f = roth_f (x,params);
  roth_df(x,params,df);
}

gsl_multimin_function_fdf wood =
{&wood_f,
 &wood_df,
 &wood_fdf,
 4, 0};

gsl_multimin_function wood_fmin =
{&wood_f,
 4, 0};

void
wood_initpt (gsl_vector * x)
{
  gsl_vector_set (x, 0, -3.0);
  gsl_vector_set (x, 1, -1.0);
  gsl_vector_set (x, 2, -3.0);
  gsl_vector_set (x, 3, -1.0);
}

double wood_f (const gsl_vector * x, void *params)
{
  double u1 = gsl_vector_get(x,0);
  double u2 = gsl_vector_get(x,1);
  double u3 = gsl_vector_get(x,2);
  double u4 = gsl_vector_get(x,3);

  double t1 = u1 * u1 - u2;
  double t2 = u3 * u3 - u4;
  fcount++;
  return 100 * t1 * t1 + (1 - u1) * (1 - u1)
    + 90 * t2 * t2 + (1 - u3) * (1 - u3)
    + 10.1 * ( (1 - u2) * (1 - u2) + (1 - u4) * (1 - u4) )
    + 19.8 * (1 - u2) * (1 - u4);
}

void wood_df (const gsl_vector * x, void *params, gsl_vector * df)
{
  double u1 = gsl_vector_get(x,0);
  double u2 = gsl_vector_get(x,1);
  double u3 = gsl_vector_get(x,2);
  double u4 = gsl_vector_get(x,3);

  double t1 = u1 * u1 - u2;
  double t2 = u3 * u3 - u4;
  gcount++;
  gsl_vector_set(df,0, 400 * u1 * t1 - 2 * (1 - u1) );
  gsl_vector_set(df,1, -200 * t1 - 20.2 * (1 - u2) - 19.8 * (1 - u4) );
  gsl_vector_set(df,2, 360 * u3 * t2 - 2 * (1 - u3) );
  gsl_vector_set(df,3, -180 * t2 - 20.2 * (1 - u4) - 19.8 * (1 - u2) );

}

void wood_fdf (const gsl_vector * x, void *params, double * f, gsl_vector * df)
{
  wood_df(x,params,df);
  *f=wood_f(x,params);
}

gsl_multimin_function_fdf Nrosenbrock =
{&rosenbrock_f,
 &Nrosenbrock_df,
 &Nrosenbrock_fdf,
 2, 0};

void Nrosenbrock_df (const gsl_vector * x, void *params, gsl_vector * df)
{
  gsl_multimin_function F ;
  F.f = rosenbrock_f;
  F.params = params;
  F.n = x->size;
  gsl_multimin_diff (&F, x, df);
}

void Nrosenbrock_fdf (const gsl_vector * x, void *params, double * f,
                     gsl_vector * df)
{
  *f = rosenbrock_f (x, params);
  Nrosenbrock_df (x, params, df);
}

gsl_multimin_function_fdf Nroth =
{&roth_f,
 &Nroth_df,
 &Nroth_fdf,
 2, 0};

void Nroth_df (const gsl_vector * x, void *params, gsl_vector * df)
{
  gsl_multimin_function F ;
  F.f = roth_f;
  F.params = params;
  F.n = x->size;
  gsl_multimin_diff (&F, x, df);
}

void Nroth_fdf (const gsl_vector * x, void *params, double * f,
                     gsl_vector * df)
{
  *f = roth_f (x, params);
  Nroth_df (x, params, df);
}

gsl_multimin_function_fdf Nwood =
{&wood_f,
 &Nwood_df,
 &Nwood_fdf,
 4, 0};

void Nwood_df (const gsl_vector * x, void *params, gsl_vector * df)
{
  gsl_multimin_function F ;
  F.f = wood_f;
  F.params = params;
  F.n = x->size;
  gsl_multimin_diff (&F, x, df);
}

void Nwood_fdf (const gsl_vector * x, void *params, double * f,
                     gsl_vector * df)
{
  *f = wood_f (x, params);
  Nwood_df (x, params, df);
}


#include <stdio.h>
#include <stdlib.h>
#include <math.h>
//#include <nubspline.h>
#include <gsl/gsl_interp.h>
#include <gsl/gsl_spline.h>

extern void* xcalloc(int NumPoints, int size);

/*void eval_NUBspline_1d_d(NUBspline_1d_d * restrict spline, double x,
	double* restrict val);

void eval_NUBspline_1d_d_vg(NUBspline_1d_d * restrict spline, double x,
	double* restrict val, double* restrict grad);

void eval_NUBspline_1d_d_vgl(NUBspline_1d_d * restrict spline, double x,
	double* restrict val, double* restrict grad, double* restrict lapl);

void InterpolateWithSplines(int NumPointsToInterpolate, int NumPointsToEvaluate, double* x, double* y, double* NodalX, double* NodalY, double *func, double *NodalFunc, double* NodalDeriv)
{

	double *s = xcalloc(NumPointsToInterpolate, sizeof(double));
	double *NodalS = xcalloc(NumPointsToEvaluate, sizeof(double));
	for (int j = 0; j < NumPointsToInterpolate; j++)
	{
		s[i] = sqrt(pow(x[j]-x[0],2)+pow(y[j]-y[0],2));

	}

	for(int j = 0; j < NumPointsToEvaluate, j++)
	{
		NodalS[i] = sqrt(pow(NodalX[j] -x[0],2) + pow(NodalY[j]-y[0],2));
	}

	NUgrid* myGrid = create_general_grid(s, NumPointsToInterpolate);
	BCtype_d myBC;
	myBC.lCode = NATURAL;
	myBC.rCode = NATURAL;
	NUBspline_1d_d *mySpline = create_NUBspline_1d_d(myGrid, myBC, func);
	for(int i =0; i < NumPointsToEvaluate; i++)
	{
		if (NodalDeriv != NULL)
			eval_NUBspline_1d_d_vg(mySpline, NodalS[i], &NodalFunc[i], &NodalDeriv[i]);
		else
			eval_NUBspline_1d_d(mySpline, NodalS[i], &NodalFunc[i]);
	}

	free(s);
	free(NodalS);

}
*/

void InterpolateWithGSLSplines(int NumPointsToInterpolate, int NumPointsToEvaluate, double* x, double* y, double* NodalX, double* NodalY, double* func, double* NodalFunc, double* NodalDeriv)
{
	double *s = xcalloc(NumPointsToInterpolate, sizeof(double));
	double *NodalS = xcalloc(NumPointsToEvaluate, sizeof(double));
	for (int j = 0; j < NumPointsToInterpolate; j++)
	{
		s[j] = sqrt(pow(x[j]-x[0],2)+pow(y[j]-y[0],2));

	}

	for(int j = 0; j < NumPointsToEvaluate; j++)
	{
		NodalS[j] = sqrt(pow(NodalX[j] -x[0],2) + pow(NodalY[j]-y[0],2));
	}

	gsl_interp_accel *acc = gsl_interp_accel_alloc();
	gsl_spline* spline = gsl_spline_alloc(gsl_interp_cspline, NumPointsToInterpolate);
	gsl_spline_init(spline, s, func, NumPointsToInterpolate);

	for(int j = 0; j < NumPointsToEvaluate; j++)
	{
		NodalFunc[j] = gsl_spline_eval(spline, NodalS[j], acc);
		if (NodalDeriv != NULL)
			NodalDeriv[j] = gsl_spline_eval_deriv(spline, NodalS[j], acc);
	}

	gsl_interp_accel_free(acc);
	gsl_spline_free(spline);
	free(s);
	free(NodalS);

}


/**
 * Provides function to fit a polynomial curve to a set of data.
 * Source: https://rosettacode.org/wiki/Polynomial_regression#C
 */

#ifndef _POLIFITGSL_H
#define _POLIFITGSL_H
#include <gsl/gsl_multifit.h>
#include <stdbool.h>
#include <math.h>
bool polynomialfit(int obs, int degree,
        const double *dx, const double *dy, double *store); /* n, p */
#endif


/* randist/exppow.c
 *
 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2006 James Theiler, Brian Gough
 * Copyright (C) 2006 Giulio Bottazzi
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or (at
 * your option) any later version.
 *
 * This program 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
 * General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 */

#include <config.h>
#include <math.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_sf_gamma.h>
#include <gsl/gsl_rng.h>
#include <gsl/gsl_randist.h>

/* The exponential power probability distribution is

   p(x) dx = (1/(2 a Gamma(1+1/b))) * exp(-|x/a|^b) dx

   for -infty < x < infty. For b = 1 it reduces to the Laplace
   distribution.

   The exponential power distribution is related to the gamma
   distribution by E = a * pow(G(1/b),1/b), where E is an exponential
   power variate and G is a gamma variate.

   We use this relation for b < 1. For b >=1 we use rejection methods
   based on the laplace and gaussian distributions which should be
   faster.  For b>4 we revert to the gamma method.

   See P. R. Tadikamalla, "Random Sampling from the Exponential Power
   Distribution", Journal of the American Statistical Association,
   September 1980, Volume 75, Number 371, pages 683-686.

*/

double
gsl_ran_exppow (const gsl_rng * r, const double a, const double b)
{
  if (b < 1 || b > 4)
    {
      double u = gsl_rng_uniform (r);
      double v = gsl_ran_gamma (r, 1 / b, 1.0);
      double z = a * pow (v, 1 / b);

      if (u > 0.5)
        {
          return z;
        }
      else
        {
          return -z;
        }
    }
  else if (b == 1)
    {
      /* Laplace distribution */
      return gsl_ran_laplace (r, a);
    }
  else if (b < 2)
    {
      /* Use laplace distribution for rejection method, from Tadikamalla */

      double x, h, u;

      double B = pow (1 / b, 1 / b);

      do
        {
          x = gsl_ran_laplace (r, B);
          u = gsl_rng_uniform_pos (r);
          h = -pow (fabs (x), b) + fabs (x) / B - 1 + (1 / b);
        }
      while (log (u) > h);

      return a * x;
    }
  else if (b == 2)
    {
      /* Gaussian distribution */
      return gsl_ran_gaussian (r, a / sqrt (2.0));
    }
  else
    {
      /* Use gaussian for rejection method, from Tadikamalla */

      double x, h, u;

      double B = pow (1 / b, 1 / b);

      do
        {
          x = gsl_ran_gaussian (r, B);
          u = gsl_rng_uniform_pos (r);
          h = -pow (fabs (x), b) + (x * x) / (2 * B * B) + (1 / b) - 0.5;
        }
      while (log (u) > h);

      return a * x;
    }
}

double
gsl_ran_exppow_pdf (const double x, const double a, const double b)
{
  double p;
  double lngamma = gsl_sf_lngamma (1 + 1 / b);
  p = (1 / (2 * a)) * exp (-pow (fabs (x / a), b) - lngamma);
  return p;
}


#pragma once

#include <initializer_list>
#include <list>
#include <vector>

#include <gsl/gsl_complex.h>

#include "Expression.h"

class TupleExpression: public Expression {

    std::vector<expression> data;

    TupleExpression();
    TupleExpression(std::vector<expression>&& tuple);
    TupleExpression(std::list<expression>& tuple);
    TupleExpression(std::initializer_list<expression> tuple);
    TupleExpression(std::initializer_list<double> tuple);
    TupleExpression(std::initializer_list<gsl_complex> tuple);

    public:
        static expression construct();
        static expression construct(std::vector<expression>&& tuple);
        static expression construct(std::list<expression>& tuple);
        static expression construct(std::initializer_list<expression> tuple);
        static expression construct(std::initializer_list<double> tuple);
        static expression construct(std::initializer_list<gsl_complex> tuple);

        expression simplify() override;
        expression derivative(const std::string& var) override;
        expression integrate(const std::string& var) override;

        expression at(const int index) override;
        size_t size() const override;

        expression apply(TransformerFunction f) override;

        EXPRESSION_OVERRIDES

};


/* linalg/qr.c
 *
 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2007 Gerard Jungman, Brian Gough
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 3 of the License, or (at
 * your option) any later version.
 *
 * This program 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
 * General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 */

/* Author:  G. Jungman */

#include <config.h>
#include <stdlib.h>
#include <string.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_vector.h>
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_blas.h>

#include <gsl/gsl_linalg.h>

#include "givens.c"
#include "apply_givens.c"

/* Factorise a general M x N matrix A into
 *
 *   A = Q R
 *
 * where Q is orthogonal (M x M) and R is upper triangular (M x N).
 *
 * Q is stored as a packed set of Householder transformations in the
 * strict lower triangular part of the input matrix.
 *
 * R is stored in the diagonal and upper triangle of the input matrix.
 *
 * The full matrix for Q can be obtained as the product
 *
 *       Q = Q_k .. Q_2 Q_1
 *
 * where k = MIN(M,N) and
 *
 *       Q_i = (I - tau_i * v_i * v_i')
 *
 * and where v_i is a Householder vector
 *
 *       v_i = [1, m(i+1,i), m(i+2,i), ... , m(M,i)]
 *
 * This storage scheme is the same as in LAPACK.  */

int
gsl_linalg_QR_decomp (gsl_matrix * A, gsl_vector * tau)
{
  const size_t M = A->size1;
  const size_t N = A->size2;

  if (tau->size != GSL_MIN (M, N))
    {
      GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN);
    }
  else
    {
      size_t i;

      for (i = 0; i < GSL_MIN (M, N); i++)
        {
          /* Compute the Householder transformation to reduce the j-th
             column of the matrix to a multiple of the j-th unit vector */

          gsl_vector_view c_full = gsl_matrix_column (A, i);
          gsl_vector_view c = gsl_vector_subvector (&(c_full.vector), i, M-i);

          double tau_i = gsl_linalg_householder_transform (&(c.vector));

          gsl_vector_set (tau, i, tau_i);

          /* Apply the transformation to the remaining columns and
             update the norms */

          if (i + 1 < N)
            {
              gsl_matrix_view m = gsl_matrix_submatrix (A, i, i + 1, M - i, N - (i + 1));
              gsl_linalg_householder_hm (tau_i, &(c.vector), &(m.matrix));
            }
        }

      return GSL_SUCCESS;
    }
}

/* Solves the system A x = b using the QR factorisation,

 *  R x = Q^T b
 *
 * to obtain x. Based on SLATEC code.
 */

int
gsl_linalg_QR_solve (const gsl_matrix * QR, const gsl_vector * tau, const gsl_vector * b, gsl_vector * x)
{
  if (QR->size1 != QR->size2)
    {
      GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR);
    }
  else if (QR->size1 != b->size)
    {
      GSL_ERROR ("matrix size must match b size", GSL_EBADLEN);
    }
  else if (QR->size2 != x->size)
    {
      GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
    }
  else
    {
      /* Copy x <- b */

      gsl_vector_memcpy (x, b);

      /* Solve for x */

      gsl_linalg_QR_svx (QR, tau, x);

      return GSL_SUCCESS;
    }
}

/* Solves the system A x = b in place using the QR factorisation,

 *  R x = Q^T b
 *
 * to obtain x. Based on SLATEC code.
 */

int
gsl_linalg_QR_svx (const gsl_matrix * QR, const gsl_vector * tau, gsl_vector * x)
{

  if (QR->size1 != QR->size2)
    {
      GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR);
    }
  else if (QR->size1 != x->size)
    {
      GSL_ERROR ("matrix size must match x/rhs size", GSL_EBADLEN);
    }
  else
    {
      /* compute rhs = Q^T b */

      gsl_linalg_QR_QTvec (QR, tau, x);

      /* Solve R x = rhs, storing x in-place */

      gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, QR, x);

      return GSL_SUCCESS;
    }
}

/* Find the least squares solution to the overdetermined system
 *
 *   A x = b
 *
 * for M >= N using the QR factorization A = Q R.
 */

int
gsl_linalg_QR_lssolve (const gsl_matrix * QR, const gsl_vector * tau, const gsl_vector * b, gsl_vector * x, gsl_vector * residual)
{
  const size_t M = QR->size1;
  const size_t N = QR->size2;

  if (M < N)
    {
      GSL_ERROR ("QR matrix must have M>=N", GSL_EBADLEN);
    }
  else if (M != b->size)
    {
      GSL_ERROR ("matrix size must match b size", GSL_EBADLEN);
    }
  else if (N != x->size)
    {
      GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
    }
  else if (M != residual->size)
    {
      GSL_ERROR ("matrix size must match residual size", GSL_EBADLEN);
    }
  else
    {
      gsl_matrix_const_view R = gsl_matrix_const_submatrix (QR, 0, 0, N, N);
      gsl_vector_view c = gsl_vector_subvector(residual, 0, N);

      gsl_vector_memcpy(residual, b);

      /* compute rhs = Q^T b */

      gsl_linalg_QR_QTvec (QR, tau, residual);

      /* Solve R x = rhs */

      gsl_vector_memcpy(x, &(c.vector));

      gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, &(R.matrix), x);

      /* Compute residual = b - A x = Q (Q^T b - R x) */

      gsl_vector_set_zero(&(c.vector));

      gsl_linalg_QR_Qvec(QR, tau, residual);

      return GSL_SUCCESS;
    }
}

int
gsl_linalg_QR_Rsolve (const gsl_matrix * QR, const gsl_vector * b, gsl_vector * x)
{
  if (QR->size1 != QR->size2)
    {
      GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR);
    }
  else if (QR->size1 != b->size)
    {
      GSL_ERROR ("matrix size must match b size", GSL_EBADLEN);
    }
  else if (QR->size2 != x->size)
    {
      GSL_ERROR ("matrix size must match x size", GSL_EBADLEN);
    }
  else
    {
      /* Copy x <- b */

      gsl_vector_memcpy (x, b);

      /* Solve R x = b, storing x in-place */

      gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, QR, x);

      return GSL_SUCCESS;
    }
}

int
gsl_linalg_QR_Rsvx (const gsl_matrix * QR, gsl_vector * x)
{
  if (QR->size1 != QR->size2)
    {
      GSL_ERROR ("QR matrix must be square", GSL_ENOTSQR);
    }
  else if (QR->size1 != x->size)
    {
      GSL_ERROR ("matrix size must match rhs size", GSL_EBADLEN);
    }
  else
    {
      /* Solve R x = b, storing x in-place */

      gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, QR, x);

      return GSL_SUCCESS;
    }
}

int
gsl_linalg_R_solve (const gsl_matrix * R, const gsl_vector * b, gsl_vector * x)
{
  if (R->size1 != R->size2)
    {
      GSL_ERROR ("R matrix must be square", GSL_ENOTSQR);
    }
  else if (R->size1 != b->size)
    {
      GSL_ERROR ("matrix size must match b size", GSL_EBADLEN);
    }
  else if (R->size2 != x->size)
    {
      GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
    }
  else
    {
      /* Copy x <- b */

      gsl_vector_memcpy (x, b);

      /* Solve R x = b, storing x inplace in b */

      gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, R, x);

      return GSL_SUCCESS;
    }
}

int
gsl_linalg_R_svx (const gsl_matrix * R, gsl_vector * x)
{
  if (R->size1 != R->size2)
    {
      GSL_ERROR ("R matrix must be square", GSL_ENOTSQR);
    }
  else if (R->size2 != x->size)
    {
      GSL_ERROR ("matrix size must match solution size", GSL_EBADLEN);
    }
  else
    {
      /* Solve R x = b, storing x inplace in b */

      gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, R, x);

      return GSL_SUCCESS;
    }
}

/* Form the product Q^T v  from a QR factorized matrix
 */

int
gsl_linalg_QR_QTvec (const gsl_matrix * QR, const gsl_vector * tau, gsl_vector * v)
{
  const size_t M = QR->size1;
  const size_t N = QR->size2;

  if (tau->size != GSL_MIN (M, N))
    {
      GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN);
    }
  else if (v->size != M)
    {
      GSL_ERROR ("vector size must be N", GSL_EBADLEN);
    }
  else
    {
      size_t i;

      /* compute Q^T v */

      for (i = 0; i < GSL_MIN (M, N); i++)
        {
          gsl_vector_const_view c = gsl_matrix_const_column (QR, i);
          gsl_vector_const_view h = gsl_vector_const_subvector (&(c.vector), i, M - i);
          gsl_vector_view w = gsl_vector_subvector (v, i, M - i);
          double ti = gsl_vector_get (tau, i);
          gsl_linalg_householder_hv (ti, &(h.vector), &(w.vector));
        }
      return GSL_SUCCESS;
    }
}

int
gsl_linalg_QR_Qvec (const gsl_matrix * QR, const gsl_vector * tau, gsl_vector * v)
{
  const size_t M = QR->size1;
  const size_t N = QR->size2;

  if (tau->size != GSL_MIN (M, N))
    {
      GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN);
    }
  else if (v->size != M)
    {
      GSL_ERROR ("vector size must be N", GSL_EBADLEN);
    }
  else
    {
      size_t i;

      /* compute Q^T v */

      for (i = GSL_MIN (M, N); i-- > 0;)
        {
          gsl_vector_const_view c = gsl_matrix_const_column (QR, i);
          gsl_vector_const_view h = gsl_vector_const_subvector (&(c.vector),
                                                                i, M - i);
          gsl_vector_view w = gsl_vector_subvector (v, i, M - i);
          double ti = gsl_vector_get (tau, i);
          gsl_linalg_householder_hv (ti, &h.vector, &w.vector);
        }
      return GSL_SUCCESS;
    }
}

/* Form the product Q^T A  from a QR factorized matrix */

int
gsl_linalg_QR_QTmat (const gsl_matrix * QR, const gsl_vector * tau, gsl_matrix * A)
{
  const size_t M = QR->size1;
  const size_t N = QR->size2;

  if (tau->size != GSL_MIN (M, N))
    {
      GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN);
    }
  else if (A->size1 != M)
    {
      GSL_ERROR ("matrix must have M rows", GSL_EBADLEN);
    }
  else
    {
      size_t i;

      /* compute Q^T A */

      for (i = 0; i < GSL_MIN (M, N); i++)
        {
          gsl_vector_const_view c = gsl_matrix_const_column (QR, i);
          gsl_vector_const_view h = gsl_vector_const_subvector (&(c.vector), i, M - i);
          gsl_matrix_view m = gsl_matrix_submatrix(A, i, 0, M - i, A->size2);
          double ti = gsl_vector_get (tau, i);
          gsl_linalg_householder_hm (ti, &(h.vector), &(m.matrix));
        }
      return GSL_SUCCESS;
    }
}

/*  Form the orthogonal matrix Q from the packed QR matrix */

int
gsl_linalg_QR_unpack (const gsl_matrix * QR, const gsl_vector * tau, gsl_matrix * Q, gsl_matrix * R)
{
  const size_t M = QR->size1;
  const size_t N = QR->size2;

  if (Q->size1 != M || Q->size2 != M)
    {
      GSL_ERROR ("Q matrix must be M x M", GSL_ENOTSQR);
    }
  else if (R->size1 != M || R->size2 != N)
    {
      GSL_ERROR ("R matrix must be M x N", GSL_ENOTSQR);
    }
  else if (tau->size != GSL_MIN (M, N))
    {
      GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN);
    }
  else
    {
      size_t i, j;

      /* Initialize Q to the identity */

      gsl_matrix_set_identity (Q);

      for (i = GSL_MIN (M, N); i-- > 0;)
        {
          gsl_vector_const_view c = gsl_matrix_const_column (QR, i);
          gsl_vector_const_view h = gsl_vector_const_subvector (&c.vector,
                                                                i, M - i);
          gsl_matrix_view m = gsl_matrix_submatrix (Q, i, i, M - i, M - i);
          double ti = gsl_vector_get (tau, i);
          gsl_linalg_householder_hm (ti, &h.vector, &m.matrix);
        }

      /*  Form the right triangular matrix R from a packed QR matrix */

      for (i = 0; i < M; i++)
        {
          for (j = 0; j < i && j < N; j++)
            gsl_matrix_set (R, i, j, 0.0);

          for (j = i; j < N; j++)
            gsl_matrix_set (R, i, j, gsl_matrix_get (QR, i, j));
        }

      return GSL_SUCCESS;
    }
}

/* Update a QR factorisation for A= Q R ,  A' = A + u v^T,

 * Q' R' = QR + u v^T
 *       = Q (R + Q^T u v^T)
 *       = Q (R + w v^T)
 *
 * where w = Q^T u.
 *
 * Algorithm from Golub and Van Loan, "Matrix Computations", Section
 * 12.5 (Updating Matrix Factorizations, Rank-One Changes)
 */

int
gsl_linalg_QR_update (gsl_matrix * Q, gsl_matrix * R,
                      gsl_vector * w, const gsl_vector * v)
{
  const size_t M = R->size1;
  const size_t N = R->size2;

  if (Q->size1 != M || Q->size2 != M)
    {
      GSL_ERROR ("Q matrix must be M x M if R is M x N", GSL_ENOTSQR);
    }
  else if (w->size != M)
    {
      GSL_ERROR ("w must be length M if R is M x N", GSL_EBADLEN);
    }
  else if (v->size != N)
    {
      GSL_ERROR ("v must be length N if R is M x N", GSL_EBADLEN);
    }
  else
    {
      size_t j, k;
      double w0;

      /* Apply Given's rotations to reduce w to (|w|, 0, 0, ... , 0)

         J_1^T .... J_(n-1)^T w = +/- |w| e_1

         simultaneously applied to R,  H = J_1^T ... J^T_(n-1) R
         so that H is upper Hessenberg.  (12.5.2) */

      for (k = M - 1; k > 0; k--)  /* loop from k = M-1 to 1 */
        {
          double c, s;
          double wk = gsl_vector_get (w, k);
          double wkm1 = gsl_vector_get (w, k - 1);

          create_givens (wkm1, wk, &c, &s);
          apply_givens_vec (w, k - 1, k, c, s);
          apply_givens_qr (M, N, Q, R, k - 1, k, c, s);
        }

      w0 = gsl_vector_get (w, 0);

      /* Add in w v^T  (Equation 12.5.3) */

      for (j = 0; j < N; j++)
        {
          double r0j = gsl_matrix_get (R, 0, j);
          double vj = gsl_vector_get (v, j);
          gsl_matrix_set (R, 0, j, r0j + w0 * vj);
        }

      /* Apply Givens transformations R' = G_(n-1)^T ... G_1^T H
         Equation 12.5.4 */

      for (k = 1; k < GSL_MIN(M,N+1); k++)
        {
          double c, s;
          double diag = gsl_matrix_get (R, k - 1, k - 1);
          double offdiag = gsl_matrix_get (R, k, k - 1);

          create_givens (diag, offdiag, &c, &s);
          apply_givens_qr (M, N, Q, R, k - 1, k, c, s);

          gsl_matrix_set (R, k, k - 1, 0.0);    /* exact zero of G^T */
        }

      return GSL_SUCCESS;
    }
}

int
gsl_linalg_QR_QRsolve (gsl_matrix * Q, gsl_matrix * R, const gsl_vector * b, gsl_vector * x)
{
  const size_t M = R->size1;
  const size_t N = R->size2;

  if (M != N)
    {
      return GSL_ENOTSQR;
    }
  else if (Q->size1 != M || b->size != M || x->size != M)
    {
      return GSL_EBADLEN;
    }
  else
    {
      /* compute sol = Q^T b */

      gsl_blas_dgemv (CblasTrans, 1.0, Q, b, 0.0, x);

      /* Solve R x = sol, storing x in-place */

      gsl_blas_dtrsv (CblasUpper, CblasNoTrans, CblasNonUnit, R, x);

      return GSL_SUCCESS;
    }
}


/*
 * Gsl_blas_ddot: test gsl_blas_ddot (vector . vector)
 *
 * Copyright (c) 2012 Jérémie Decock
 *
 * Required: GSL library (libgsl0-dev)
 * Usage: gcc gsl_blas_ddot.c -lgsl -lgslcblas -lm
 *    or: gcc gsl_blas_ddot.c $(pkg-config --libs gsl)
 */

#include <stdio.h>
#include <gsl/gsl_blas.h>
#include <gsl/gsl_vector.h>

int main (void)
{
    gsl_vector * v1 = gsl_vector_alloc(3);
    gsl_vector * v2 = gsl_vector_alloc(3);

    gsl_vector_set_all(v1, 3.0);
    gsl_vector_set_all(v2, 2.0);

    double r;
    gsl_blas_ddot(v1, v2, &r);

    printf("%f\n", r);

    gsl_vector_free(v1);
    gsl_vector_free(v2);

    return 0;
}


/* randist/tdist.c
 *
 * Copyright (C) 1996, 1997, 1998, 1999, 2000 James Theiler, Brian Gough
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or (at
 * your option) any later version.
 *
 * This program 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
 * General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 */

#include <config.h>
#include <math.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_sf_gamma.h>
#include <gsl/gsl_rng.h>
#include <gsl/gsl_randist.h>

/* The t-distribution has the form

   p(x) dx = (Gamma((nu + 1)/2)/(sqrt(pi nu) Gamma(nu/2))
   * (1 + (x^2)/nu)^-((nu + 1)/2) dx

   The method used here is the one described in Knuth */

double
gsl_ran_tdist (const gsl_rng * r, const double nu)
{
  if (nu <= 2)
    {
      double Y1 = gsl_ran_ugaussian (r);
      double Y2 = gsl_ran_chisq (r, nu);

      double t = Y1 / sqrt (Y2 / nu);

      return t;
    }
  else
    {
      double Y1, Y2, Z, t;
      do
	{
	  Y1 = gsl_ran_ugaussian (r);
	  Y2 = gsl_ran_exponential (r, 1 / (nu/2 - 1));

	  Z = Y1 * Y1 / (nu - 2);
	}
      while (1 - Z < 0 || exp (-Y2 - Z) > (1 - Z));

      /* Note that there is a typo in Knuth's formula, the line below
	 is taken from the original paper of Marsaglia, Mathematics of
	 Computation, 34 (1980), p 234-256 */

      t = Y1 / sqrt ((1 - 2 / nu) * (1 - Z));
      return t;
    }
}

double
gsl_ran_tdist_pdf (const double x, const double nu)
{
  double p;

  double lg1 = gsl_sf_lngamma (nu / 2);
  double lg2 = gsl_sf_lngamma ((nu + 1) / 2);

  p = ((exp (lg2 - lg1) / sqrt (M_PI * nu))
       * pow ((1 + x * x / nu), -(nu + 1) / 2));
  return p;
}


/* min/test_funcs.c
 *
 * Copyright (C) 1996, 1997, 1998, 1999, 2000 Brian Gough
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or (at
 * your option) any later version.
 *
 * This program 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
 * General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 */

#include <gsl/gsl_math.h>
#include <gsl/gsl_min.h>

#include "test.h"

gsl_function create_function (double (*f)(double, void *))
{
  gsl_function F ;
  F.function = f ;
  F.params = 0 ;
  return F ;
}

double
f_cos (double x, void * p)
{
  p = 0;  /* avoid warning about unused parameter */
  return cos(x);
}

/* f(x) = x^4 - 1 */
/* minimum at x = 0 */

double
func1 (double x, void * p)
{
  p = 0;  /* avoid warning about unused parameter */
  return pow (x, 4.0) - 1;
}

/* f(x) = sqrt(|x|) */
/* minimum at x = 0 */

double
func2 (double x, void * p)
{
  p = 0;  /* avoid warning about unused parameter */
  return sqrt(fabs(x));
}

/* f(x) = 1 for x < 1 and -exp(-x) for x >= 1 */
/* minimum at x = 1 */

double
func3 (double x, void * p)
{
  p = 0;  /* avoid warning about unused parameter */

  if (x < 1)
    return 1 ;
  else
    return - exp(-x) ;
}

/* f(x) = x - 30/(1+1e5*(x-0.8)**2) */
/* minimum near x = 0.8 */

double
func4 (double x, void * p)
{
  p = 0;  /* avoid warning about unused parameter */

  return x - 30.0 / (1.0 + 1e5 * pow(x-0.8, 2.0));
}


/* specfunc/gsl_sf_bessel.h
 *
 * Copyright (C) 1996, 1997, 1998, 1999, 2000 Gerard Jungman
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 3 of the License, or (at
 * your option) any later version.
 *
 * This program 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
 * General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 */

/* Author:  G. Jungman */

#ifndef __GSL_SF_BESSEL_H__
#define __GSL_SF_BESSEL_H__

#include <stdlib.h>
#include <gsl/gsl_mode.h>
#include <gsl/gsl_precision.h>
#include <gsl/gsl_sf_result.h>

#undef __BEGIN_DECLS
#undef __END_DECLS
#ifdef __cplusplus
# define __BEGIN_DECLS extern "C" {
# define __END_DECLS }
#else
# define __BEGIN_DECLS /* empty */
# define __END_DECLS /* empty */
#endif

__BEGIN_DECLS

/* Regular Bessel Function J_0(x)
 *
 * exceptions: none
 */
int gsl_sf_bessel_J0_e(const double x,  gsl_sf_result * result);
double gsl_sf_bessel_J0(const double x);

/* Regular Bessel Function J_1(x)
 *
 * exceptions: GSL_EUNDRFLW
 */
int gsl_sf_bessel_J1_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_J1(const double x);

/* Regular Bessel Function J_n(x)
 *
 * exceptions: GSL_EUNDRFLW
 */
int gsl_sf_bessel_Jn_e(int n, double x, gsl_sf_result * result);
double gsl_sf_bessel_Jn(const int n, const double x);

/* Regular Bessel Function J_n(x),  nmin <= n <= nmax
 *
 * exceptions: GSL_EDOM, GSL_EUNDRFLW
 */
int gsl_sf_bessel_Jn_array(int nmin, int nmax, double x, double * result_array);

/* Irregular Bessel function Y_0(x)
 *
 * x > 0.0
 * exceptions: GSL_EDOM, GSL_EUNDRFLW
 */
int gsl_sf_bessel_Y0_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_Y0(const double x);

/* Irregular Bessel function Y_1(x)
 *
 * x > 0.0
 * exceptions: GSL_EDOM, GSL_EOVRFLW, GSL_EUNDRFLW
 */
int gsl_sf_bessel_Y1_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_Y1(const double x);

/* Irregular Bessel function Y_n(x)
 *
 * x > 0.0
 * exceptions: GSL_EDOM, GSL_EOVRFLW, GSL_EUNDRFLW
 */
int gsl_sf_bessel_Yn_e(int n,const double x, gsl_sf_result * result);
double gsl_sf_bessel_Yn(const int n,const double x);

/* Irregular Bessel function Y_n(x), nmin <= n <= nmax
 *
 * x > 0.0
 * exceptions: GSL_EDOM, GSL_EOVRFLW, GSL_EUNDRFLW
 */
int gsl_sf_bessel_Yn_array(const int nmin, const int nmax, const double x, double * result_array);

/* Regular modified Bessel function I_0(x)
 *
 * exceptions: GSL_EOVRFLW
 */
int gsl_sf_bessel_I0_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_I0(const double x);

/* Regular modified Bessel function I_1(x)
 *
 * exceptions: GSL_EOVRFLW, GSL_EUNDRFLW
 */
int gsl_sf_bessel_I1_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_I1(const double x);

/* Regular modified Bessel function I_n(x)
 *
 * exceptions: GSL_EOVRFLW, GSL_EUNDRFLW
 */
int gsl_sf_bessel_In_e(const int n, const double x, gsl_sf_result * result);
double gsl_sf_bessel_In(const int n, const double x);

/* Regular modified Bessel function  I_n(x) for n=nmin,...,nmax
 *
 * nmin >=0, nmax >= nmin
 * exceptions: GSL_EDOM, GSL_EOVRFLW, GSL_EUNDRFLW
 */
int gsl_sf_bessel_In_array(const int nmin, const int nmax, const double x, double * result_array);

/* Scaled regular modified Bessel function
 *  exp(-|x|) I_0(x)
 *
 * exceptions: none
 */
int gsl_sf_bessel_I0_scaled_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_I0_scaled(const double x);

/* Scaled regular modified Bessel function
 *  exp(-|x|) I_1(x)
 *
 * exceptions: GSL_EUNDRFLW
 */
int gsl_sf_bessel_I1_scaled_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_I1_scaled(const double x);

/* Scaled regular modified Bessel function
 *  exp(-|x|) I_n(x)
 *
 * exceptions: GSL_EUNDRFLW
 */
int gsl_sf_bessel_In_scaled_e(int n, const double x, gsl_sf_result * result);
double gsl_sf_bessel_In_scaled(const int n, const double x);

/* Scaled regular modified Bessel function
 *  exp(-|x|) I_n(x)  for n=nmin,...,nmax
 *
 * nmin >=0, nmax >= nmin
 * exceptions: GSL_EUNDRFLW
 */
int gsl_sf_bessel_In_scaled_array(const int nmin, const int nmax, const double x, double * result_array);

/* Irregular modified Bessel function K_0(x)
 *
 * x > 0.0
 * exceptions: GSL_EDOM, GSL_EUNDRFLW
 */
int gsl_sf_bessel_K0_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_K0(const double x);

/* Irregular modified Bessel function K_1(x)
 *
 * x > 0.0
 * exceptions: GSL_EDOM, GSL_EOVRFLW, GSL_EUNDRFLW
 */
int gsl_sf_bessel_K1_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_K1(const double x);

/* Irregular modified Bessel function K_n(x)
 *
 * x > 0.0
 * exceptions: GSL_EDOM, GSL_EOVRFLW, GSL_EUNDRFLW
 */
int gsl_sf_bessel_Kn_e(const int n, const double x, gsl_sf_result * result);
double gsl_sf_bessel_Kn(const int n, const double x);

/* Irregular modified Bessel function  K_n(x)  for n=nmin,...,nmax
 *
 * x > 0.0, nmin >=0, nmax >= nmin
 * exceptions: GSL_EDOM, GSL_EOVRFLW, GSL_EUNDRFLW
 */
int gsl_sf_bessel_Kn_array(const int nmin, const int nmax, const double x, double * result_array);

/* Scaled irregular modified Bessel function
 *  exp(x) K_0(x)
 *
 * x > 0.0
 * exceptions: GSL_EDOM
 */
int gsl_sf_bessel_K0_scaled_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_K0_scaled(const double x);

/* Scaled irregular modified Bessel function
 *  exp(x) K_1(x)
 *
 * x > 0.0
 * exceptions: GSL_EDOM, GSL_EUNDRFLW
 */
int gsl_sf_bessel_K1_scaled_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_K1_scaled(const double x);

/* Scaled irregular modified Bessel function
 *  exp(x) K_n(x)
 *
 * x > 0.0
 * exceptions: GSL_EDOM, GSL_EUNDRFLW
 */
int gsl_sf_bessel_Kn_scaled_e(int n, const double x, gsl_sf_result * result);
double gsl_sf_bessel_Kn_scaled(const int n, const double x);

/* Scaled irregular modified Bessel function  exp(x) K_n(x)  for n=nmin,...,nmax
 *
 * x > 0.0, nmin >=0, nmax >= nmin
 * exceptions: GSL_EDOM, GSL_EUNDRFLW
 */
int gsl_sf_bessel_Kn_scaled_array(const int nmin, const int nmax, const double x, double * result_array);

/* Regular spherical Bessel function j_0(x) = sin(x)/x
 *
 * exceptions: none
 */
int gsl_sf_bessel_j0_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_j0(const double x);

/* Regular spherical Bessel function j_1(x) = (sin(x)/x - cos(x))/x
 *
 * exceptions: GSL_EUNDRFLW
 */
int gsl_sf_bessel_j1_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_j1(const double x);

/* Regular spherical Bessel function j_2(x) = ((3/x^2 - 1)sin(x) - 3cos(x)/x)/x
 *
 * exceptions: GSL_EUNDRFLW
 */
int gsl_sf_bessel_j2_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_j2(const double x);

/* Regular spherical Bessel function j_l(x)
 *
 * l >= 0, x >= 0.0
 * exceptions: GSL_EDOM, GSL_EUNDRFLW
 */
int gsl_sf_bessel_jl_e(const int l, const double x, gsl_sf_result * result);
double gsl_sf_bessel_jl(const int l, const double x);

/* Regular spherical Bessel function j_l(x) for l=0,1,...,lmax
 *
 * exceptions: GSL_EDOM, GSL_EUNDRFLW
 */
int gsl_sf_bessel_jl_array(const int lmax, const double x, double * result_array);

/* Regular spherical Bessel function j_l(x) for l=0,1,...,lmax
 * Uses Steed's method.
 *
 * exceptions: GSL_EDOM, GSL_EUNDRFLW
 */
int gsl_sf_bessel_jl_steed_array(const int lmax, const double x, double * jl_x_array);

/* Irregular spherical Bessel function y_0(x)
 *
 * exceptions: none
 */
int gsl_sf_bessel_y0_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_y0(const double x);

/* Irregular spherical Bessel function y_1(x)
 *
 * exceptions: GSL_EUNDRFLW
 */
int gsl_sf_bessel_y1_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_y1(const double x);

/* Irregular spherical Bessel function y_2(x)
 *
 * exceptions: GSL_EUNDRFLW
 */
int gsl_sf_bessel_y2_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_y2(const double x);

/* Irregular spherical Bessel function y_l(x)
 *
 * exceptions: GSL_EUNDRFLW
 */
int gsl_sf_bessel_yl_e(int l, const double x, gsl_sf_result * result);
double gsl_sf_bessel_yl(const int l, const double x);

/* Irregular spherical Bessel function y_l(x) for l=0,1,...,lmax
 *
 * exceptions: GSL_EUNDRFLW
 */
int gsl_sf_bessel_yl_array(const int lmax, const double x, double * result_array);

/* Regular scaled modified spherical Bessel function
 *
 * Exp[-|x|] i_0(x)
 *
 * exceptions: none
 */
int gsl_sf_bessel_i0_scaled_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_i0_scaled(const double x);

/* Regular scaled modified spherical Bessel function
 *
 * Exp[-|x|] i_1(x)
 *
 * exceptions: GSL_EUNDRFLW
 */
int gsl_sf_bessel_i1_scaled_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_i1_scaled(const double x);

/* Regular scaled modified spherical Bessel function
 *
 * Exp[-|x|] i_2(x)
 *
 * exceptions: GSL_EUNDRFLW
 */
int gsl_sf_bessel_i2_scaled_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_i2_scaled(const double x);

/* Regular scaled modified spherical Bessel functions
 *
 * Exp[-|x|] i_l(x)
 *
 * i_l(x) = Sqrt[Pi/(2x)] BesselI[l+1/2,x]
 *
 * l >= 0
 * exceptions: GSL_EDOM, GSL_EUNDRFLW
 */
int gsl_sf_bessel_il_scaled_e(const int l, double x, gsl_sf_result * result);
double gsl_sf_bessel_il_scaled(const int l, const double x);

/* Regular scaled modified spherical Bessel functions
 *
 * Exp[-|x|] i_l(x)
 * for l=0,1,...,lmax
 *
 * exceptions: GSL_EUNDRFLW
 */
int gsl_sf_bessel_il_scaled_array(const int lmax, const double x, double * result_array);

/* Irregular scaled modified spherical Bessel function
 * Exp[x] k_0(x)
 *
 * x > 0.0
 * exceptions: GSL_EDOM, GSL_EUNDRFLW
 */
int gsl_sf_bessel_k0_scaled_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_k0_scaled(const double x);

/* Irregular modified spherical Bessel function
 * Exp[x] k_1(x)
 *
 * x > 0.0
 * exceptions: GSL_EDOM, GSL_EUNDRFLW, GSL_EOVRFLW
 */
int gsl_sf_bessel_k1_scaled_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_k1_scaled(const double x);

/* Irregular modified spherical Bessel function
 * Exp[x] k_2(x)
 *
 * x > 0.0
 * exceptions: GSL_EDOM, GSL_EUNDRFLW, GSL_EOVRFLW
 */
int gsl_sf_bessel_k2_scaled_e(const double x, gsl_sf_result * result);
double gsl_sf_bessel_k2_scaled(const double x);

/* Irregular modified spherical Bessel function
 * Exp[x] k_l[x]
 *
 * k_l(x) = Sqrt[Pi/(2x)] BesselK[l+1/2,x]
 *
 * exceptions: GSL_EDOM, GSL_EUNDRFLW
 */
int gsl_sf_bessel_kl_scaled_e(int l, const double x, gsl_sf_result * result);
double gsl_sf_bessel_kl_scaled(const int l, const double x);

/* Irregular scaled modified spherical Bessel function
 * Exp[x] k_l(x)
 *
 * for l=0,1,...,lmax
 * exceptions: GSL_EDOM, GSL_EUNDRFLW
 */
int gsl_sf_bessel_kl_scaled_array(const int lmax, const double x, double * result_array);

/* Regular cylindrical Bessel function J_nu(x)
 *
 * exceptions: GSL_EDOM, GSL_EUNDRFLW
 */
int gsl_sf_bessel_Jnu_e(const double nu, const double x, gsl_sf_result * result);
double gsl_sf_bessel_Jnu(const double nu, const double x);

/* Irregular cylindrical Bessel function Y_nu(x)
 *
 * exceptions:
 */
int gsl_sf_bessel_Ynu_e(double nu, double x, gsl_sf_result * result);
double gsl_sf_bessel_Ynu(const double nu, const double x);

/* Regular cylindrical Bessel function J_nu(x)
 * evaluated at a series of x values. The array
 * contains the x values. They are assumed to be
 * strictly ordered and positive. The array is
 * over-written with the values of J_nu(x_i).
 *
 * exceptions: GSL_EDOM, GSL_EINVAL
 */
int gsl_sf_bessel_sequence_Jnu_e(double nu, gsl_mode_t mode, size_t size, double * v);

/* Scaled modified cylindrical Bessel functions
 *
 * Exp[-|x|] BesselI[nu, x]
 * x >= 0, nu >= 0
 *
 * exceptions: GSL_EDOM
 */
int gsl_sf_bessel_Inu_scaled_e(double nu, double x, gsl_sf_result * result);
double gsl_sf_bessel_Inu_scaled(double nu, double x);

/* Modified cylindrical Bessel functions
 *
 * BesselI[nu, x]
 * x >= 0, nu >= 0
 *
 * exceptions: GSL_EDOM, GSL_EOVRFLW
 */
int gsl_sf_bessel_Inu_e(double nu, double x, gsl_sf_result * result);
double gsl_sf_bessel_Inu(double nu, double x);

/* Scaled modified cylindrical Bessel functions
 *
 * Exp[+|x|] BesselK[nu, x]
 * x > 0, nu >= 0
 *
 * exceptions: GSL_EDOM
 */
int gsl_sf_bessel_Knu_scaled_e(const double nu, const double x, gsl_sf_result * result);
double gsl_sf_bessel_Knu_scaled(const double nu, const double x);

/* Modified cylindrical Bessel functions
 *
 * BesselK[nu, x]
 * x > 0, nu >= 0
 *
 * exceptions: GSL_EDOM, GSL_EUNDRFLW
 */
int gsl_sf_bessel_Knu_e(const double nu, const double x, gsl_sf_result * result);
double gsl_sf_bessel_Knu(const double nu, const double x);

/* Logarithm of modified cylindrical Bessel functions.
 *
 * Log[BesselK[nu, x]]
 * x > 0, nu >= 0
 *
 * exceptions: GSL_EDOM
 */
int gsl_sf_bessel_lnKnu_e(const double nu, const double x, gsl_sf_result * result);
double gsl_sf_bessel_lnKnu(const double nu, const double x);

/* s'th positive zero of the Bessel function J_0(x).
 *
 * exceptions:
 */
int gsl_sf_bessel_zero_J0_e(unsigned int s, gsl_sf_result * result);
double gsl_sf_bessel_zero_J0(unsigned int s);

/* s'th positive zero of the Bessel function J_1(x).
 *
 * exceptions:
 */
int gsl_sf_bessel_zero_J1_e(unsigned int s, gsl_sf_result * result);
double gsl_sf_bessel_zero_J1(unsigned int s);

/* s'th positive zero of the Bessel function J_nu(x).
 *
 * exceptions:
 */
int gsl_sf_bessel_zero_Jnu_e(double nu, unsigned int s, gsl_sf_result * result);
double gsl_sf_bessel_zero_Jnu(double nu, unsigned int s);

__END_DECLS

#endif /* __GSL_SF_BESSEL_H__ */


/* AUTORIGHTS
Copyright (C) 2007 Princeton University

This file is part of Ferret Toolkit.

Ferret Toolkit is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

This program 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 General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software Foundation,
Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*/
#include <math.h>
#ifdef _OPENMP
#include <omp.h>
#endif
#include <gsl/gsl_cdf.h>
#include <gsl/gsl_vector.h>
#include <gsl/gsl_multiroots.h>
#include <cass.h>
#include "LSH.h"
#include "local.h"

#define ERR	1e-4

struct local_params
{
	double a;
	double b;
	double W;
	int M;
	int L;
	int K;
};

static inline double p_col_helper (double x)
{
	double result;
	result = 2.0*gsl_cdf_ugaussian_P(x) - 1.0;
	result += sqrt(2.0/M_PI) * (exp(-x*x/2.0)-1.0)/x;
	return result;
}

static inline double p_col (double x, double W, int M, int L)
{
	return 1.0 - pow(1.0 - pow(p_col_helper(W/x), M), L);
}

static int fun (const gsl_vector *x, void *params, gsl_vector *f)
{
	double W = ((struct local_params *)params)->W;
	int M = ((struct local_params *)params)->M;
	int L = ((struct local_params *)params)->L;
	int K = ((struct local_params *)params)->K;
	double fa = ((struct local_params *)params)->a;
	double fb = ((struct local_params *)params)->b;
	double sxx, sxy, sx, sy, k, d;
	double a, b;
	int n;

	double alpha = gsl_vector_get(x, 0);
	double beta = gsl_vector_get(x, 1);

	sxx = sxy = sx = sy = 0;

	n = 0;
	k = 0;
	while ((k < K) && (n < 1000))
	{
		double lk, ld;
		n++;
		d = alpha * pow(n, beta);
		k += p_col(sqrt(d), W, M, L);
		lk = log(k);
		ld = log(d);
		sx += lk;
		sy += ld;
		sxx += lk * lk;
		sxy += lk * ld;
	}

	least_squares(&a, &b, n, sxx, sxy, sx, sy);

	a = exp(a);

	gsl_vector_set(f, 0, a - fa);
	gsl_vector_set(f, 1, b - fb);
	return GSL_SUCCESS;
}

int print_state (size_t iter, gsl_multiroot_fsolver *s)
{
	fprintf(stderr, "iter = %3zu x = %.3f %.3f "
		"f(x) = %.3e %.3e\n",
		iter,
		gsl_vector_get(s->x, 0),
		gsl_vector_get(s->x, 1),
		gsl_vector_get(s->f, 0),
		gsl_vector_get(s->f, 1));
	return 0;
}

int localdim (double a, double b, double *alpha, double *beta, double W, int M, int L, int K)
{
	const gsl_multiroot_fsolver_type *T = NULL;
	gsl_multiroot_fsolver *s = NULL;

	int status;
	size_t iter = 0;

	struct local_params params = {.a = a, .b = b, .W = W, .M = M, .L = L, .K = K};
	gsl_multiroot_function f = {&fun, 2, &params};

	gsl_vector *x = gsl_vector_alloc(2);
	gsl_vector_set(x, 0, a);
	gsl_vector_set(x, 1, b);

	if (s == NULL)
	{
		T = gsl_multiroot_fsolver_hybrids;
		s = gsl_multiroot_fsolver_alloc(T, 2);
	}

	gsl_multiroot_fsolver_set(s, &f, x);

	do
	{
		status = gsl_multiroot_fsolver_iterate(s);

//		print_state(iter, s);

		if (status) break;

		status = gsl_multiroot_test_residual(s->f, ERR);
		iter++;
	} while ((status == GSL_CONTINUE) && (iter < 1000));

//	fprintf(stderr, "status = %s\n", gsl_strerror(status));
	*alpha = gsl_vector_get(s->x, 0);
	*beta = gsl_vector_get(s->x, 1);

	gsl_multiroot_fsolver_free(s);
	gsl_vector_free(x);
	return 0;
}

int LSH_est_init (LSH_est_t *est, int a_step, double a_min, double a_max,
				int b_step, double b_min, double b_max, double W, int M, int L, int K)
{
	double a_delta, b_delta;
	int i, j;
	est->a_step = a_step;
	est->b_step = b_step;
	est->a_min = a_min;
	est->b_min = b_min;
	est->a_max = a_max;
	est->b_max = b_max;
	a_delta = est->a_delta = (a_max - a_min) / a_step;
	b_delta = est->b_delta = (b_max - b_min) / b_step;
	est->a_table = type_matrix_alloc(double , a_step, b_step);
	est->b_table = type_matrix_alloc(double , a_step, b_step);

	for (i = 0; i < a_step; i++)
	{
		for (j = 0; j < b_step; j++)
		{
			localdim(a_min + i * a_delta,
				b_min + j * b_delta,
				&est->a_table[i][j],
				&est->b_table[i][j],
				W, M, L, K);
		}
	}

	return 0;
}


/* specfunc/bessel_sequence.c
 *
 * Copyright (C) 1996, 1997, 1998, 1999, 2000 Gerard Jungman
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or (at
 * your option) any later version.
 *
 * This program 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
 * General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 */

/* Author:  G. Jungman */

#include <config.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_sf_bessel.h>

#define DYDX_p(p,u,x) (-(p)/(x) + (((nu)*(nu))/((x)*(x))-1.0)*(u))
#define DYDX_u(p,u,x) (p)

static int
rk_step(double nu, double x, double dx, double * Jp, double * J)
{
  double p_0 = *Jp;
  double u_0 = *J;

  double p_1 = dx * DYDX_p(p_0, u_0, x);
  double u_1 = dx * DYDX_u(p_0, u_0, x);

  double p_2 = dx * DYDX_p(p_0 + 0.5*p_1, u_0 + 0.5*u_1, x + 0.5*dx);
  double u_2 = dx * DYDX_u(p_0 + 0.5*p_1, u_0 + 0.5*u_1, x + 0.5*dx);

  double p_3 = dx * DYDX_p(p_0 + 0.5*p_2, u_0 + 0.5*u_2, x + 0.5*dx);
  double u_3 = dx * DYDX_u(p_0 + 0.5*p_2, u_0 + 0.5*u_2, x + 0.5*dx);

  double p_4 = dx * DYDX_p(p_0 + p_3, u_0 + u_3, x + dx);
  double u_4 = dx * DYDX_u(p_0 + p_3, u_0 + u_3, x + dx);

  *Jp = p_0 + p_1/6.0 + p_2/3.0 + p_3/3.0 + p_4/6.0;
  *J  = u_0 + u_1/6.0 + u_2/3.0 + u_3/3.0 + u_4/6.0;

  return GSL_SUCCESS;
}

int
gsl_sf_bessel_sequence_Jnu_e(double nu, gsl_mode_t mode, size_t size, double * v)
{
  /* CHECK_POINTER(v) */

  if(nu < 0.0) {
    GSL_ERROR ("domain error", GSL_EDOM);
  }
  else if(size == 0) {
    GSL_ERROR ("error", GSL_EINVAL);
  }
  else {
    const gsl_prec_t goal   = GSL_MODE_PREC(mode);
    const double dx_array[] = { 0.001, 0.03, 0.1 }; /* double, single, approx */
    const double dx_nominal = dx_array[goal];

    const int cnu = (int) ceil(nu);
    const double nu13 = pow(nu,1.0/3.0);
    const double smalls[] = { 0.01, 0.02, 0.4, 0.7, 1.3, 2.0, 2.5, 3.2, 3.5, 4.5, 6.0 };
    const double x_small = ( nu >= 10.0 ? nu - nu13 : smalls[cnu] );

    gsl_sf_result J0, J1;
    double Jp, J;
    double x;
    size_t i = 0;

    /* Calculate the first point. */
    x = v[0];
    gsl_sf_bessel_Jnu_e(nu, x, &J0);
    v[0] = J0.val;
    ++i;

    /* Step over the idiot case where the
     * first point was actually zero.
     */
    if(x == 0.0) {
      if(v[1] <= x) {
        /* Strict ordering failure. */
        GSL_ERROR ("error", GSL_EFAILED);
      }
      x = v[1];
      gsl_sf_bessel_Jnu_e(nu, x, &J0);
      v[1] = J0.val;
      ++i;
    }

    /* Calculate directly as long as the argument
     * is small. This is necessary because the
     * integration is not very good there.
     */
    while(v[i] < x_small && i < size) {
      if(v[i] <= x) {
        /* Strict ordering failure. */
        GSL_ERROR ("error", GSL_EFAILED);
      }
      x = v[i];
      gsl_sf_bessel_Jnu_e(nu, x, &J0);
      v[i] = J0.val;
      ++i;
    }

    /* At this point we are ready to integrate.
     * The value of x is the last calculated
     * point, which has the value J0; v[i] is
     * the next point we need to calculate. We
     * calculate nu+1 at x as well to get
     * the derivative, then we go forward.
     */
    gsl_sf_bessel_Jnu_e(nu+1.0, x, &J1);
    J  = J0.val;
    Jp = -J1.val + nu/x * J0.val;

    while(i < size) {
      const double dv = v[i] - x;
      const int Nd    = (int) ceil(dv/dx_nominal);
      const double dx = dv / Nd;
      double xj;
      int j;

      if(v[i] <= x) {
        /* Strict ordering failure. */
        GSL_ERROR ("error", GSL_EFAILED);
      }

      /* Integrate over interval up to next sample point.
       */
      for(j=0, xj=x; j<Nd; j++, xj += dx) {
        rk_step(nu, xj, dx, &Jp, &J);
      }

      /* Go to next interval. */
      x = v[i];
      v[i] = J;
      ++i;
    }

    return GSL_SUCCESS;
  }
}


#include <math.h>
#include <stdio.h>

#include <gsl/gsl_blas.h>
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_sf_pow_int.h>
#include <gsl/gsl_vector.h>

#include <argtable2.h>

#include "qdm.h"

void
qdm_ispline_vector(
    gsl_vector *result,
    const double tau,
    const size_t spline_df,
    const gsl_vector *knots
)
{
  size_t bin = qdm_vector_search(knots, tau);

  gsl_vector_set(result, 0, 1);

  for (size_t m = 0; m < result->size - 1; m++) {
    double v;

    if (bin < m) {
      v = 0;
    } else if (bin - spline_df + 1 > m) {
      v = 1;
    } else if (bin == m) {
      double n = gsl_sf_pow_int(tau - gsl_vector_get(knots, m), 3);
      double d1 = gsl_vector_get(knots, m + 3) - gsl_vector_get(knots, m);
      double d2 = gsl_vector_get(knots, m + 2) - gsl_vector_get(knots, m);
      double d3 = gsl_vector_get(knots, m + 1) - gsl_vector_get(knots, m);

      v = n / (d1 * d2 * d3);
    } else if (bin == m + 1) {
      double i1n = 3 * tau;
      double i1d = gsl_vector_get(knots, m + 2) - gsl_vector_get(knots, m + 1);
      double i1 = i1n / i1d;

      double i2n = -gsl_sf_pow_int(tau - gsl_vector_get(knots, m), 3);
      double i2d1 = gsl_vector_get(knots, m + 3) - gsl_vector_get(knots, m);
      double i2d2 = gsl_vector_get(knots, m + 2) - gsl_vector_get(knots, m);
      double i2d3 = gsl_vector_get(knots, m + 2) - gsl_vector_get(knots, m + 1);
      double i2 = i2n / (i2d1 * i2d2 * i2d3);

      double i3n = gsl_sf_pow_int(gsl_vector_get(knots, m + 3) - tau, 3);
      double i3d1 = gsl_vector_get(knots, m + 3) - gsl_vector_get(knots, m + 1);
      double i3d2 = gsl_vector_get(knots, m + 3) - gsl_vector_get(knots, m);
      double i3d3 = gsl_vector_get(knots, m + 2) - gsl_vector_get(knots, m + 1);
      double i3 = i3n / (i3d1 * i3d2 * i3d3);

      double i4an = -3 * gsl_vector_get(knots, m + 1);
      double i4ad = gsl_vector_get(knots, m + 2) - gsl_vector_get(knots, m + 1);
      double i4a = i4an / i4ad;
      double i4bn = gsl_sf_pow_int(gsl_vector_get(knots, m + 1) - gsl_vector_get(knots, m), 3);
      double i4bd1 = gsl_vector_get(knots, m + 3) - gsl_vector_get(knots, m);
      double i4bd2 = gsl_vector_get(knots, m + 2) - gsl_vector_get(knots, m);
      double i4bd3 = gsl_vector_get(knots, m + 2) - gsl_vector_get(knots, m + 1);
      double i4b = i4bn / (i4bd1 * i4bd2 * i4bd3);
      double i4cn = gsl_sf_pow_int(gsl_vector_get(knots, m + 3) - gsl_vector_get(knots, m + 1), 3);
      double i4cd1 = gsl_vector_get(knots, m + 3) - gsl_vector_get(knots, m + 1);
      double i4cd2 = gsl_vector_get(knots, m + 3) - gsl_vector_get(knots, m);
      double i4cd3 = gsl_vector_get(knots, m + 2) - gsl_vector_get(knots, m + 1);
      double i4c = i4cn / (i4cd1 * i4cd2 * i4cd3);
      double i4 = i4a + i4b - i4c;

      double i5 = 0;
      if (m != 1) {
        double i5n = gsl_sf_pow_int(gsl_vector_get(knots, m + 1) - gsl_vector_get(knots, m), 3);
        double i5d1 = gsl_vector_get(knots, m + 3) - gsl_vector_get(knots, m);
        double i5d2 = gsl_vector_get(knots, m + 2) - gsl_vector_get(knots, m);
        double i5d3 = gsl_vector_get(knots, m + 1) - gsl_vector_get(knots, m);
        i5 = i5n / (i5d1 * i5d2 * i5d3);
      }

      v = i1 + i2 + i3 + i4 + i5;
    } else {
      double n = gsl_sf_pow_int(gsl_vector_get(knots, m + 3) - tau, 3);
      double d1 = gsl_vector_get(knots, m + 3) - gsl_vector_get(knots, m);
      double d2 = gsl_vector_get(knots, m + 3) - gsl_vector_get(knots, m + 1);
      double d3 = gsl_vector_get(knots, m + 3) - gsl_vector_get(knots, m + 2);
      double d = d1 * d2 * d3;

      v = 1 - n / d;
    }

    gsl_vector_set(result, m + 1, v);
  }
}

void
qdm_ispline_matrix(
    gsl_matrix *result,
    const gsl_vector *taus,
    const size_t spline_df,
    const gsl_vector *knots
)
{
  for (size_t i = 0; i < result->size1; i++) {
    gsl_vector_view row = gsl_matrix_row(result, i);
    qdm_ispline_vector(&row.vector, gsl_vector_get(taus, i), spline_df, knots);
  }
}