#include <gsl/blas/cblas.h>

/**
	All the methods below are obtained directly from the ATLAS implementation of BLAS, available at: http://www.netlib.org/clapack/cblas/
*/

#include "f2c.h"

doublereal ddot(integer *n, doublereal *dx, integer *incx, doublereal *dy, integer *incy){

    /* System generated locals */
    integer i__1;
    doublereal ret_val;

    /* Local variables */
    static integer i, m;
    static doublereal dtemp;
    static integer ix, iy, mp1;

/*     forms the dot product of two vectors.
       uses unrolled loops for increments equal to one.
       jack dongarra, linpack, 3/11/78.
       modified 12/3/93, array(1) declarations changed to array(*)

   Parameter adjustments
       Function Body */
#define DY(I) dy[(I)-1]
#define DX(I) dx[(I)-1]

    ret_val = 0.;
    dtemp = 0.;
    if (*n <= 0) {
	return ret_val;
    }
    if (*incx == 1 && *incy == 1) {
	goto L20;
    }

/*        code for unequal increments or equal increments
            not equal to 1 */

    ix = 1;
    iy = 1;
    if (*incx < 0) {
	ix = (-(*n) + 1) * *incx + 1;
    }
    if (*incy < 0) {
	iy = (-(*n) + 1) * *incy + 1;
    }
    i__1 = *n;
    for (i = 1; i <= *n; ++i) {
	dtemp += DX(ix) * DY(iy);
	ix += *incx;
	iy += *incy;
/* L10: */
    }
    ret_val = dtemp;
    return ret_val;

/*        code for both increments equal to 1

          clean-up loop */

L20:
    m = *n % 5;
    if (m == 0) {
	goto L40;
    }
    i__1 = m;
    for (i = 1; i <= m; ++i) {
	dtemp += DX(i) * DY(i);
/* L30: */
    }
    if (*n < 5) {
	goto L60;
    }
L40:
    mp1 = m + 1;
    i__1 = *n;
    for (i = mp1; i <= *n; i += 5) {
	dtemp = dtemp + DX(i) * DY(i) + DX(i + 1) * DY(i + 1) + DX(i + 2) *
		DY(i + 2) + DX(i + 3) * DY(i + 3) + DX(i + 4) * DY(i + 4);
/* L50: */
    }
L60:
    ret_val = dtemp;
    return ret_val;
} /* ddot_ */

doublereal dnrm2(integer *n, doublereal *x, integer *incx)
{
    /* System generated locals */
    integer i__1, i__2;
    doublereal ret_val, d__1;

    /* Builtin functions */
    double sqrt(doublereal);

    /* Local variables */
    static doublereal norm, scale, absxi;
    static integer ix;
    static doublereal ssq;

/*  DNRM2 returns the euclidean norm of a vector via the function
    name, so that

       DNRM2 := sqrt( x'*x )

    -- This version written on 25-October-1982.
       Modified on 14-October-1993 to inline the call to DLASSQ.
       Sven Hammarling, Nag Ltd.

   Parameter adjustments
       Function Body */
#define X(I) x[(I)-1]

    if (*n < 1 || *incx < 1) {
	norm = 0.;
    } else if (*n == 1) {
	norm = abs(X(1));
    } else {
	scale = 0.;
	ssq = 1.;
/*        The following loop is equivalent to this call to the LAPACK

          auxiliary routine:
          CALL DLASSQ( N, X, INCX, SCALE, SSQ ) */

	i__1 = (*n - 1) * *incx + 1;
	i__2 = *incx;
	for (ix = 1; *incx < 0 ? ix >= (*n-1)**incx+1 : ix <= (*n-1)**incx+1; ix += *incx) {
	    if (X(ix) != 0.) {
		absxi = (d__1 = X(ix), abs(d__1));
		if (scale < absxi) {
/* Computing 2nd power */
		    d__1 = scale / absxi;
		    ssq = ssq * (d__1 * d__1) + 1.;
		    scale = absxi;
		} else {
/* Computing 2nd power */
		    d__1 = absxi / scale;
		    ssq += d__1 * d__1;
		}
	    }
/* L10: */
	}
	norm = scale * sqrt(ssq);
    }

    ret_val = norm;
    return ret_val;

/*     End of DNRM2. */

} /* dnrm2_ */

int dswap(integer *n, doublereal *dx, integer *incx, doublereal *dy, integer *incy)
{

    /* System generated locals */
    integer i__1;

    /* Local variables */
    static integer i, m;
    static doublereal dtemp;
    static integer ix, iy, mp1;

/*     interchanges two vectors.
       uses unrolled loops for increments equal one.
       jack dongarra, linpack, 3/11/78.
       modified 12/3/93, array(1) declarations changed to array(*)

   Parameter adjustments
       Function Body */
#define DY(I) dy[(I)-1]
#define DX(I) dx[(I)-1]

    if (*n <= 0) {
	return 0;
    }
    if (*incx == 1 && *incy == 1) {
	goto L20;
    }

/*       code for unequal increments or equal increments not equal
           to 1 */

    ix = 1;
    iy = 1;
    if (*incx < 0) {
	ix = (-(*n) + 1) * *incx + 1;
    }
    if (*incy < 0) {
	iy = (-(*n) + 1) * *incy + 1;
    }
    i__1 = *n;
    for (i = 1; i <= *n; ++i) {
	dtemp = DX(ix);
	DX(ix) = DY(iy);
	DY(iy) = dtemp;
	ix += *incx;
	iy += *incy;
/* L10: */
    }
    return 0;

/*       code for both increments equal to 1

         clean-up loop */

L20:
    m = *n % 3;
    if (m == 0) {
	goto L40;
    }
    i__1 = m;
    for (i = 1; i <= m; ++i) {
	dtemp = DX(i);
	DX(i) = DY(i);
	DY(i) = dtemp;
/* L30: */
    }
    if (*n < 3) {
	return 0;
    }
L40:
    mp1 = m + 1;
    i__1 = *n;
    for (i = mp1; i <= *n; i += 3) {
	dtemp = DX(i);
	DX(i) = DY(i);
	DY(i) = dtemp;
	dtemp = DX(i + 1);
	DX(i + 1) = DY(i + 1);
	DY(i + 1) = dtemp;
	dtemp = DX(i + 2);
	DX(i + 2) = DY(i + 2);
	DY(i + 2) = dtemp;
/* L50: */
    }
    return 0;
} /* dswap_ */

int dcopy(integer *n, doublereal *dx, integer *incx, doublereal *dy, integer *incy)
{

    /* System generated locals */
    integer i__1;

    /* Local variables */
    static integer i, m, ix, iy, mp1;

/*     copies a vector, x, to a vector, y.
       uses unrolled loops for increments equal to one.
       jack dongarra, linpack, 3/11/78.
       modified 12/3/93, array(1) declarations changed to array(*)

   Parameter adjustments
       Function Body */
#define DY(I) dy[(I)-1]
#define DX(I) dx[(I)-1]

    if (*n <= 0) {
	return 0;
    }
    if (*incx == 1 && *incy == 1) {
	goto L20;
    }

/*        code for unequal increments or equal increments
            not equal to 1 */

    ix = 1;
    iy = 1;
    if (*incx < 0) {
	ix = (-(*n) + 1) * *incx + 1;
    }
    if (*incy < 0) {
	iy = (-(*n) + 1) * *incy + 1;
    }
    i__1 = *n;
    for (i = 1; i <= *n; ++i) {
	DY(iy) = DX(ix);
	ix += *incx;
	iy += *incy;
/* L10: */
    }
    return 0;

/*        code for both increments equal to 1

          clean-up loop */

L20:
    m = *n % 7;
    if (m == 0) {
	goto L40;
    }
    i__1 = m;
    for (i = 1; i <= m; ++i) {
	DY(i) = DX(i);
/* L30: */
    }
    if (*n < 7) {
	return 0;
    }
L40:
    mp1 = m + 1;
    i__1 = *n;
    for (i = mp1; i <= *n; i += 7) {
	DY(i) = DX(i);
	DY(i + 1) = DX(i + 1);
	DY(i + 2) = DX(i + 2);
	DY(i + 3) = DX(i + 3);
	DY(i + 4) = DX(i + 4);
	DY(i + 5) = DX(i + 5);
	DY(i + 6) = DX(i + 6);
/* L50: */
    }
    return 0;
} /* dcopy_ */

int dgemm(char *transa, char *transb, integer *m, integer *	n, integer *k, doublereal *alpha, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *beta, doublereal *c, integer *ldc)
{

    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
	    i__3;

    /* Local variables */
    static integer info;
    static logical nota, notb;
    static doublereal temp;
    static integer i, j, l, ncola;
    extern logical lsame_(char *, char *);
    static integer nrowa, nrowb;
    extern /* Subroutine */ int xerbla_(char *, integer *);

/*  Purpose
    =======

    DGEMM  performs one of the matrix-matrix operations

       C := alpha*op( A )*op( B ) + beta*C,

    where  op( X ) is one of

       op( X ) = X   or   op( X ) = X',

    alpha and beta are scalars, and A, B and C are matrices, with op( A )

    an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.

    Parameters
    ==========

    TRANSA - CHARACTER*1.
             On entry, TRANSA specifies the form of op( A ) to be used in

             the matrix multiplication as follows:

                TRANSA = 'N' or 'n',  op( A ) = A.

                TRANSA = 'T' or 't',  op( A ) = A'.

                TRANSA = 'C' or 'c',  op( A ) = A'.

             Unchanged on exit.

    TRANSB - CHARACTER*1.
             On entry, TRANSB specifies the form of op( B ) to be used in

             the matrix multiplication as follows:

                TRANSB = 'N' or 'n',  op( B ) = B.

                TRANSB = 'T' or 't',  op( B ) = B'.

                TRANSB = 'C' or 'c',  op( B ) = B'.

             Unchanged on exit.

    M      - INTEGER.
             On entry,  M  specifies  the number  of rows  of the  matrix

             op( A )  and of the  matrix  C.  M  must  be at least  zero.

             Unchanged on exit.

    N      - INTEGER.
             On entry,  N  specifies the number  of columns of the matrix

             op( B ) and the number of columns of the matrix C. N must be

             at least zero.
             Unchanged on exit.

    K      - INTEGER.
             On entry,  K  specifies  the number of columns of the matrix

             op( A ) and the number of rows of the matrix op( B ). K must

             be at least  zero.
             Unchanged on exit.

    ALPHA  - DOUBLE PRECISION.
             On entry, ALPHA specifies the scalar alpha.
             Unchanged on exit.

    A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is

             k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
             Before entry with  TRANSA = 'N' or 'n',  the leading  m by k

             part of the array  A  must contain the matrix  A,  otherwise

             the leading  k by m  part of the array  A  must contain  the

             matrix A.
             Unchanged on exit.

    LDA    - INTEGER.
             On entry, LDA specifies the first dimension of A as declared

             in the calling (sub) program. When  TRANSA = 'N' or 'n' then

             LDA must be at least  max( 1, m ), otherwise  LDA must be at

             least  max( 1, k ).
             Unchanged on exit.

    B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is

             n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
             Before entry with  TRANSB = 'N' or 'n',  the leading  k by n

             part of the array  B  must contain the matrix  B,  otherwise

             the leading  n by k  part of the array  B  must contain  the

             matrix B.
             Unchanged on exit.

    LDB    - INTEGER.
             On entry, LDB specifies the first dimension of B as declared

             in the calling (sub) program. When  TRANSB = 'N' or 'n' then

             LDB must be at least  max( 1, k ), otherwise  LDB must be at

             least  max( 1, n ).
             Unchanged on exit.

    BETA   - DOUBLE PRECISION.
             On entry,  BETA  specifies the scalar  beta.  When  BETA  is

             supplied as zero then C need not be set on input.
             Unchanged on exit.

    C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
             Before entry, the leading  m by n  part of the array  C must

             contain the matrix  C,  except when  beta  is zero, in which

             case C need not be set on entry.
             On exit, the array  C  is overwritten by the  m by n  matrix

             ( alpha*op( A )*op( B ) + beta*C ).

    LDC    - INTEGER.
             On entry, LDC specifies the first dimension of C as declared

             in  the  calling  (sub)  program.   LDC  must  be  at  least

             max( 1, m ).
             Unchanged on exit.

    Level 3 Blas routine.

    -- Written on 8-February-1989.
       Jack Dongarra, Argonne National Laboratory.
       Iain Duff, AERE Harwell.
       Jeremy Du Croz, Numerical Algorithms Group Ltd.
       Sven Hammarling, Numerical Algorithms Group Ltd.

       Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not

       transposed and set  NROWA, NCOLA and  NROWB  as the number of rows

       and  columns of  A  and the  number of  rows  of  B  respectively.

   Parameter adjustments
       Function Body */

#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define C(I,J) c[(I)-1 + ((J)-1)* ( *ldc)]

    nota = lsame_(transa, "N");
    notb = lsame_(transb, "N");
    if (nota) {
	nrowa = *m;
	ncola = *k;
    } else {
	nrowa = *k;
	ncola = *m;
    }
    if (notb) {
	nrowb = *k;
    } else {
	nrowb = *n;
    }

/*     Test the input parameters. */

    info = 0;
    if (! nota && ! lsame_(transa, "C") && ! lsame_(transa, "T")) {
	info = 1;
    } else if (! notb && ! lsame_(transb, "C") && ! lsame_(transb,
	    "T")) {
	info = 2;
    } else if (*m < 0) {
	info = 3;
    } else if (*n < 0) {
	info = 4;
    } else if (*k < 0) {
	info = 5;
    } else if (*lda < max(1,nrowa)) {
	info = 8;
    } else if (*ldb < max(1,nrowb)) {
	info = 10;
    } else if (*ldc < max(1,*m)) {
	info = 13;
    }
    if (info != 0) {
	xerbla_("DGEMM ", &info);
	return 0;
    }

/*     Quick return if possible. */

    if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
	return 0;
    }

/*     And if  alpha.eq.zero. */

    if (*alpha == 0.) {
	if (*beta == 0.) {
	    i__1 = *n;
	    for (j = 1; j <= *n; ++j) {
		i__2 = *m;
		for (i = 1; i <= *m; ++i) {
		    C(i,j) = 0.;
/* L10: */
		}
/* L20: */
	    }
	} else {
	    i__1 = *n;
	    for (j = 1; j <= *n; ++j) {
		i__2 = *m;
		for (i = 1; i <= *m; ++i) {
		    C(i,j) = *beta * C(i,j);
/* L30: */
		}
/* L40: */
	    }
	}
	return 0;
    }

/*     Start the operations. */

    if (notb) {
	if (nota) {

/*           Form  C := alpha*A*B + beta*C. */

	    i__1 = *n;
	    for (j = 1; j <= *n; ++j) {
		if (*beta == 0.) {
		    i__2 = *m;
		    for (i = 1; i <= *m; ++i) {
			C(i,j) = 0.;
/* L50: */
		    }
		} else if (*beta != 1.) {
		    i__2 = *m;
		    for (i = 1; i <= *m; ++i) {
			C(i,j) = *beta * C(i,j);
/* L60: */
		    }
		}
		i__2 = *k;
		for (l = 1; l <= *k; ++l) {
		    if (B(l,j) != 0.) {
			temp = *alpha * B(l,j);
			i__3 = *m;
			for (i = 1; i <= *m; ++i) {
			    C(i,j) += temp * A(i,l);
/* L70: */
			}
		    }
/* L80: */
		}
/* L90: */
	    }
	} else {

/*           Form  C := alpha*A'*B + beta*C */

	    i__1 = *n;
	    for (j = 1; j <= *n; ++j) {
		i__2 = *m;
		for (i = 1; i <= *m; ++i) {
		    temp = 0.;
		    i__3 = *k;
		    for (l = 1; l <= *k; ++l) {
			temp += A(l,i) * B(l,j);
/* L100: */
		    }
		    if (*beta == 0.) {
			C(i,j) = *alpha * temp;
		    } else {
			C(i,j) = *alpha * temp + *beta * C(i,j);
		    }
/* L110: */
		}
/* L120: */
	    }
	}
    } else {
	if (nota) {

/*           Form  C := alpha*A*B' + beta*C */

	    i__1 = *n;
	    for (j = 1; j <= *n; ++j) {
		if (*beta == 0.) {
		    i__2 = *m;
		    for (i = 1; i <= *m; ++i) {
			C(i,j) = 0.;
/* L130: */
		    }
		} else if (*beta != 1.) {
		    i__2 = *m;
		    for (i = 1; i <= *m; ++i) {
			C(i,j) = *beta * C(i,j);
/* L140: */
		    }
		}
		i__2 = *k;
		for (l = 1; l <= *k; ++l) {
		    if (B(j,l) != 0.) {
			temp = *alpha * B(j,l);
			i__3 = *m;
			for (i = 1; i <= *m; ++i) {
			    C(i,j) += temp * A(i,l);
/* L150: */
			}
		    }
/* L160: */
		}
/* L170: */
	    }
	} else {

/*           Form  C := alpha*A'*B' + beta*C */

	    i__1 = *n;
	    for (j = 1; j <= *n; ++j) {
		i__2 = *m;
		for (i = 1; i <= *m; ++i) {
		    temp = 0.;
		    i__3 = *k;
		    for (l = 1; l <= *k; ++l) {
			temp += A(l,i) * B(j,l);
/* L180: */
		    }
		    if (*beta == 0.) {
			C(i,j) = *alpha * temp;
		    } else {
			C(i,j) = *alpha * temp + *beta * C(i,j);
		    }
/* L190: */
		}
/* L200: */
	    }
	}
    }

    return 0;

/*     End of DGEMM . */

} /* dgemm_ */

int dgemv(char *trans, integer *m, integer *n, doublereal *	alpha, doublereal *a, integer *lda, doublereal *x, integer *incx, doublereal *beta, doublereal *y, integer *incy)
{

    /* System generated locals */
    integer a_dim1, a_offset, i__1, i__2;

    /* Local variables */
    static integer info;
    static doublereal temp;
    static integer lenx, leny, i, j;
    extern logical lsame_(char *, char *);
    static integer ix, iy, jx, jy, kx, ky;
    extern /* Subroutine */ int xerbla_(char *, integer *);

/*  Purpose
    =======

    DGEMV  performs one of the matrix-vector operations

       y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y,

    where alpha and beta are scalars, x and y are vectors and A is an
    m by n matrix.

    Parameters
    ==========

    TRANS  - CHARACTER*1.
             On entry, TRANS specifies the operation to be performed as
             follows:

                TRANS = 'N' or 'n'   y := alpha*A*x + beta*y.

                TRANS = 'T' or 't'   y := alpha*A'*x + beta*y.

                TRANS = 'C' or 'c'   y := alpha*A'*x + beta*y.

             Unchanged on exit.

    M      - INTEGER.
             On entry, M specifies the number of rows of the matrix A.
             M must be at least zero.
             Unchanged on exit.

    N      - INTEGER.
             On entry, N specifies the number of columns of the matrix A.

             N must be at least zero.
             Unchanged on exit.

    ALPHA  - DOUBLE PRECISION.
             On entry, ALPHA specifies the scalar alpha.
             Unchanged on exit.

    A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
             Before entry, the leading m by n part of the array A must
             contain the matrix of coefficients.
             Unchanged on exit.

    LDA    - INTEGER.
             On entry, LDA specifies the first dimension of A as declared

             in the calling (sub) program. LDA must be at least
             max( 1, m ).
             Unchanged on exit.

    X      - DOUBLE PRECISION array of DIMENSION at least
             ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
             and at least
             ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
             Before entry, the incremented array X must contain the
             vector x.
             Unchanged on exit.

    INCX   - INTEGER.
             On entry, INCX specifies the increment for the elements of
             X. INCX must not be zero.
             Unchanged on exit.

    BETA   - DOUBLE PRECISION.
             On entry, BETA specifies the scalar beta. When BETA is
             supplied as zero then Y need not be set on input.
             Unchanged on exit.

    Y      - DOUBLE PRECISION array of DIMENSION at least
             ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
             and at least
             ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
             Before entry with BETA non-zero, the incremented array Y
             must contain the vector y. On exit, Y is overwritten by the

             updated vector y.

    INCY   - INTEGER.
             On entry, INCY specifies the increment for the elements of
             Y. INCY must not be zero.
             Unchanged on exit.

    Level 2 Blas routine.

    -- Written on 22-October-1986.
       Jack Dongarra, Argonne National Lab.
       Jeremy Du Croz, Nag Central Office.
       Sven Hammarling, Nag Central Office.
       Richard Hanson, Sandia National Labs.

       Test the input parameters.

   Parameter adjustments
       Function Body */
#define X(I) x[(I)-1]
#define Y(I) y[(I)-1]

#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]

    info = 0;
    if (! lsame_(trans, "N") && ! lsame_(trans, "T") && !
	    lsame_(trans, "C")) {
	info = 1;
    } else if (*m < 0) {
	info = 2;
    } else if (*n < 0) {
	info = 3;
    } else if (*lda < max(1,*m)) {
	info = 6;
    } else if (*incx == 0) {
	info = 8;
    } else if (*incy == 0) {
	info = 11;
    }
    if (info != 0) {
	xerbla_("DGEMV ", &info);
	return 0;
    }

/*     Quick return if possible. */

    if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
	return 0;
    }

/*     Set  LENX  and  LENY, the lengths of the vectors x and y, and set

       up the start points in  X  and  Y. */

    if (lsame_(trans, "N")) {
	lenx = *n;
	leny = *m;
    } else {
	lenx = *m;
	leny = *n;
    }
    if (*incx > 0) {
	kx = 1;
    } else {
	kx = 1 - (lenx - 1) * *incx;
    }
    if (*incy > 0) {
	ky = 1;
    } else {
	ky = 1 - (leny - 1) * *incy;
    }

/*     Start the operations. In this version the elements of A are
       accessed sequentially with one pass through A.

       First form  y := beta*y. */

    if (*beta != 1.) {
	if (*incy == 1) {
	    if (*beta == 0.) {
		i__1 = leny;
		for (i = 1; i <= leny; ++i) {
		    Y(i) = 0.;
/* L10: */
		}
	    } else {
		i__1 = leny;
		for (i = 1; i <= leny; ++i) {
		    Y(i) = *beta * Y(i);
/* L20: */
		}
	    }
	} else {
	    iy = ky;
	    if (*beta == 0.) {
		i__1 = leny;
		for (i = 1; i <= leny; ++i) {
		    Y(iy) = 0.;
		    iy += *incy;
/* L30: */
		}
	    } else {
		i__1 = leny;
		for (i = 1; i <= leny; ++i) {
		    Y(iy) = *beta * Y(iy);
		    iy += *incy;
/* L40: */
		}
	    }
	}
    }
    if (*alpha == 0.) {
	return 0;
    }
    if (lsame_(trans, "N")) {

/*        Form  y := alpha*A*x + y. */

	jx = kx;
	if (*incy == 1) {
	    i__1 = *n;
	    for (j = 1; j <= *n; ++j) {
		if (X(jx) != 0.) {
		    temp = *alpha * X(jx);
		    i__2 = *m;
		    for (i = 1; i <= *m; ++i) {
			Y(i) += temp * A(i,j);
/* L50: */
		    }
		}
		jx += *incx;
/* L60: */
	    }
	} else {
	    i__1 = *n;
	    for (j = 1; j <= *n; ++j) {
		if (X(jx) != 0.) {
		    temp = *alpha * X(jx);
		    iy = ky;
		    i__2 = *m;
		    for (i = 1; i <= *m; ++i) {
			Y(iy) += temp * A(i,j);
			iy += *incy;
/* L70: */
		    }
		}
		jx += *incx;
/* L80: */
	    }
	}
    } else {

/*        Form  y := alpha*A'*x + y. */

	jy = ky;
	if (*incx == 1) {
	    i__1 = *n;
	    for (j = 1; j <= *n; ++j) {
		temp = 0.;
		i__2 = *m;
		for (i = 1; i <= *m; ++i) {
		    temp += A(i,j) * X(i);
/* L90: */
		}
		Y(jy) += *alpha * temp;
		jy += *incy;
/* L100: */
	    }
	} else {
	    i__1 = *n;
	    for (j = 1; j <= *n; ++j) {
		temp = 0.;
		ix = kx;
		i__2 = *m;
		for (i = 1; i <= *m; ++i) {
		    temp += A(i,j) * X(ix);
		    ix += *incx;
/* L110: */
		}
		Y(jy) += *alpha * temp;
		jy += *incy;
/* L120: */
	    }
	}
    }

    return 0;

/*     End of DGEMV . */

} /* dgemv_ */

logical lsame_(char *ca, char *cb)
{

    /* System generated locals */
    logical ret_val;

    /* Local variables */
    static integer inta, intb, zcode;

/*  -- LAPACK auxiliary routine (version 2.0) --
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
       Courant Institute, Argonne National Lab, and Rice University
       January 31, 1994

    Purpose
    =======

    LSAME returns .TRUE. if CA is the same letter as CB regardless of
    case.

    Arguments
    =========

    CA      (input) CHARACTER*1
    CB      (input) CHARACTER*1
            CA and CB specify the single characters to be compared.

   =====================================================================

       Test if the characters are equal */

    ret_val = *(unsigned char *)ca == *(unsigned char *)cb;
    if (ret_val) {
	return ret_val;
    }

/*     Now test for equivalence if both characters are alphabetic. */

    zcode = 'Z';

/*     Use 'Z' rather than 'A' so that ASCII can be detected on Prime
       machines, on which ICHAR returns a value with bit 8 set.
       ICHAR('A') on Prime machines returns 193 which is the same as
       ICHAR('A') on an EBCDIC machine. */

    inta = *(unsigned char *)ca;
    intb = *(unsigned char *)cb;

    if (zcode == 90 || zcode == 122) {

/*        ASCII is assumed - ZCODE is the ASCII code of either lower o
r
          upper case 'Z'. */

	if (inta >= 97 && inta <= 122) {
	    inta += -32;
	}
	if (intb >= 97 && intb <= 122) {
	    intb += -32;
	}

    } else if (zcode == 233 || zcode == 169) {

/*        EBCDIC is assumed - ZCODE is the EBCDIC code of either lower
 or
          upper case 'Z'. */

	if (inta >= 129 && inta <= 137 || inta >= 145 && inta <= 153 || inta
		>= 162 && inta <= 169) {
	    inta += 64;
	}
	if (intb >= 129 && intb <= 137 || intb >= 145 && intb <= 153 || intb
		>= 162 && intb <= 169) {
	    intb += 64;
	}

    } else if (zcode == 218 || zcode == 250) {

/*        ASCII is assumed, on Prime machines - ZCODE is the ASCII cod
e
          plus 128 of either lower or upper case 'Z'. */

	if (inta >= 225 && inta <= 250) {
	    inta += -32;
	}
	if (intb >= 225 && intb <= 250) {
	    intb += -32;
	}
    }
    ret_val = inta == intb;

/*     RETURN

       End of LSAME */

    return ret_val;
} /* lsame_ */
int xerbla_(char *srname, integer *info)
{
/*  -- LAPACK auxiliary routine (version 2.0) --
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
       Courant Institute, Argonne National Lab, and Rice University
       September 30, 1994

    Purpose
    =======

    XERBLA  is an error handler for the LAPACK routines.
    It is called by an LAPACK routine if an input parameter has an
    invalid value.  A message is printed and execution stops.

    Installers may consider modifying the STOP statement in order to
    call system-specific exception-handling facilities.

    Arguments
    =========

    SRNAME  (input) CHARACTER*6
            The name of the routine which called XERBLA.

    INFO    (input) INTEGER
            The position of the invalid parameter in the parameter list

            of the calling routine.

   =====================================================================
*/

    printf("** On entry to %6s, parameter number %2i had an illegal value\n",
		srname, *info);

/*     End of XERBLA */

    return 0;
} /* xerbla_ */


#ifndef CHEVALIER_H
#define CHEVALIER_H

#include <math.h>
#include <gsl/gsl_roots.h>
#include <gsl/gsl_multiroots.h>

#define parsec_in_cm 3.085678e+18 //parsec in cm
#define parsec_in_km 3.085678e+13 //parsec in km
#define msun_in_g    1.988920e+33 //msun in g
#define year_in_sec  3.155760e+07 //year in s

typedef struct Chevalier
{
    double M_dot;               //mass input rate
    double E_dot;               //energy input rate
    double R;                   //limit of mass and energy input
    double gamma;               //adiabatic index
    double V;                   //Volume of input area
    double q;                   //M_dot / V
    double Q;                   //E_dot / V
    gsl_root_fsolver *grsolve;  //GSL root solver
} Chevalier;

// Function declarations for Chevalier struct
void SetChevalier(Chevalier *c, double M_dot, double E_dot, double gamma, double R);
double MachNumber(Chevalier *c, double r);      //mach number vs. radius
double MomentumDensity(Chevalier *c, double r); //momentum density vs. radius in Msun/pc^3 * km/s
double Pressure(Chevalier *c, double r);        //Pressure in dyn cm^-2
double Density(Chevalier *c, double r);         //density in g cm^-3
double Density_Msunpc3(Chevalier *c, double r); //density in Msun/pc3
double WindVelocity(Chevalier *c, double r);    //wind velocity in km/s
double EnergyIntegral(Chevalier *c, double r);  //msun/yr (km/s)^2 / pc^3
double u_star(Chevalier *c, double r);          //normalized wind velocity
double rho_star(Chevalier *c, double r);        //normalized density
double P_star(Chevalier *c, double r);          //normalized pressure

double mach_crossing_A(double M, void *fp);     //functions for Mach number root finding
double mach_crossing_B(double M, void *fp);

// Function definitions
void SetChevalier(Chevalier *c, double M_dot, double E_dot, double gamma, double R) {
    // M_dot = Mass input in Msun/yr
    // E_dot = Energy input in erg / s
    // gamma = Adiabatic index
    // R     = Radius of the wind region in parsec

    //Set model parameters
    c->M_dot = M_dot;
    c->E_dot = E_dot;
    c->gamma = gamma;
    c->R     = R;
    c->V     = (4.*M_PI/3. * R*R*R); //volume in pc^3
    //compute input density rate (msun / yr / pc^3)
    c->q     = c->M_dot / c->V;
    //compute input energy density rate (msun/yr (km/s)^2 / pc^3)
    c->Q     = (c->E_dot/msun_in_g*year_in_sec / 1.0e10) / c->V;
    //define the GSL root solver to use
    const gsl_root_fsolver_type *grsolve_T = gsl_root_fsolver_brent;
    c->grsolve = gsl_root_fsolver_alloc(grsolve_T);
}

double u_star(Chevalier *c, double r) {
    // Returns dimensionless wind velocity
    double u = WindVelocity(c, r);
    double u_prime = sqrt(c->E_dot)/sqrt(c->M_dot*msun_in_g/year_in_sec)/1.0e5;
    return u/u_prime;
}

double rho_star(Chevalier *c, double r) {
    // Returns dimensionless density
    double rho = Density(c,r); //g cm^-3
    double M_dot_prime = c->M_dot * msun_in_g/year_in_sec; // g/s
    double R_prime = c->R * parsec_in_cm; //cm
    double rho_prime = pow(M_dot_prime,1.5)/(sqrt(c->E_dot)*R_prime*R_prime);
    return rho/rho_prime;
}

double P_star(Chevalier *c, double r) {
    // Returns dimensionless pressure
    double P = Pressure(c,r); //dyn cm^-2
    double M_dot_prime = c->M_dot * msun_in_g/year_in_sec; // g/s
    double R_prime = c->R * parsec_in_cm; //cm
    double P_prime = sqrt(M_dot_prime)*sqrt(c->E_dot)/(R_prime*R_prime);
    return P/P_prime;
}

double Pressure(Chevalier *c, double r) {
    // Returns pressure in dyn cm^-2
    double Mach = MachNumber(c,r);          //mach number
    double u    = WindVelocity(c,r);        //km/s
    double cs   = u/Mach * 1.0e5;           //sound speed in cm/s
    u *= year_in_sec / parsec_in_km;        //to pc/yr
    double rho  = MomentumDensity(c,r)/u;   //Msun / pc^3
    rho *= msun_in_g;                       //g / pc^3
    rho /= pow(parsec_in_cm, 3);            //g / cm^3
    double P = cs*cs*rho/c->gamma;          //pressure in cgs
    return P;                               //in dyn cm^-2
}

double Density(Chevalier *c, double r) {
    // Returns density in g cm^-3
    double rho = Density_Msunpc3(c, r);     //Msun/pc^3
    rho *= msun_in_g;                       //g / pc^3
    rho /= pow(parsec_in_cm, 3);            //g / cm^3
    return rho;                             // in g/cm^3
}

double Density_Msunpc3(Chevalier *c, double r) {
    // Returns density in g cm^-3
    double u = WindVelocity(c, r);          //km/s
    u *= year_in_sec / parsec_in_km;        //to pc/yr
    return MomentumDensity(c,r)/u;          //Msun/pc^3;
}

double WindVelocity(Chevalier *c, double r) {
    // Returns wind velocity in km/s

    //First, find integrated energy input density
    double Qint = EnergyIntegral(c, r);     //msun/yr (km/s)^2 / pc^3
    //Second, find momentum density
    double rhou = MomentumDensity(c, r);     //msun/yr/pc^2
    //find sq of velocity (modulo gamma + Mach correction)
    double usq = Qint/rhou;                 //1/2 u^2 + (gamma/(gamma-1))*P/rho
                                            //1/2 u^2 + c^2 / (gamma-1)
                                            //1/2 u^2 + u^2 / (M^2 (gamma-1))
                                            //u^2 * ( 1/2 + 1/(M^2 (gamma-1)) )
    //get the mach number
    double Mach = MachNumber(c,r);
    //find the adjustment factor
    double fac = (0.5 + 1./(Mach*Mach*(c->gamma-1.)));
    return sqrt(usq/fac);	//km/s
}

double EnergyIntegral(Chevalier *c, double r) {
    double Qint = r<c->R ? 1./3.*c->Q*r : 1./3.*c->Q*c->R*c->R*c->R/(r*r);
    return Qint;    //msun/yr (km/s)^2 / pc^3
}

double MomentumDensity(Chevalier *c, double r) {
    double rhou = r<c->R ? 1./3.*c->q*r : 1./3.*c->q*c->R*c->R*c->R/(r*r) ;
    return rhou;    // in Msun/yr/pc^2
}

double MachNumber(Chevalier *c, double r) {

    int    status, iter=0, max_iter=100;
    double M_lo = 1.0e-5, M_hi = 5.;
    double Mx, answer = 0;
    double x = r/c->R;
    gsl_function func;
    double fp[2] = {c->gamma, x};

    //choose which solution to use
    if(x<=1.0) {
        M_lo = 1.0e-5;
        M_hi = 1.0;
        func.function = &mach_crossing_A;
    }
    else {
        M_lo = 1.0;
        M_hi = 10000.0;
        func.function = &mach_crossing_B;
    }
    func.params   = &fp[0];

    gsl_root_fsolver_set(c->grsolve, &func, M_lo, M_hi);

    while(++iter<max_iter){
        status = gsl_root_fsolver_iterate(c->grsolve);
        Mx = gsl_root_fsolver_root(c->grsolve);
        M_lo = gsl_root_fsolver_x_lower(c->grsolve);
        M_hi = gsl_root_fsolver_x_upper(c->grsolve);
        status = gsl_root_test_interval(M_lo,M_hi,0,1.0e-5);
        if(status==GSL_SUCCESS) {answer = Mx; break;}
    }

    return answer;
}

double mach_crossing_A(double M, void *fp) {
    double *g     = (double *) fp;
    double gamma  = g[0];
    double x      = g[1];
    double alpha  = -1.*(3.*gamma+1.)/(5.*gamma+1.);
    double beta   = (gamma+1.)/(2.*(5.*gamma+1.));
    double A      = pow( (3.*gamma + 1./(M*M))/(1.+3.*gamma), alpha);
    double B      = pow( (gamma-1.+2./(M*M))/(1.+gamma), beta);
    return A*B - x;
}

double mach_crossing_B(double M, void *fp) {
    double *g     = (double *) fp;
    double gamma = g[0];
    double x     = g[1];
    double alpha = 2./(gamma-1.);
    double beta  = (gamma+1.)/(2.*(gamma-1.));
    double A     = pow( M, alpha);
    double B     = pow( (gamma-1.+2./(M*M))/(1.+gamma), beta);
    return A*B - x*x;
}

#endif //CHEVALIER_H


#ifndef __DESIGN_H
#define __DESIGN_H

#include <gsl/gsl_matrix.h>

//function prototypes
double distance(double *x,double *y,int D,double p);
double cost(gsl_matrix *data,int Npoints,int D,double p,double lambda);
double diagonalCost(int Npoints,double lambda);
double swap(gsl_matrix *data,int Npoints,int D,double p,double lambda,int i1,int i2, int d);
void swapBack(gsl_matrix *data,int i1,int i2,int d);

//main design sampler prototype
double sample(int Npoints,int D,double p,double lambda,int seed,int maxIterations,gsl_matrix *data,double *costValues);

#endif


/* multirobust.c
 *
 * Copyright (C) 2013 Patrick Alken
 *
 * 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.
 *
 * This module contains routines related to robust linear least squares. The
 * algorithm used closely follows the publications:
 *
 * [1] DuMouchel, W. and F. O'Brien (1989), "Integrating a robust
 * option into a multiple regression computing environment,"
 * Computer Science and Statistics:  Proceedings of the 21st
 * Symposium on the Interface, American Statistical Association
 *
 * [2] Street, J.O., R.J. Carroll, and D. Ruppert (1988), "A note on
 * computing robust regression estimates via iteratively
 * reweighted least squares," The American Statistician, v. 42,
 * pp. 152-154.
 */

//#include <config.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_multifit.h>
#include <gsl/gsl_vector.h>
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_statistics.h>
#include <gsl/gsl_sort.h>
#include <gsl/gsl_sort_vector.h>
#include <gsl/gsl_blas.h>
#include <gsl/gsl_linalg.h>

#include "linear_common.c"

static int robust_test_convergence(const gsl_vector *c_prev, const gsl_vector *c,
                                   const double tol);
static double robust_madsigma(const gsl_vector *x, gsl_multifit_robust_workspace *w);
static double robust_robsigma(const gsl_vector *r, const double s,
                              const double tune, gsl_multifit_robust_workspace *w);
static double robust_sigma(const double s_ols, const double s_rob,
                           gsl_multifit_robust_workspace *w);
static int robust_covariance(const double sigma, gsl_matrix *cov,
                             gsl_multifit_robust_workspace *w);

/*
gsl_multifit_robust_alloc
  Allocate a robust workspace

Inputs: T - robust weighting algorithm
        n - number of observations
        p - number of model parameters

Return: pointer to workspace
*/

gsl_multifit_robust_workspace *
gsl_multifit_robust_alloc(const gsl_multifit_robust_type *T,
                          const size_t n, const size_t p)
{
  gsl_multifit_robust_workspace *w;

  if (n < p)
    {
      GSL_ERROR_VAL("observations n must be >= p", GSL_EINVAL, 0);
    }

  w = calloc(1, sizeof(gsl_multifit_robust_workspace));
  if (w == 0)
    {
      GSL_ERROR_VAL("failed to allocate space for multifit_robust struct",
                    GSL_ENOMEM, 0);
    }

  w->n = n;
  w->p = p;
  w->type = T;
  /* bdavis */
  //w->maxiter = 100; /* maximum iterations */
  w->maxiter = 5; /* maximum iterations */
  /* bdavis */
  w->tune = w->type->tuning_default;

  w->multifit_p = gsl_multifit_linear_alloc(n, p);
  if (w->multifit_p == 0)
    {
      GSL_ERROR_VAL("failed to allocate space for multifit_linear struct",
                    GSL_ENOMEM, 0);
    }

  w->r = gsl_vector_alloc(n);
  if (w->r == 0)
    {
      GSL_ERROR_VAL("failed to allocate space for residuals",
                    GSL_ENOMEM, 0);
    }

  w->weights = gsl_vector_alloc(n);
  if (w->weights == 0)
    {
      GSL_ERROR_VAL("failed to allocate space for weights", GSL_ENOMEM, 0);
    }

  w->c_prev = gsl_vector_alloc(p);
  if (w->c_prev == 0)
    {
      GSL_ERROR_VAL("failed to allocate space for c_prev", GSL_ENOMEM, 0);
    }

  w->resfac = gsl_vector_alloc(n);
  if (w->resfac == 0)
    {
      GSL_ERROR_VAL("failed to allocate space for residual factors",
                    GSL_ENOMEM, 0);
    }

  w->psi = gsl_vector_alloc(n);
  if (w->psi == 0)
    {
      GSL_ERROR_VAL("failed to allocate space for psi", GSL_ENOMEM, 0);
    }

  w->dpsi = gsl_vector_alloc(n);
  if (w->dpsi == 0)
    {
      GSL_ERROR_VAL("failed to allocate space for dpsi", GSL_ENOMEM, 0);
    }

  w->QSI = gsl_matrix_alloc(p, p);
  if (w->QSI == 0)
    {
      GSL_ERROR_VAL("failed to allocate space for QSI", GSL_ENOMEM, 0);
    }

  w->D = gsl_vector_alloc(p);
  if (w->D == 0)
    {
      GSL_ERROR_VAL("failed to allocate space for D", GSL_ENOMEM, 0);
    }

  w->workn = gsl_vector_alloc(n);
  if (w->workn == 0)
    {
      GSL_ERROR_VAL("failed to allocate space for workn", GSL_ENOMEM, 0);
    }

  w->stats.sigma_ols = 0.0;
  w->stats.sigma_mad = 0.0;
  w->stats.sigma_rob = 0.0;
  w->stats.sigma = 0.0;
  w->stats.Rsq = 0.0;
  w->stats.adj_Rsq = 0.0;
  w->stats.rmse = 0.0;
  w->stats.sse = 0.0;
  w->stats.dof = n - p;
  w->stats.weights = w->weights;
  w->stats.r = w->r;

  return w;
} /* gsl_multifit_robust_alloc() */

/*
gsl_multifit_robust_free()
  Free memory associated with robust workspace
*/

void
gsl_multifit_robust_free(gsl_multifit_robust_workspace *w)
{
  if (w->multifit_p)
    gsl_multifit_linear_free(w->multifit_p);

  if (w->r)
    gsl_vector_free(w->r);

  if (w->weights)
    gsl_vector_free(w->weights);

  if (w->c_prev)
    gsl_vector_free(w->c_prev);

  if (w->resfac)
    gsl_vector_free(w->resfac);

  if (w->psi)
    gsl_vector_free(w->psi);

  if (w->dpsi)
    gsl_vector_free(w->dpsi);

  if (w->QSI)
    gsl_matrix_free(w->QSI);

  if (w->D)
    gsl_vector_free(w->D);

  if (w->workn)
    gsl_vector_free(w->workn);

  free(w);
} /* gsl_multifit_robust_free() */

int
gsl_multifit_robust_tune(const double tune, gsl_multifit_robust_workspace *w)
{
  w->tune = tune;
  return GSL_SUCCESS;
}

const char *
gsl_multifit_robust_name(const gsl_multifit_robust_workspace *w)
{
  return w->type->name;
}

gsl_multifit_robust_stats
gsl_multifit_robust_statistics(const gsl_multifit_robust_workspace *w)
{
  return w->stats;
}

/*
gsl_multifit_robust()
  Perform robust iteratively reweighted linear least squares
fit

Inputs: X     - design matrix of basis functions
        y     - right hand side vector
        c     - (output) model coefficients
        cov   - (output) covariance matrix
        w     - workspace
*/

int
gsl_multifit_robust(const gsl_matrix * X,
                    const gsl_vector * y,
                    gsl_vector * c,
                    gsl_matrix * cov,
                    gsl_multifit_robust_workspace *w)
{
  /* check matrix and vector sizes */
  if (X->size1 != y->size)
    {
      GSL_ERROR
        ("number of observations in y does not match rows of matrix X",
         GSL_EBADLEN);
    }
  else if (X->size2 != c->size)
    {
      GSL_ERROR ("number of parameters c does not match columns of matrix X",
                 GSL_EBADLEN);
    }
  else if (cov->size1 != cov->size2)
    {
      GSL_ERROR ("covariance matrix is not square", GSL_ENOTSQR);
    }
  else if (c->size != cov->size1)
    {
      GSL_ERROR
        ("number of parameters does not match size of covariance matrix",
         GSL_EBADLEN);
    }
  else if (X->size1 != w->n || X->size2 != w->p)
    {
      GSL_ERROR
        ("size of workspace does not match size of observation matrix",
         GSL_EBADLEN);
    }
  else
    {
      int s;
      double chisq;
      const double tol = GSL_SQRT_DBL_EPSILON;
      int converged = 0;
      size_t numit = 0;
      const size_t n = y->size;
      double sigy = gsl_stats_sd(y->data, y->stride, n);
      double sig_lower;
      size_t i;

      /*
       * if the initial fit is very good, then finding outliers by comparing
       * them to the residual standard deviation is difficult. Therefore we
       * set a lower bound on the standard deviation estimate that is a small
       * fraction of the standard deviation of the data values
       */
      sig_lower = 1.0e-6 * sigy;
      if (sig_lower == 0.0)
        sig_lower = 1.0;

      /* compute initial estimates using ordinary least squares */
      s = gsl_multifit_linear(X, y, c, cov, &chisq, w->multifit_p);
      if (s)
        return s;

      /* save Q S^{-1} of original matrix */
      gsl_matrix_memcpy(w->QSI, w->multifit_p->QSI);
      gsl_vector_memcpy(w->D, w->multifit_p->D);

      /* compute statistical leverage of each data point */
      s = gsl_linalg_SV_leverage(w->multifit_p->A, w->resfac);
      if (s)
        return s;

      /* correct residuals with factor 1 / sqrt(1 - h) */
      for (i = 0; i < n; ++i)
        {
          double h = gsl_vector_get(w->resfac, i);

          if (h > 0.9999)
            h = 0.9999;

          gsl_vector_set(w->resfac, i, 1.0 / sqrt(1.0 - h));
        }

      /* compute residuals from OLS fit r = y - X c */
      s = gsl_multifit_linear_residuals(X, y, c, w->r);
      if (s)
        return s;

      /* compute estimate of sigma from ordinary least squares */
      w->stats.sigma_ols = gsl_blas_dnrm2(w->r) / sqrt((double) w->stats.dof);

      while (!converged && ++numit <= w->maxiter)
        {
          double sig;

          /* adjust residuals by statistical leverage (see DuMouchel and O'Brien) */
          s = gsl_vector_mul(w->r, w->resfac);
          if (s)
            return s;

          /* compute estimate of standard deviation using MAD */
          sig = robust_madsigma(w->r, w);

          /* scale residuals by standard deviation and tuning parameter */
          gsl_vector_scale(w->r, 1.0 / (GSL_MAX(sig, sig_lower) * w->tune));

          /* compute weights using these residuals */
          s = w->type->wfun(w->r, w->weights);
          if (s)
            return s;

          gsl_vector_memcpy(w->c_prev, c);

          /* solve weighted least squares with new weights */
          s = gsl_multifit_wlinear(X, w->weights, y, c, cov, &chisq, w->multifit_p);
          if (s)
            return s;

          /* compute new residuals r = y - X c */
          s = gsl_multifit_linear_residuals(X, y, c, w->r);
          if (s)
            return s;

          converged = robust_test_convergence(w->c_prev, c, tol);
        }

      /* compute final MAD sigma */
      w->stats.sigma_mad = robust_madsigma(w->r, w);

      /* compute robust estimate of sigma */
      w->stats.sigma_rob = robust_robsigma(w->r, w->stats.sigma_mad, w->tune, w);

      /* compute final estimate of sigma */
      w->stats.sigma = robust_sigma(w->stats.sigma_ols, w->stats.sigma_rob, w);

      /* store number of iterations */
      w->stats.numit = numit;

      {
        double dof = (double) w->stats.dof;
        double rnorm = w->stats.sigma * sqrt(dof); /* see DuMouchel, sec 4.2 */
        double ss_err = rnorm * rnorm;
        double ss_tot = gsl_stats_tss(y->data, y->stride, n);

        /* compute R^2 */
        w->stats.Rsq = 1.0 - ss_err / ss_tot;

        /* compute adjusted R^2 */
        w->stats.adj_Rsq = 1.0 - (1.0 - w->stats.Rsq) * (n - 1.0) / dof;

        /* compute rmse */
        w->stats.rmse = sqrt(ss_err / dof);

        /* store SSE */
        w->stats.sse = ss_err;
      }

      /* calculate covariance matrix = sigma^2 (X^T X)^{-1} */
      s = robust_covariance(w->stats.sigma, cov, w);
      if (s)
        return s;

      /* raise an error if not converged */
/* bdavis */
      /* Eliminating this check is to avoid an error when iterations */
      /* exceed 5.  A better solution is probably recommended, such as */
      /* reverting to default of 100 if an input specification is not */
      /* enabled and defined. */
      /* bdavis@usgs.gov */
      /*
      if (numit > w->maxiter)
        {
          GSL_ERROR("maximum iterations exceeded", GSL_EMAXITER);
        }
      */
/* bdavis */

      return s;
    }
} /* gsl_multifit_robust() */

/* Estimation of values for given x */
int
gsl_multifit_robust_est(const gsl_vector * x, const gsl_vector * c,
                        const gsl_matrix * cov, double *y, double *y_err)
{
  int s = gsl_multifit_linear_est(x, c, cov, y, y_err);

  return s;
}

/***********************************
 * INTERNAL ROUTINES               *
 ***********************************/

/*
robust_test_convergence()
  Test for convergence in robust least squares

Convergence criteria:

|c_i^(k) - c_i^(k-1)| <= tol * max(|c_i^(k)|, |c_i^(k-1)|)

for all i. k refers to iteration number.

Inputs: c_prev - coefficients from previous iteration
        c      - coefficients from current iteration
        tol    - tolerance

Return: 1 if converged, 0 if not
*/

static int
robust_test_convergence(const gsl_vector *c_prev, const gsl_vector *c,
                        const double tol)
{
  size_t p = c->size;
  size_t i;

  for (i = 0; i < p; ++i)
    {
      double ai = gsl_vector_get(c_prev, i);
      double bi = gsl_vector_get(c, i);

      if (fabs(bi - ai) > tol * GSL_MAX(fabs(ai), fabs(bi)))
        return 0; /* not yet converged */
    }

  /* converged */
  return 1;
} /* robust_test_convergence() */

/*
robust_madsigma()
  Estimate the standard deviation of the residuals using
the Median-Absolute-Deviation (MAD) of the residuals,
throwing away the smallest p residuals.

See: Street et al, 1988

Inputs: r - vector of residuals
        w - workspace
*/

static double
robust_madsigma(const gsl_vector *r, gsl_multifit_robust_workspace *w)
{
  gsl_vector_view v;
  double sigma;
  size_t n = r->size;
  const size_t p = w->p;
  size_t i;

  /* copy |r| into workn */
  for (i = 0; i < n; ++i)
    {
      gsl_vector_set(w->workn, i, fabs(gsl_vector_get(r, i)));
    }

  gsl_sort_vector(w->workn);

  /*
   * ignore the smallest p residuals when computing the median
   * (see Street et al 1988)
   */
  v = gsl_vector_subvector(w->workn, p - 1, n - p + 1);
  sigma = gsl_stats_median_from_sorted_data(v.vector.data, v.vector.stride, v.vector.size) / 0.6745;

  return sigma;
} /* robust_madsigma() */

/*
robust_robsigma()
  Compute robust estimate of sigma so that
sigma^2 * inv(X' * X) is a reasonable estimate of
the covariance for robust regression. Based heavily
on the equations of Street et al, 1988.

Inputs: r    - vector of residuals y - X c
        s    - sigma estimate using MAD
        tune - tuning constant
        w    - workspace
*/

static double
robust_robsigma(const gsl_vector *r, const double s,
                const double tune, gsl_multifit_robust_workspace *w)
{
  double sigma;
  size_t i;
  const size_t n = w->n;
  const size_t p = w->p;
  const double st = s * tune;
  double a, b, lambda;

  /* compute u = r / sqrt(1 - h) / st */
  gsl_vector_memcpy(w->workn, r);
  gsl_vector_mul(w->workn, w->resfac);
  gsl_vector_scale(w->workn, 1.0 / st);

  /* compute w(u) and psi'(u) */
  w->type->wfun(w->workn, w->psi);
  w->type->psi_deriv(w->workn, w->dpsi);

  /* compute psi(u) = u*w(u) */
  gsl_vector_mul(w->psi, w->workn);

  /* Street et al, Eq (3) */
  a = gsl_stats_mean(w->dpsi->data, w->dpsi->stride, n);

  /* Street et al, Eq (5) */
  b = 0.0;
  for (i = 0; i < n; ++i)
    {
      double psi_i = gsl_vector_get(w->psi, i);
      double resfac = gsl_vector_get(w->resfac, i);
      double fac = 1.0 / (resfac*resfac); /* 1 - h */

      b += fac * psi_i * psi_i;
    }
  b /= (double) (n - p);

  /* Street et al, Eq (5) */
  lambda = 1.0 + ((double)p)/((double)n) * (1.0 - a) / a;

  sigma = lambda * sqrt(b) * st / a;

  return sigma;
} /* robust_robsigma() */

/*
robust_sigma()
  Compute final estimate of residual standard deviation, using
the OLS and robust sigma estimates.

This equation is taken from DuMouchel and O'Brien, sec 4.1:
\hat{\sigma_R}

Inputs: s_ols - OLS sigma
        s_rob - robust sigma
        w     - workspace

Return: final estimate of sigma
*/

static double
robust_sigma(const double s_ols, const double s_rob,
             gsl_multifit_robust_workspace *w)
{
  double sigma;
  const size_t p = w->p;
  const size_t n = w->n;

  /* see DuMouchel and O'Brien, sec 4.1 */
  sigma = GSL_MAX(s_rob,
                  sqrt((s_ols*s_ols*p*p + s_rob*s_rob*n) /
                       (p*p + n)));

  return sigma;
} /* robust_sigma() */

/*
robust_covariance()
  Calculate final covariance matrix, defined as:

  sigma * (X^T X)^{-1}

Inputs: sigma - residual standard deviation
        cov   - (output) covariance matrix
        w     - workspace
*/

static int
robust_covariance(const double sigma, gsl_matrix *cov,
                  gsl_multifit_robust_workspace *w)
{
  int s = 0;
  const size_t p = w->p;
  const double s2 = sigma * sigma;
  size_t i, j;
  gsl_matrix *QSI = w->QSI;
  gsl_vector *D = w->D;

  /* Form variance-covariance matrix cov = s2 * (Q S^-1) (Q S^-1)^T */

  for (i = 0; i < p; i++)
    {
      gsl_vector_view row_i = gsl_matrix_row (QSI, i);
      double d_i = gsl_vector_get (D, i);

      for (j = i; j < p; j++)
        {
          gsl_vector_view row_j = gsl_matrix_row (QSI, j);
          double d_j = gsl_vector_get (D, j);
          double s;

          gsl_blas_ddot (&row_i.vector, &row_j.vector, &s);

          gsl_matrix_set (cov, i, j, s * s2 / (d_i * d_j));
          gsl_matrix_set (cov, j, i, s * s2 / (d_i * d_j));
        }
    }

  return s;
} /* robust_covariance() */


#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <gsl/gsl_matrix.h>
#include "globals.h"
#include "SimulationSteps.h"

//#define WDON

int P;
int Np;
gsl_matrix *LIFT;
gsl_matrix *VolMat;
gsl_matrix *MassMatrix;

int main(int argc, char **argv)
{
	if (argc != 2)
	{
		printf("Usage: ./Simulation 'Fort.14'\n");
		printf("Fort.14: Mesh for the channel\n");
		exit(EXIT_FAILURE);

	}

	char *Mesh = argv[1];

	//printf("Enter the polynomial approximation order:\n");
	//scanf("%d", &P);

	P = 1;
	Np = P+1;

	store_mesh(Mesh);

/*	for (int i = 0; i < NumEl; i++)
	{
		for (int j = 0; j < Np; j++)
			printf("x = %lf \t z = %lf \t S0 = %3.18lf\n", NodalX[i*Np+j] , Nodalz[i*Np+j], dz[i*Np+j]);
	}

	exit(1);
*/	// Create VolMat, LIFT and MassMatrix
	calculateLIFTVolMat(P, Np, &LIFT, &VolMat, &MassMatrix);

	double FinalTime;

	printf("Enter the time you would like to run the simulation till:\n");
	scanf("%lf", &FinalTime);

	initialize();

	/* Impose boundary conditions and couple the channels to the junction */
	boundary_conditions();

	/* Step through time */

	time_evolution(FinalTime);

	return(0);

}


#include <math.h>
#include <stdio.h>
#include <stddef.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_blas.h>
#include <gsl/gsl_vector.h>
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_multimin.h>
#include <gsl/gsl_sf.h>
#include <gsl/gsl_randist.h>
#include <gsl/gsl_cdf.h>
#include <gsl/gsl_linalg.h>
#include <getopt.h>
#include <string.h>

#include "libhdr"
#include "Library_DFE_v1.8.h"

/*
  version 1.7.3:
  -added: constant population support
  -added: generate gamma distribution deviates
  -added: generate beta distribution deviates
  -added: generate gamma+beta distribution deviates

  to compile:

  gcc -O3 -o bin/Multi_DFE_gen_v1.8 Multi_DFE_gen_v1.8.c Library_DFE_v1.8.c tmatrix_routines.c genlib.c nrlib.c nrutil.c  -lm -lgsl -lgslcblas -w

  example run:

  GSL_RNG_SEED=1 ~/Multi_DFE_est/source/bin/Multi_DFE_gen_v1.8 -N1 100 -N2 100 -nalleles 20 -t 100 -f0 0.9 -neutral 1000000 -selected 1000000 -mode 9 -conpop 1 -exp_mean 0.05 -file 1.out

  #-gamma_alpha 10 -gamma_beta 0.5
  #-exp_mean 0.02 -beta_alpha 10 -beta_beta 1
  #-exp_mean 0.02 -gamma_alpha 1000 -gamma_beta 50
  #-gamma_alpha 70 -gamma_beta 0.07 -gamma2_alpha 1000 -gamma2_beta 50
  #-exp_mean 0.05

*/

/*Global variable declaration*/
int selmode=0;
int  n_sfs=0;
int nspikes=1;//default a single spike

int N1,N2=100;
int max_n2d=2000;
double saveresults[100];
int n2_step=0, conpop=0, output_egf_mode=0;

/*Function list*/
double load_FV(int n1,int n2,int t2,double s,double f0,double *mean_FV);

/******************************************************************************/
double load_FV(int n1,int n2,int t2,double s,double f0,double *mean_FV)
{

  static double egf_vec1_lower[maxnd+1], egf_vec2_lower[maxnd+1],
    egf_vec1_upper[maxnd+1], egf_vec2_upper[maxnd+1],
    egf_vec1[maxnd+1], egf_vec2[maxnd+1],egf_vec[maxnd+1];

  double *gamma_density_vec;

  int i=0,j=0,file_size_bytes=0;
  int t2_upper=0;
  int t2_real=t2;
  int n1d=2*n1;
  int n2d=2*n2;

  char *buffer_p1_t2_lower, *buffer_p2_t2_lower,
    *buffer_p1_t2_upper, *buffer_p2_t2_upper, *buffer_const_pop;
  ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  if (!conpop)
    {
      get_upper_lower_int(t2_real, &t2_lower, &t2_upper, n_t2_evaluated, t2_evaluated_vec);
      if ((t2_lower==undefined_int)||(t2_upper==undefined_int))
	{
	  return undefined;
	}
      //printf("\n%d",t2_lower);
      //printf("\n%f",s);
      file_size_bytes=compute_file_size_bytes(n2);
      //Read buffers
      ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
      buffer_p1_t2_lower = (char*) malloc (file_size_bytes);
      buffer_p1_t2_upper = (char*) malloc (file_size_bytes);

      buffer_p2_t2_lower = (char*) malloc (file_size_bytes);
      buffer_p2_t2_upper = (char*) malloc (file_size_bytes);

      read_phase1_phase2_file_into_buffer(n1,1, n2, t2_lower,
					  buffer_p1_t2_lower, file_size_bytes);
      read_phase1_phase2_file_into_buffer(n1,1, n2, t2_upper,
					  buffer_p1_t2_upper, file_size_bytes);

      read_phase1_phase2_file_into_buffer(n1,2, n2, t2_lower,
					  buffer_p2_t2_lower, file_size_bytes);
      read_phase1_phase2_file_into_buffer(n1,2, n2, t2_upper,
					  buffer_p2_t2_upper, file_size_bytes);

      get_binary_egf_vec(buffer_p1_t2_lower, n2, t2_lower, s, egf_vec1_lower);
      get_binary_egf_vec(buffer_p1_t2_upper, n2, t2_upper, s, egf_vec1_upper);

      get_binary_egf_vec(buffer_p2_t2_lower, n2, t2_lower, s, egf_vec2_lower);
      get_binary_egf_vec(buffer_p2_t2_upper, n2, t2_upper, s, egf_vec2_upper);
      //End reading buffers
      ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
      //Averaging vectors w(s) and x(s)

      compute_weighted_average_egf_vec(t2_real, t2_lower, t2_upper,
				       egf_vec1_lower, egf_vec1_upper, egf_vec1, n2d);
      compute_weighted_average_egf_vec(t2_real, t2_lower, t2_upper,
				       egf_vec2_lower, egf_vec2_upper, egf_vec2, n2d);
      ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
      //dumpvector(egf_vec1,0,210,"egf_vec1");
      //printf("\n%d\t%d",t2_lower, t2_upper);
      //dumpvector(egf_vec2,0,210,"egf_vec2");
      compute_weighted_average( mean_FV, egf_vec1, egf_vec2, n1d, n2d);

      free(buffer_p1_t2_lower);
      free(buffer_p2_t2_lower);
      free(buffer_p1_t2_upper);
      free(buffer_p2_t2_upper);
    }
  else//constant population
    {
      if (2*n1 > max_n2d)
	{
	  printf("ERROR: Value of 2*n1 %d exceeds max_n2d %d\n", n1, max_n2d);
	  gabort("Program terminating", 0);
	}
      file_size_bytes = compute_file_size_bytes(n1);
      //      printf("const pop: file_size_bytes %d\n", file_size_bytes); monitorinput();
      buffer_const_pop = (char*) malloc (file_size_bytes);

      read_const_pop_file_into_buffer(n1, buffer_const_pop, file_size_bytes);
      get_const_pop_egf_vec(s, n1, mean_FV, buffer_const_pop, 1);

      free(buffer_const_pop);
    }

  return (1);
}

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
static int verbose_flag;
main(argc,argv)
int argc; char **argv;
{
  int i=0,j=0;
  int nalleles=0;
  double f0=0;
  int t=0;
  int nspikes=0;
  int sampleS=0,sampleN=0;

  double beta_alpha=0,beta_beta=0,gamma_alpha=0, gamma_beta=0,gamma2_alpha=0,gamma2_beta=0,exp_mean=0,exp_mean2=0,
    sel_coeff1=0,sel_coeff2=0,sel_coeff3=0,prob1=0,prob2=0,prob3=0;
  char *sfs_filename;

  /*
    location parameters measured
    Mean,squared mean,harmonic mean
  */
  double MEAN_S=0,MEAN_S2=0,MEAN_H=0,fix_prob=0;

  int c;

  while (1)
    {
      static struct option long_options[] =
	{
	  /* These options set a flag. */
	  // {"verbose", no_argument,       &verbose_flag, 1},
	  // {"brief",   no_argument,       &verbose_flag, 0},
	  /* These options don't set a flag.
	     We distinguish them by their indices. */
	  {"N1",     required_argument,0, 'a'},
	  {"N2",  required_argument,0, 'b'},
	  {"nalleles",  required_argument, 0, 'c'},
	  {"t",  required_argument, 0, 'd'},
	  {"f0",    required_argument, 0, 'e'},
	  {"neutral",    required_argument, 0, 'f'},
	  {"selected",    required_argument, 0, 'g'},
	  {"mode",    required_argument, 0, 'h'},
	  {"nspikes",    required_argument, 0, 'i'},
	  {"gamma_alpha",    required_argument, 0, 'j'},
	  {"gamma_beta",    required_argument, 0, 'k'},
	  {"beta_alpha",    required_argument, 0, 'l'},
	  {"beta_beta",    required_argument, 0, 'm'},
	  {"gamma2_alpha",    required_argument, 0, 'n'},
	  {"gamma2_beta",    required_argument, 0, 'o'},
	  {"exp_mean",    required_argument, 0, 'p'},
	  {"conpop",    required_argument, 0, 'q'},
	  {"file",    required_argument, 0, 'r'},
	  {"exp_mean2",    required_argument, 0, 's'},
	  {"s1",    required_argument, 0, 't'},
	  {"s2",    required_argument, 0, 'u'},
	  {"s3",    required_argument, 0, 'v'},
	  {"p1",    required_argument, 0, 'w'},
	  {"p2",    required_argument, 0, 'x'},
	  {"p3",    required_argument, 0, 'y'},
	  {0, 0, 0, 0}
	};
      /* getopt_long stores the option index here. */
      int option_index = 0;

      c = getopt_long_only (argc, argv, "",
                            long_options, &option_index);

      /* Detect the end of the options. */
      if (c == -1)
	break;

      switch (c)
	{
	case 0:
	  /* If this option set a flag, do nothing else now. */
	  if (long_options[option_index].flag != 0)
	    break;
	  printf ("option %s", long_options[option_index].name);
	  if (optarg)
	    printf (" with arg %s", optarg);
	  printf ("\nalleles");
	  break;

	case 'a':
	  N1=atoi(optarg);
	  break;
	case 'b':
	  N2=atoi(optarg);
	  break;
	case 'c':
	  nalleles=atoi(optarg);
	  break;
	case 'd':
	  t=atof(optarg);
	  break;
	case 'e':
	  f0=atof(optarg);
	  break;
	case 'f':
	  sampleS=atoi(optarg);
	  break;
	case 'g':
	  sampleN=atoi(optarg);
	  break;
	case 'h':
	  selmode=atoi(optarg);
	  break;
	case 'i':
	  nspikes=atoi(optarg);
	  break;
	case 'j':
	  gamma_alpha=atof(optarg);
	  break;
	case 'k':
	  gamma_beta=atof(optarg);
	  break;
	case 'l':
	  beta_alpha=atof(optarg);
	  break;
	case 'm':
	  beta_beta=atof(optarg);
	  break;
	case 'n':
	  gamma2_alpha=atof(optarg);
	  break;
	case 'o':
	  gamma2_beta=atof(optarg);
	  break;
	case 'p':
	  exp_mean=atof(optarg);
	  break;
	case 'q':
	  conpop=atoi(optarg);
	  break;
	case 'r':
	  sfs_filename=optarg;
	  break;
	case 's':
	  exp_mean2=atof(optarg);
	  break;
	case 't':
	  sel_coeff1=atof(optarg);
	  break;
	case 'u':
	  sel_coeff2=atof(optarg);
	  break;
	case 'v':
	  sel_coeff3=atof(optarg);
	  break;
	case 'w':
	  prob1=atof(optarg);
	  break;
	case 'x':
	  prob2=atof(optarg);
	  break;
	case 'y':
	  prob3=atof(optarg);
	  break;
	case '?':
	  /* getopt_long already printed an error message. */
	  break;

	default:
	  abort ();
	}
    }

  /* Print any remaining command line arguments (not options). */
  if (optind < argc)
    {
      printf ("non-option ARGV-elements: ");
      while (optind < argc)
	printf ("%s ", argv[optind++]);
      putchar ('\n');
    }

  double n1d=2*N1;
  double n2d=2*N2;
  /*find n_e*/
  double prop[4],n_es=0;
  double n_e=calculate_ne(N1,N2,t);

  /*Set up Spikes*/
  double * spikes_vec = (double*) calloc (nspikes+1, sizeof(double));
  double * prob_vec = (double*) calloc (nspikes+1, sizeof(double));

  for(i = 1; i <= nspikes; i++){
    printf("Give s for spike %d:\n", i);
    scanf("%lf",&spikes_vec[i]);
  }
  spikes_vec[0]=0;

  double sum_prob=0;
  for(i = 1; i <= nspikes-1; i++){
    printf("Give probability of Spike %d:\n", i);
    scanf("%lf",&prob_vec[i]);
    sum_prob+=prob_vec[i];
  }
  prob_vec[nspikes]=1-sum_prob;
  prob_vec[0]=0;

  double **FVSX= calloc(maxnd+1, sizeof(double *));

  for(i = 1; i <= nspikes; i++){
    FVSX[i] = calloc(maxnd+1,  sizeof(double));
  }
  double * FV0 = (double*) calloc (maxnd+1, sizeof(double));

  /*Set up Tables*/

  get_data_path(data_path);
  set_up_file_name(N1, s_evaluated_vec_file_const, s_evaluated_vec_file);
  set_up_file_name(N1, s_range_file_const, s_range_file);
  get_s_evaluated_vec(s_evaluated_vec, &n_s_evaluated, &n_s_evaluated_file,
		      s_evaluated_vec_file);
  get_s_ranges();

  if (!conpop)
    {
      set_up_file_name(N1, n2_evaluated_vec_file_const, n2_evaluated_vec_file);
      set_up_file_name(N1, t2_evaluated_vec_file_const, t2_evaluated_vec_file);
      set_up_file_name(N1, phase_1_dir_const, phase_1_dir);
      set_up_file_name(N1, phase_2_dir_const, phase_2_dir);

      get_int_evaluated_vec(t2_evaluated_vec,&n_t2_evaluated, &t2_lower,
			    &t2_step,&t2_evaluated_vec_file);
      get_int_evaluated_vec(n2_evaluated_vec,&n_n2_evaluated, &n2_lower,
			    &n2_step,&n2_evaluated_vec_file);
    }
  else
    {
      set_up_file_name(N1, "", const_pop_dir);
    }

  /* calculate neutral frequency vector*/
  load_FV(N1,N2,t,0.0,f0,FV0);

  /*Sampling of sites*/
  int * discrete0 = (int*) calloc (nalleles+2, sizeof(int));
  int * discrete1 = (int*) calloc (nalleles+2, sizeof(int));

  const gsl_rng_type * T;
  double selcoeff=0,uniform=0;

  gsl_rng_env_setup();
  T = gsl_rng_taus;
  gsl_rng  *rgen =gsl_rng_alloc(T);

  printf("%f,%f\n",gamma_alpha,gamma_beta);
  i=1;
  while (i<=sampleN)
    {// loop for sampling starts here
      i++;
      uniform=gsl_rng_uniform (rgen);
      double * FVS = (double*) calloc (maxnd+1, sizeof(double));
      selcoeff=0;
      switch(selmode)
	{
	case 0:case 1:
	  break;
	case 2:
	  selcoeff=gsl_ran_gamma (rgen, gamma_beta, 1/gamma_alpha);
	  break;
	case 3:
	  selcoeff=gsl_ran_beta (rgen, beta_alpha, beta_beta);
	  break;
	case 4:
	  if (uniform<=0.2) {selcoeff=gsl_ran_exponential(rgen,exp_mean);}
	  if (uniform>0.2) {selcoeff=gsl_ran_beta (rgen, beta_alpha, beta_beta);}
	  break;
	case 5:
	  if (uniform<=0.5) {selcoeff=gsl_ran_gamma (rgen, gamma_beta, 1/gamma_alpha);}
	  if (uniform>0.5) {selcoeff=gsl_ran_gamma (rgen, gamma2_beta, 1/gamma2_alpha);}
	  break;
	case 6:
	  if (uniform<=0.5) {selcoeff=gsl_ran_exponential(rgen, exp_mean);}
	  if (uniform>0.5) {selcoeff=gsl_ran_exponential (rgen, exp_mean2);}
	  break;
	case 7:
	  if (uniform<=0.5) {selcoeff=gsl_ran_gamma (rgen, gamma_beta, 1/gamma_alpha);}
	  if (uniform>0.5) {selcoeff=gsl_ran_exponential (rgen, exp_mean);}
	  break;
	case 8:
	  if (uniform<=0.8) {selcoeff=gsl_ran_exponential(rgen,exp_mean);}
	  if (uniform>0.8) {selcoeff=gsl_ran_beta (rgen, beta_alpha, beta_beta);}
	  break;
	case 9:
          selcoeff=gsl_ran_exponential(rgen,exp_mean);
	  break;
	case 10:
          if (uniform<=0.5) {selcoeff=0.0;}
          if (uniform>0.5) {selcoeff=0.05;}
	  break;
	case 11:
          if (uniform<=(0.3)) {selcoeff=0.0;}
          if (uniform>0.33&&uniform<=0.67) {selcoeff=0.05;}
          if (uniform>0.67) {selcoeff=0.5;}
	  break;
    case 12:
          if (uniform<=0.3) {selcoeff=0;}//gsl_ran_gaussian (rgen,1e-5);}
          if (uniform>0.3&&uniform<=0.4) {selcoeff=-0.05;}//gsl_ran_gaussian (rgen,1e-5);selcoeff+=0.005;}
          if (uniform>0.4&&uniform<=0.6) {selcoeff=-0.5;}//gsl_ran_gaussian (rgen,1e-5);selcoeff+=0.05;}
          if (uniform>0.6) {selcoeff=-5;} //gsl_ran_gaussian (rgen,1e-5);selcoeff+=0.5;}
	  break;
	case 13:
          selcoeff=uniform;
	  break;
    case 14:
	  if (uniform<=0.5) {selcoeff=gsl_ran_gamma (rgen, gamma_beta, 1/gamma_alpha);}
	  if (uniform>0.5) {selcoeff=gsl_ran_beta (rgen, beta_alpha, beta_beta);}
	  break;
    case 15:
	  if (uniform<=0.2) {selcoeff=gsl_ran_gamma (rgen, gamma_beta, 1/gamma_alpha);}
	  if (uniform>0.2) {selcoeff=gsl_ran_beta (rgen, beta_alpha, beta_beta);}
	  break;
    case 16:
	  if (uniform<=0.8) {selcoeff=gsl_ran_gamma (rgen, gamma_beta, 1/gamma_alpha);}
	  if (uniform>0.8) {selcoeff=gsl_ran_beta (rgen, beta_alpha, beta_beta);}
	  break;
 	case 17:
          if (uniform<=(0.3)) {selcoeff=0.0;}
          if (uniform>0.33&&uniform<=0.67) {selcoeff=0.03;}
          if (uniform>0.67) {selcoeff=0.06;}
	  break;
	case 18:
          if (uniform<=0.2) {selcoeff=sel_coeff1;}
          if (uniform>0.2&&uniform<=0.8) {selcoeff=sel_coeff2;}
          if (uniform>0.8) {selcoeff=sel_coeff3;}
	  break;
	case 19:
          if (uniform<=0.3) {selcoeff=0;}
          if (uniform>0.3) {selcoeff=0.05;}
	  break;
	case 20:
          if (uniform<=0.2) {selcoeff=0;}
          if (uniform>0.2&&uniform<=0.4) {selcoeff=0.05;}
          if (uniform>0.4) {selcoeff=0.5;}
	  break;
	case 21:
          if (uniform<=0.2) {selcoeff=0;}
          if (uniform>0.2&&uniform<=0.4) {selcoeff=0.02;}
          if (uniform>0.4&&uniform<=0.6) {selcoeff=0.05;}
          if (uniform>0.6) {selcoeff=0.1;}
          break;
    case 22:
	  selcoeff=exp_mean;
	  break;
    case 23:
	  selcoeff=gsl_ran_lognormal (rgen, gamma_alpha, gamma_beta);
	  break;
	case 24:
          if (uniform<=0.2) {selcoeff=sel_coeff1;}
          if (uniform>0.2) {selcoeff=sel_coeff2;}
	  break;
    case 25:
          if (uniform<=0.5) {selcoeff=sel_coeff1;}
          if (uniform>0.5) {selcoeff=sel_coeff2;}
	  break;
	case 26:
          if (uniform<=prob1) {selcoeff=sel_coeff1;}
          if (uniform>prob1) {selcoeff=sel_coeff2;}
	  break;
	case 27:
          if (uniform<=prob1) {selcoeff=sel_coeff1;}
          if (uniform>=prob1) {selcoeff=sel_coeff1;}
          if (uniform>prob1) {selcoeff=sel_coeff2;}
	  break;
	}//end switch

      //monitorinput();
      if(selcoeff>0){selcoeff=-selcoeff;}
      if (selcoeff<-100) {selcoeff=-100;}//free(FVS);continue;}//free(FVS);continue;
      //printf("%f\n",selcoeff);
      MEAN_S+=selcoeff;
      MEAN_S2+=-pow(selcoeff,2);
      MEAN_H+=1/selcoeff;

      if (selcoeff== 0)
        {
	  fix_prob += 0.5/n_e;
	}
      else
	{
	  fix_prob += kimura_fixation_prob(selcoeff, n_e);
	}

      /*calculate relative proportions*/
      n_es=-n_e*selcoeff;
      if (n_es<=0.1){prop[0]++;}
      if (n_es<=1.0){prop[1]++;}
      if (n_es<=10.0){prop[2]++;}
      if (n_es<100.0){prop[3]++;}

      load_FV(N1,N2,t,selcoeff,f0,FVS);

      egf_scaling(N2,f0,FV0,FVS);
      gsl_ran_discrete_t *r= gsl_ran_discrete_preproc (n2d,FVS);
      double s1=gsl_ran_discrete (rgen, r);
      double prob=(double)(s1)/n2d;

      int success=gsl_ran_binomial(rgen,prob,nalleles);
      if (success==nalleles){discrete1[0]++;}else{
	discrete1[success]++;
      }
      free(FVS);
      gsl_ran_discrete_free(r);

    }//end sampling

  MEAN_S/=sampleN;
  MEAN_S2/=sampleN;
  MEAN_H/=sampleN;
  MEAN_H=1/MEAN_H;//Reciprocal of the mean of the reciprocals
  fix_prob/=sampleN;

  fix_prob *=2*n_e;

  prop[3]=(prop[3]-prop[2])/sampleN;
  prop[2]=(prop[2]-prop[1])/sampleN;
  prop[1]=(prop[1]-prop[0])/sampleN;
  prop[0]=prop[0]/sampleN;

  egf_scaling(N2,f0,FV0,FV0);
  binomial_sampling(N2,nalleles,sampleS,FV0,discrete0);//neutral

  /*Print Output*/

  printf("%f\t%f\t%f\n",MEAN_S,MEAN_S2,MEAN_H);
  //output_sfs_to_file_thanasis_format(nalleles,discrete0,discrete1,sfs_filename);
  output_sfs_to_file_peter_format2(nalleles,sampleS,sampleN,discrete1,discrete0,sfs_filename);

  FILE *file1= fopen(strcat(sfs_filename,".mean"), "w" );
  fprintf(file1,"%0.16E %0.16E %0.16E ",MEAN_S,MEAN_S2,MEAN_H);

  for(i = 0; i <= 3; i++){
    fprintf(file1,"%0.16E ",prop[i]);
  }
  fprintf(file1,"%0.16E ",fix_prob);
  fclose(file1);
  ////////////////////////////////////////////////////////////////////////////////

  free(FV0);
  gsl_rng_free (rgen);

  free(discrete0);
  free(discrete1);

  for(i = 1; i <= nspikes; i++){
    free(FVSX[i]);
  }
  free(FVSX);

  return 0;
}


/** @file */

#ifndef __CCL_F3D_H_INCLUDED__
#define __CCL_F3D_H_INCLUDED__

#include <gsl/gsl_spline.h>
#include <gsl/gsl_interp2d.h>
#include <gsl/gsl_spline2d.h>

CCL_BEGIN_DECLS

/**
 * Struct for accelerated linear interpolation.
 */
typedef struct {
  int ia_last; /**< Last index found */
  double amin; /**< Minimum a-value within range */
  double amax; /**< Maximum a-value within range */
  int na; /**< Number of a-values held */
  double *a_arr; /**< Array of a-values */
} ccl_a_finder;

/**
 * Creates a new ccl_a_finder structure from an array
 * of scale factors.
 * @param na Number of elements held by a_arr
 * @param a_arr array of scale factors over which linear interpolation will be carried out.
 */
ccl_a_finder *ccl_a_finder_new(int na, double *a_arr);

/**
 * ccl_a_finder destructor.
 */
void ccl_a_finder_free(ccl_a_finder *finda);

/**
 * Find index corresponding to scale factor value a
 * such that finda->a_arr[index]<a<finda->a_arr[index+1].
 * @param finda ccl_a_finder.
 * @param a scale factor value.
 */
int ccl_find_a_index(ccl_a_finder *finda, double a);

/**
 * Struct containing a 3D trispectrum
 */
typedef struct {
  double lkmin,lkmax; /**< Edges in log(k)*/
  int na; /**< Number of a values */
  double *a_arr; /**< Array of a values at which this is sampled */
  int is_product; /**< Is this factorizable as f(k1,a)*g(k2,a)? */
  int extrap_order_lok; /**< Order of extrapolating polynomial in log(k) for low k (0, 1 or 2)*/
  int extrap_order_hik; /**< Order of extrapolating polynomial in log(k) for high k (0, 1 or 2)*/
  ccl_f2d_extrap_growth_t extrap_linear_growth;  /**< Extrapolation type at high redshifts*/
  int is_log; /**< Do I hold the values of log(f(k,a))?*/
  double growth_factor_0; /**< Constant extrapolating growth factor*/
  int growth_exponent; /**< Power to which growth should be exponentiated*/
  ccl_f2d_t *fka_1; /**< If is_product=True, then this holds the first factor f(k,a) */
  ccl_f2d_t *fka_2; /**< If is_product=True, then this holds the second factor g(k,a) */
  gsl_spline2d **tkka; /**< Array of 2D (k1,k2) splines (one for each value of a). */
} ccl_f3d_t;

/**
 * Create a ccl_f3d_t structure.
 * @param na number of elements in a_arr.
 * @param a_arr array of scale factor values at which the function is defined. The array should be ordered.
 * @param nk number of elements of lk_arr.
 * @param lk_arr array of logarithmic wavenumbers at which the function is defined (i.e. this array contains ln(k), NOT k). The array should be ordered.
 * @param tkka_arr array of size na * nk * nk containing the 3D function. The 3D ordering is such that fka_arr[ik1+nk*(ik2+nk*ia)] = f(k1=exp(lk_arr[ik1]),k2=exp(lk_arr[ik2],a=a_arr[ia]).
 * @param fka1_arr array of size nk * na containing the first factor f1 making up the total function if it's factorizable such that f(k1,k2,a) = f1(k1,a)*f2(k2,a). The 2D ordering of this array should be such that fka1_arr[ik+nk*ia] = f1(k=exp(lk_arr[ik]),a=a_arr[ia]). Only relevant if is_product is true.
 * @param fka2_arr same as fka1_arr for the second factor.
 * @param is_product if not 0, fka1_arr and fka2_arr will be used as 2-D arrays to construct a factorizable 3D function f(k1,k1,a) = f1(k1,a)*f2(k2,a).
 * @param extrap_order_lok Order of the polynomial that extrapolates on wavenumbers smaller than the minimum of lk_arr. Allowed values: 0 (constant) and 1 (linear extrapolation). Extrapolation happens in ln(k).
 * @param extrap_order_hik Order of the polynomial that extrapolates on wavenumbers larger than the maximum of lk_arr. Allowed values: 0 (constant) and 1 (linear extrapolation). Extrapolation happens in ln(k).
 * @param extrap_linear_growth: ccl_f2d_extrap_growth_t value defining how the function with scale factors below the interpolation range. Allowed values: ccl_f2d_cclgrowth (scale with the CCL linear growth factor), ccl_f2d_constantgrowth (scale by multiplying the function at the earliest available scale factor by a constant number, defined by `growth_factor_0`), ccl_f2d_no_extrapol (throw an error if the function is ever evaluated outside the interpolation range in a). Note that, above the interpolation range (i.e. for low redshifts), the function will be assumed constant.
 * @param is_tkka_log: if not zero, `tkka_arr` contains ln(f(k1,k2,a)) instead of f(k1,k2,a) (and likewise for fka1_arr and fka2_arr).
 * @param growth_factor_0: growth factor outside the range of scale factors held by a_arr. Irrelevant if extrap_linear_growth!=ccl_f2d_constantgrowth.
 * @param growth_exponent: power to which the extrapolating growth factor should be exponentiated when extrapolating (e.g. usually 4 for trispectra).
 * @param interp_type: 2D interpolation method in k1,k2 space. Currently only ccl_f2d_3 is implemented (bicubic interpolation). Note that linear interpolation is used between values of the scale factor.
 * @param status Status flag. 0 if there are no errors, nonzero otherwise.
 */
ccl_f3d_t *ccl_f3d_t_new(int na,double *a_arr,
			 int nk,double *lk_arr,
                         double *tkka_arr,
			 double *fka1_arr,
			 double *fka2_arr,
			 int is_product,
			 int extrap_order_lok,
			 int extrap_order_hik,
			 ccl_f2d_extrap_growth_t extrap_linear_growth,
			 int is_tkka_log,
			 double growth_factor_0,
			 int growth_exponent,
			 ccl_f2d_interp_t interp_type,
			 int *status);

/**
 * Evaluate 3D function of k1, k2 and a defined by ccl_f3d_t structure.
 * @param f3d ccl_f3d_t structure defining f(k1,k2,a).
 * @param lk1 Natural logarithm of the wavenumber.
 * @param lk2 Natural logarithm of the wavenumber.
 * @param a Scale factor.
 * @param finda Helper structure used to accelerate the scale factor interpolation.
 * @param cosmo ccl_cosmology structure, only needed if evaluating f(k1,k2,a) at small scale factors outside the interpolation range, and if fka was initialized with extrap_linear_growth = ccl_f2d_cclgrowth.
 * @param status Status flag. 0 if there are no errors, nonzero otherwise.
 */
double ccl_f3d_t_eval(ccl_f3d_t *f3d,double lk1,double lk2,double a,ccl_a_finder *finda,
                      void *cosmo, int *status);

/**
 * F3D structure destructor.
 * Frees up all memory associated with a f3d structure.
 * @param f3d Structure to be freed.
 */
void ccl_f3d_t_free(ccl_f3d_t *f3d);

/**
 * Make a copy of a ccl_f3d_t structure.
 * @param f3d_o old ccl_f3d_t structure.
 * @param status Status flag. 0 if there are no errors, nonzero otherwise.
 */
ccl_f3d_t *ccl_f3d_t_copy(ccl_f3d_t *f3d_o, int *status);

/**
 * Create a ccl_a_finder from the array of scale factors held
 * by a ccl_f3d_t structure.
 * @param f3d ccl_f3d_t structure.
 */
ccl_a_finder *ccl_a_finder_new_from_f3d(ccl_f3d_t *f3d);

CCL_END_DECLS

#endif


#include <stdlib.h>
#include <utility>
#include <gsl/gsl_multiroots.h>
#include <gsl/gsl_sf.h>
#include <string>
#include <random>
#include <array>

using namespace std;
struct mass_eff_scalar_density_params
{
    vector<double> scalar_coeff;
    vector<double> scalar_exp;
    double number_density;
    double nucleon_mass;
    double degeneracy;
    double temperature;
    vector<double> vec_coeff;
    vector<double> vec_exp;
};
//struct for the parameters for root solving for the coupling constants
struct coeff_params
{
    double saturation_densitiy;
    double nucleon_mass;
    double binding_energy;
    double degeneracy;
    vector<double> scalar_exp;
    vector<double> vec_exp;
    unsigned int* terms;
};
//struct for the parameters for finding the critical point
struct crit_params
{
    vector<double> scalar_coeff;
    vector<double> scalar_exp;
    vector<double> vec_coeff;
    vector<double> vec_exp;
    double nucleon_mass;
    double degeneracy;
};
//struct for the parameters for finding the interaction terms for 1 CP
struct interaction_params
{
    double nucleon_mass;
    double degeneracy;
    double saturation_density;
    double binding_energy;
    double critical_temperature;
    double critical_density;
    unsigned int* terms;
};
//struct for the parameters for finding the interaction terms for 2 CPs
struct interaction_params_2crit
{
    double nucleon_mass;
    double degeneracy;
    double saturation_density;
    double binding_energy;
    double critical_temperature_lg;
    double critical_density_lg;
    double critical_temperature_qgp;
    double critical_density_qgp;
    double spinodial_l_density;
    double spinodial_r_density;
    unsigned int* terms;
};
int mass_eff_scalar_density_root(const gsl_vector * x, void *params, gsl_vector * f);
int print_state_mass_eff_scalar_density (size_t iter, gsl_multiroot_fsolver * s);
pair<double, double> get_mass_eff_scalar_density(double degeneracy, double nucleon_mass,vector<double> scalar_coeff ,vector<double>  scalar_exp,double number_density,bool print);
int T_mass_eff_mu_eff_scalar_density_root(const gsl_vector * x, void *params, gsl_vector * f);
int print_state_T_mass_eff_mu_eff_scalar_density (size_t iter, gsl_multiroot_fsolver * s);
tuple<double, double,double,bool> get_T_mass_eff_mu_eff_scalar_density(vector<double> scalar_coeff, vector<double> scalar_exp, vector<double> vec_coeff, vector<double> vec_exp, double nucleon_mass,double number_density, double temperature, double degeneracy, bool print);
int coeff_root(const gsl_vector * x, void *params, gsl_vector * f);
int print_state_coeff (size_t iter, gsl_multiroot_fsolver * s);
pair<double, double> get_coeff(double nucleon_mass, double saturation_density, double binding_energy, double degeneracy, vector<double> scalar_exp, vector<double> vec_exp, bool print, unsigned int terms[2], bool * success=NULL);
int crit_root(const gsl_vector * x, void *params, gsl_vector * f);
pair<double, double> get_crit(double nucleon_mass,double saturation_density, double binding_energy, double degeneracy, vector<double> scalar_exp, vector<double> vec_exp, bool print, double crit_T=19.09, double crit_density=540000, vector<double> scalar_coeff={0.0}, vector<double> vec_coeff={0.0});
int interaction_root(const gsl_vector * x, void *params, gsl_vector * f);
int print_state_interaction (size_t iter, gsl_multiroot_fsolver * s);
tuple<double, double,double,double, double, bool> get_interaction_4D(void * p, bool print,vector<double> init_exp={2.05,2.05},vector<double> init_coeff={10*4*M_PI/pow(550,2.0),10*4*M_PI/pow(783,2.0)});
int interaction_root_2crit(const gsl_vector * x, void *params, gsl_vector * f);
int print_state_interaction_2crit (size_t iter, gsl_multiroot_fsolver * s);
tuple<double, vector<double>, vector<double>, bool> get_interaction_2crit(void * p, bool print,vector<double> init_exp={2.05,2.05,3,3},vector<double> init_coeff={10*4*M_PI/pow(550,2.0),10*4*M_PI/pow(783,2.0),0,0});
double energy_pp_minus_mass_solv(double degeneracy, double nucleon_mass,double number_density, vector<double> scalar_coeff,vector<double> scalar_exp, vector<double> vec_coeff, vector<double> vec_exp);
double energy_pp_minus_mass_dn_solv(double degeneracy, double nucleon_mass,double number_density,vector<double> scalar_coeff,vector<double> scalar_exp, vector<double> vec_coeff, vector<double> vec_exp);
double press_solv(double degeneracy, double nucleon_mass,double number_density,vector<double> scalar_coeff,vector<double> scalar_exp, vector<double> vec_coeff, vector<double> vec_exp);
double press_dn_solv(double degeneracy, double nucleon_mass,double number_density,vector<double> scalar_coeff,vector<double> scalar_exp, vector<double> vec_coeff, vector<double> vec_exp);
double incsolv(double degeneracy, double nucleon_mass,double number_density,vector<double> scalar_coeff,vector<double> scalar_exp, vector<double> vec_coeff, vector<double> vec_exp,double delta=1);
double T_press_solv(double degeneracy, double nucleon_mass,double number_density,vector<double> scalar_coeff,vector<double> scalar_exp, vector<double> vec_coeff, vector<double> vec_exp, double temperature);
double  T_press_dmu_solv(double degeneracy, double nucleon_mass,double number_density,vector<double> scalar_coeff,vector<double> scalar_exp, vector<double> vec_coeff, vector<double> vec_exp, double temperature, double delta=1.);
double  T_press_dT_solv(double degeneracy, double nucleon_mass,double number_density,vector<double> scalar_coeff,vector<double> scalar_exp, vector<double> vec_coeff, vector<double> vec_exp, double temperature, double delta=1e-2);
double  T_press_dn_solv(double degeneracy, double nucleon_mass,double number_density,vector<double> scalar_coeff,vector<double> scalar_exp, vector<double> vec_coeff, vector<double> vec_exp, double temperature, double delta=1e3);
double  T_press_dn2_solv(double degeneracy, double nucleon_mass,double number_density,vector<double> scalar_coeff,vector<double> scalar_exp, vector<double> vec_coeff, vector<double> vec_exp,double temperature, double delta=1e3);
pair<double, double> T_press_dn12_solv(double degeneracy, double nucleon_mass,double number_density,vector<double> scalar_coeff,vector<double> scalar_exp, vector<double> vec_coeff, vector<double> vec_exp, double temperature, double delta=1e3);
double T_eps_solv(double degeneracy, double nucleon_mass,double number_density,vector<double> scalar_coeff,vector<double> scalar_exp, vector<double> vec_coeff, vector<double> vec_exp, double temperature);
void gsl_handler (const char * reason, const char * file, int line, int gsl_errno);
bool validate_interaction(double error, vector<double> coeff_guess, vector<double> exp_guess,vector<double> coeff, vector<double> exp, string filename, int timestamp, void* params);
void interaction_4D_grid(double nucleon_mass,double critical_temperature, double critical_density, double binding_energy, double saturation_density, double degeneracy, double boundaries  [4][3], unsigned int terms [2], string filename, bool print, int num_sol=0);
void interaction_4D_crit_grid(double nucleon_mass, double binding_energy, double saturation_density, double degeneracy, double boundaries_model  [4][3], double boundaries_crit [2][3], unsigned int terms [2], string filename, bool print, int num_sol);
double round_to_n_digits(double x, int n);