/**
 *
 * @file core_cpltmg.c
 *
 *  PLASMA core_blas kernel
 *  PLASMA is a software package provided by Univ. of Tennessee,
 *  Univ. of California Berkeley and Univ. of Colorado Denver
 *
 * @version 2.6.0
 * @author Ichitaro Yamazaki
 * @author Julien Herrmann
 * @author Mathieu Faverge
 * @date 2010-11-15
 * @generated c Tue Jan  7 11:44:47 2014
 *
 **/

#include <math.h>
#include <lapacke.h>
#include "common.h"

#define pi (3.1415926535897932384626433832795028841971693992)

/***************************************************************************//**
 *
 * @ingroup CORE_PLASMA_Complex32_t
 *
 *  CORE_cpltmg initialize a tile of a random matrix from the MatLab
 *  gallery configured with the default parameters, and a few other
 *  specific matrices.
 *
 *******************************************************************************
 *
 * @param[in] mtxtype
 *          Possible types are: PlasmaMatrixRandom, PlasmaMatrixHadamard,
 *          PlasmaMatrixParter, PlasmaMatrixRis, PlasmaMatrixKms,
 *          PlasmaMatrixMoler, PlasmaMatrixCompan, PlasmaMatrixRiemann,
 *          PlasmaMatrixLehmer, PlasmaMatrixMinij, PlasmaMatrixDorr,
 *          PlasmaMatrixDemmel, PlasmaMatrixInvhess, PlasmaMatrixCauchy,
 *          PlasmaMatrixHilb, PlasmaMatrixLotkin, PlasmaMatrixOrthog,
 *          PlasmaMatrixWilkinson, PlasmaMatrixFoster, PlasmaMatrixWright,
 *          PlasmaMatrixLangou
 *          (See further in the code for more details)
 *
 * @param[in] M
 *         The number of rows of the tile A. M >= 0.
 *
 * @param[in] N
 *         The number of columns of the tile A. N >= 0.
 *
 * @param[in,out] A
 *         On entry, the M-by-N tile to be initialized.
 *         On exit, the tile initialized in the mtxtype format.
 *
 * @param[in] LDA
 *         The leading dimension of the tile A. LDA >= max(1,M).
 *
 * @param[in] gM
 *         The global number of rows of the full matrix, A is belonging to. gM >= (m0+M).
 *
 * @param[in] gN
 *         The global number of columns of the full matrix, A is belonging to. gN >= (n0+gN).
 *
 * @param[in] m0
 *         The index of the first row of tile A in the full matrix. m0 >= 0.
 *
 * @param[in] n0
 *         The index of the first column of tile A in the full matrix. n0 >= 0.
 *
 * @param[in] seed
 *         The seed used for random generation. Must be the same for
 *         all tiles initialized with this routine.
 *
 *******************************************************************************
 *
 * @return
 *         \retval PLASMA_SUCCESS successful exit
 *         \retval <0 if INFO = -k, the k-th argument had an illegal value
 *
 ******************************************************************************/
#if defined(PLASMA_HAVE_WEAK)
#pragma weak CORE_cpltmg = PCORE_cpltmg
#define CORE_cpltmg PCORE_cpltmg
#define CORE_cplrnt  PCORE_cplrnt
void
CORE_cplrnt( int M, int N, PLASMA_Complex32_t *A, int LDA,
             int gM, int m0, int n0,
             unsigned long long int seed );
#endif
int CORE_cpltmg( PLASMA_enum mtxtype,
                  int M, int N, PLASMA_Complex32_t *A, int LDA,
                  int gM, int gN, int m0, int n0,
                  unsigned long long int seed )
{
    int i, j;

    /* Check input arguments */
    if (M < 0) {
        coreblas_error(2, "Illegal value of M");
        return -3;
    }
    if (N < 0) {
        coreblas_error(3, "Illegal value of N");
        return -3;
    }
    if ((LDA < max(1,M)) && (M > 0)) {
        coreblas_error(5, "Illegal value of LDA");
        return -5;
    }
    if (m0 < 0) {
        coreblas_error(8, "Illegal value of m0");
        return -8;
    }
    if (n0 < 0) {
        coreblas_error(9, "Illegal value of n0");
        return -9;
    }
    if (gM < m0+M) {
        coreblas_error(6, "Illegal value of gM");
        return -6;
    }
    if (gN < n0+N) {
        coreblas_error(7, "Illegal value of gN");
        return -7;
    }

    /* Quick return */
    if ((M == 0) || (N == 0))
        return PLASMA_SUCCESS;

    switch( mtxtype ) {
    case PlasmaMatrixRandom:
    {
        CORE_cplrnt( M, N, A, LDA, gM, m0, n0, seed );
    }
    break;

    /*
     * See http://www.mathworks.fr/fr/help/matlab/ref/hadamard.html
     *
     * Initialize the tile A to create the Hadamard matrix of order gN.
     *
     * Hadamard matrices are matrices of 1's and -1's whose columns are orthogonal,
     *
     *   H'*H = gN*I
     *
     *   where [gN gN]=size(H) and I = eye(gN,gN) ,.
     *
     *  They have applications in several different areas, including
     *  combinatorics, signal processing, and numerical analysis.
     *
     *  An n-by-n Hadamard matrix with n > 2 exists only if rem(n,4) =
     *  0. This function handles only the cases where n is a power of
     *  2.
     */
    case PlasmaMatrixHadamard:
    {
        int tmp, nbone;

        /* Extra parameters check */
        if (gM != gN) {
            coreblas_error(6, "Illegal value of gM (Matrix must be square)");
            return -6;
        }

        tmp = gM;
        while ( tmp > 1 ) {
            if( tmp % 2 != 0 ) {
                coreblas_error(6, "Illegal value of gM (Matrix dimension must be a power of 2)");
                return -6;
            }
            tmp /= 2;
        }

        for (j=0; j<N; j++) {
            for (i=0; i<M; i++) {
                tmp = ((m0 + i) & (n0 + j));
                nbone = 0;
                while ( tmp != 0 )
                {
                    nbone += ( tmp & 1 );
                    tmp >>= 1;
                }
                A[j*LDA+i] = (PLASMA_Complex32_t)(1. - 2. * ( nbone % 2 ));
            }
        }
    }
    break;

    /*
     * See http://www.mathworks.fr/fr/help/matlab/ref/gallery.html#f84-1000116
     *
     * Toeplitz matrix with singular values near pi.
     * Returns the tile A, such that the elment of the matrix are 1/(i-j+0.5).
     *
     * C is a Cauchy matrix and a Toeplitz matrix. Most of the
     * singular values of C are very close to pi.
     *
     */
    case PlasmaMatrixParter:
    {
        PLASMA_Complex32_t tmp;

        if (gM != gN) {
            coreblas_error(6, "Illegal value of gM (Matrix must be square for Parter)");
            return -6;
        }

        tmp = (PLASMA_Complex32_t)( .5 + m0 - n0 );
        for (j=0; j<N; j++) {
            for (i=0; i<M; i++) {
                A[j*LDA+i] = (PLASMA_Complex32_t)1. / (PLASMA_Complex32_t)( tmp + i - j );
            }
        }
    }
    break;

    /*
     * See http://www.mathworks.fr/fr/help/matlab/ref/gallery.html#f84-1000243
     *
     * Symmetric Hankel matrix
     * Returns a symmetric gN-by-gN Hankel matrix with elements.
     *
     *     A(i,j) = 0.5/(n-i-j+1.5)
     *
     * The eigenvalues of A cluster around π/2 and –π/2. This matrix
     * was invented by F.N. Ris.
     *
     */
     case PlasmaMatrixRis:
    {
        PLASMA_Complex32_t tmp;

        if (gM != gN) {
            coreblas_error(6, "Illegal value of gM (Matrix must be square for RIS)");
            return -6;
        }

        tmp = (PLASMA_Complex32_t)( gM - m0 - n0 - 0.5 );
        for (j=0; j<N; j++) {
            for (i=0; i<M; i++) {
                A[j*LDA+i] = (PLASMA_Complex32_t).5 / (PLASMA_Complex32_t)( tmp - i - j );
            }
        }
    }
    break;

    /*
     * See http://www.mathworks.fr/fr/help/matlab/ref/gallery.html#f84-1000026
     *
     * Kac-Murdock-Szego Toeplitz matrix
     *
     * Returns the n-by-n Kac-Murdock-Szego Toeplitz matrix such that
     * A(i,j) = rho^(abs(i-j)), for real rho.
     *
     * For complex rho, the same formula holds except that elements
     * below the diagonal are conjfugated. rho defaults to 0.5.
     *
     * The KMS matrix A has these properties:
     *     - An LDL' factorization with L inv(gallery('triw',n,-rho,1))',
     *       and D(i,i) (1-abs(rho)^2)*eye(n), except D(1,1) = 1.
     *     - Positive definite if and only if 0 < abs(rho) < 1.
     *     - The inverse inv(A) is tridiagonal.Symmetric Hankel matrix
     *
     * In this function, rho is set to 0.5 and cannot be changed.
     */
    case PlasmaMatrixKms:
    {
        PLASMA_Complex32_t rho;

        if (gM != gN) {
            coreblas_error(6, "Illegal value of gM (Matrix must be square for KMS)");
            return -6;
        }

        rho = .5;
        for (j=0; j<N; j++) {
            for (i=0; i<M; i++) {
                A[j*LDA+i] = (PLASMA_Complex32_t)( cpowf( rho, fabs( (float)( m0 + i - n0 - j ) ) ) );
            }
        }
    }
    break;

    /*
     * See http://www.mathworks.fr/fr/help/matlab/ref/gallery.html#f84-1000074
     *
     * Symmetric positive definite matrix
     *
     * Returns the symmetric positive definite n-by-n matrix U'*U,
     * where U = gallery('triw',n,alpha).
     *
     * For the default alpha = -1, A(i,j) = min(i,j)-2, and A(i,i) =
     * i. One of the eigenvalues of A is small.
     *
     */
    case PlasmaMatrixMoler:
    {
        int ii, jj;
        for (j=0,jj=n0; j<N; j++,jj++) {
            for (i=0,ii=m0; i<M; i++,ii++) {
                if ( ii == jj ) {
                    A[j*LDA+i] = (PLASMA_Complex32_t)( ii + 1. );
                } else {
                    A[j*LDA+i] = (PLASMA_Complex32_t)( min( ii, jj ) - 1. );
                }
            }
        }
    }
    break;

    /*
     *  See http://www.mathworks.fr/fr/help/matlab/ref/compan.html
     *
     *  Companion matrix
     *
     *  A = compan(u) returns the corresponding companion matrix whose first row is
     *  -u(2:n)/u(1), where u is a vector of polynomial coefficients. The
     *  eigenvalues of compan(u) are the roots of the polynomial.
     *
     */
    case PlasmaMatrixCompan:
    {
        int jj;

        LAPACKE_claset_work(LAPACK_COL_MAJOR, 'A', M, N, 0., 0., A, LDA);

        /* First row */
        if ( m0 == 0 ) {
            PLASMA_Complex32_t v0;
            /* Get V0 */
            CORE_cplrnt( 1, 1, &v0, 1, 1, 1, 0, seed );
            v0 = 1. / v0 ;

            /* Initialize random vector */
            CORE_cplrnt( 1, N, A, LDA, 1, 1, n0, seed );
            cblas_cscal( N, CBLAS_SADDR(v0), A, LDA);

            /* Restore A(0,0) */
            if ( n0 == 0 )
                A[0] = 0.;
        }

        /* Sub diagonal*/
        for (j=0,jj=n0; j<N; j++,jj++)
        {
            i = jj + 1 - m0;
            if ( ( i > 0 ) && (i < M) )
            {
                A[j*LDA+i] = 1.;
            }
        }
    }
    break;

    /*
     * See http://www.mathworks.fr/fr/help/matlab/ref/gallery.html#f84-1000232
     *
     * Matrix associated with the Riemann hypothesis
     *
     * Returns an n-by-n matrix for which the Riemann hypothesis is
     * true if and only if for every eps > 0.
     *
     * The Riemann matrix is defined by:
     *
     *    A = B(2:n+1,2:n+1)
     *
     *    where B(i,j) = i-1 if i divides j, and B(i,j) = -1 otherwise.
     *
     * The Riemann matrix has these properties:
     *     - Each eigenvalue e(i) satisfies abs(e(i)) <= m-1/m, where m = n+1.
     *     - i <= e(i) <= i+1 with at most m-sqrt(m) exceptions.
     *     - All integers in the interval (m/3, m/2] are eigenvalues.
     *
     */
    case PlasmaMatrixRiemann:
    {
        int ii, jj;
        for (j=0,jj=n0+2; j<N; j++,jj++) {
            for (i=0,ii=m0+2; i<M; i++,ii++) {
                if ( jj%ii == 0 ) {
                    A[j*LDA+i] = (PLASMA_Complex32_t)( ii - 1. );
                } else {
                    A[j*LDA+i] = (PLASMA_Complex32_t)( -1. );
                }
            }
        }
    }
    break;

    /*
     * See http://www.mathworks.fr/fr/help/matlab/ref/gallery.html#f84-1000049
     *
     * Symmetric positive definite matrix
     *
     * Returns the symmetric positive definite n-by-n matrix such that
     * A(i,j) = i/j for j >= i.
     *
     * The Lehmer matrix A has these properties:
     *     - A is totally nonnegative.
     *     - The inverse inv(A) is tridiagonal and explicitly known.
     *     - The order n <= cond(A) <= 4*n*n.Matrix associated with the
     *       Riemann hypothesis
     *
     */
     case PlasmaMatrixLehmer:
    {
        int ii, jj;
        for (j=0,jj=n0+1; j<N; j++,jj++) {
            for (i=0,ii=m0+1; i<M; i++,ii++) {
                if ( jj >= ii ) {
                    A[j*LDA+i] = (PLASMA_Complex32_t)( ii ) / (PLASMA_Complex32_t)( jj );
                } else {
                    A[j*LDA+i] = (PLASMA_Complex32_t)( jj ) / (PLASMA_Complex32_t)( ii );
                }
            }
        }
    }
    break;

    /*
     * See http://www.mathworks.fr/fr/help/matlab/ref/gallery.html#f84-1000066
     *
     * Symmetric positive definite matrix
     *
     * Returns the n-by-n symmetric positive definite matrix with
     * A(i,j) = min(i,j).
     *
     * The minij matrix has these properties:
     *     - The inverse inv(A) is tridiagonal and equal to -1 times the
     *       second difference matrix, except its (n,n) element is 1.
     *     - Givens' matrix, 2*A-ones(size(A)), has tridiagonal inverse
     *       and eigenvalues 0.5*sec((2*r-1)*pi/(4*n))^2, where r=1:n.
     *     - (n+1)*ones(size(A))-A has elements that are max(i,j) and a
     *       tridiagonal inverse.
     *
     */
    case PlasmaMatrixMinij:
    {
        int ii, jj;
        for (j=0,jj=n0+1; j<N; j++,jj++) {
            for (i=0,ii=m0+1; i<M; i++,ii++) {
                A[j*LDA+i] = (PLASMA_Complex32_t) min( ii, jj );
            }
        }
    }
    break;

    /*
     * See http://www.mathworks.fr/fr/help/matlab/ref/gallery.html#f84-999936
     *
     * Diagonally dominant, ill-conditioned, tridiagonal matrix
     *
     * Returns the n-by-n matrix, row diagonally dominant, tridiagonal
     * matrix that is ill-conditioned for small nonnegative values of
     * theta. The default value of theta is 0.01. The Dorr matrix
     * itself is the same as gallery('tridiag',c,d,e).
     *
     */
    case PlasmaMatrixDorr:
    {
        PLASMA_Complex32_t theta = 0.01;
        PLASMA_Complex32_t h     = 1. / ( gN + 1. );
        PLASMA_Complex32_t term  = theta / ( h * h );
        int jj;
        int half = (gN+1) / 2;

        LAPACKE_claset_work(LAPACK_COL_MAJOR, 'A', M, N, 0., 0., A, LDA);

        /* First half */
        for (j=0, jj=n0; (j<N) && (jj<half); j++, jj++) {
            i = jj - m0;
            if ( ( i < -1 ) || (i > M) )
                continue;

            /* Over the diagonal */
            if (i > 0)
                A[j*LDA + i-1] = - term - (0.5 - jj*h)/h;

            /* Diagonal */
            if ( i >= M )
                return PLASMA_SUCCESS;

            if ( i >=0 )
                A[j*LDA + i] = 2. * term + (0.5 - (jj+1) * h) / h;

            /* Below the diagonal */
            if (i+1 < M) {
                if (jj+1 == half)
                    A[j*LDA + i+1] = - term + (0.5 - (jj+2)*h)/h;
                else
                    A[j*LDA + i+1] = - term;
            }
        }

        /* Second half */
        for (; j<N; j++,jj++) {
            i = jj - m0;
            if ( ( i < -1 ) || (i > M))
                continue;

            if (i > 0) {
                if (jj == half)
                    A[j*LDA + i-1] = - term - (0.5 - jj*h)/h;
                else
                    A[j*LDA + i-1] = - term;
            }

            if ((i >=0) && (i < M))
                A[j*LDA + i] = 2. * term - (0.5 - (jj+1)*h)/h;

            if (i+1 < M)
                A[j*LDA + i+1] = - term + (0.5 - (jj+2)*h)/h;
        }
    }
    break;

    /*
     * See [1] J. Demmel, Applied Numerical Linear Algebra, SIAM,
     *         Philadelphia, 1997
     *
     * Returns a matrix defined by:
     *    A = D * ( I + 1e-7* rand(n)), where D = diag(10^{14*(0:n-1)/n})
     *
     */
    case PlasmaMatrixDemmel:
    {
        PLASMA_Complex32_t dii;
        int ii, jj;

        /* Randomize the matrix */
        CORE_cplrnt( M, N, A, LDA, gM, m0, n0, seed );

        for (j=0,jj=n0; j<N; j++,jj++) {
            for (i=0,ii=m0; i<M; i++,ii++) {
                dii = cpowf( 10. , 14. * ii / gM );
                A[j*LDA+i] *= dii * ( (jj == ii) ? 1. : 1.e-7 );
            }
        }
    }
    break;

    /*
     * See http://www.mathworks.fr/fr/help/matlab/ref/gallery.html#f84-1000000
     *
     * Inverse of an upper Hessenberg matrix
     *
     * A = gallery('invhess',x,y), where x is a length n vector and y
     * is a length n-1 vector, returns the matrix whose lower triangle
     * agrees with that of ones(n,1)*x' and whose strict upper
     * triangle agrees with that of [1 y]*ones(1,n).
     *
     * The matrix is nonsingular if x(1) ~= 0 and x(i+1) ~= y(i) for
     * all i, and its inverse is an upper Hessenberg matrix. Argument
     * y defaults to -x(1:n-1).
     *
     * If x is a scalar, invhess(x) is the same as invhess(1:x).
     *
     * Here: gallery('invhess', gM)
     */
    case PlasmaMatrixInvhess:
    {
        int ii, jj;
        for (j=0,jj=n0+1; j<N; j++,jj++) {
            for (i=0,ii=m0+1; i<M; i++,ii++) {
                if ( jj <= ii ) {
                    A[j*LDA+i] = (PLASMA_Complex32_t)( jj );
                } else {
                    A[j*LDA+i] = (PLASMA_Complex32_t)( -ii );
                }
            }
        }
    }
    break;

    /*
     * See http://www.mathworks.fr/fr/help/matlab/ref/gallery.html#f84-1019317
     *
     * Cauchy matrix
     *
     * Returns an n-by-n matrix C such that, C(i,j) = 1/(i + j).
     *
     */
    case PlasmaMatrixCauchy:
    {
        int ii, jj;
        for (j=0,jj=n0+1; j<N; j++,jj++) {
            for (i=0,ii=m0+1; i<M; i++,ii++) {
                A[j*LDA+i] = (PLASMA_Complex32_t)( 1. ) / (PLASMA_Complex32_t)( ii+jj );
            }
        }
    }
    break;

    /*
     * See http://www.mathworks.fr/fr/help/matlab/ref/hilb.html
     *
     * Hilbert Matrix
     *
     * The Hilbert matrix is a notable example of a poorly conditioned
     * matrix. The elements of the Hilbert matrices are:
     *   H(i,j) = 1/(i * + j – 1).
     *
     */
    case PlasmaMatrixHilb:
    {
        PLASMA_Complex32_t tmp = (PLASMA_Complex32_t)( m0 + n0 + 1. );
        for (j=0; j<N; j++) {
            for (i=0; i<M; i++) {
                A[j*LDA+i] = (PLASMA_Complex32_t)1. / (PLASMA_Complex32_t)( tmp + i + j );
            }
        }
    }
    break;

    /*
     * See http://www.mathworks.fr/fr/help/matlab/ref/gallery.html#f84-1000062
     *
     * Lotkin matrix
     *
     * Returns the Hilbert matrix with its first row altered to all
     * ones. The Lotkin matrix A is nonsymmetric, ill-conditioned, and
     * has many negative eigenvalues of small magnitude. Its inverse
     * has integer entries and is known explicitly.
     *
     */
    case PlasmaMatrixLotkin:
    {
        PLASMA_Complex32_t tmp = (PLASMA_Complex32_t)( m0 + n0 + 1. );
        if (m0 == 0) {
            for (j=0; j<N; j++) {
                A[j*LDA] = (PLASMA_Complex32_t)1.;
                for (i=1; i<M; i++) {
                    A[j*LDA+i] = (PLASMA_Complex32_t)1. / (PLASMA_Complex32_t)( tmp + i + j );
                }
            }
        } else {
            for (j=0; j<N; j++) {
                for (i=0; i<M; i++) {
                    A[j*LDA+i] = (PLASMA_Complex32_t)1. / (PLASMA_Complex32_t)( tmp + i + j );
                }
            }
        }
    }
    break;

    /*
     * See http://www.mathworks.fr/fr/help/matlab/ref/gallery.html#f84-1000083
     *
     * Orthogonal and nearly orthogonal matrices
     *
     * Returns the matrix Q of order n, such that:
     *    Q(i,j) = sqrt(2/(n+1)) * sin(i*j*pi/(n+1))
     *
     * Symmetric eigenvector matrix for second difference matrix.
     *
     */
    case PlasmaMatrixOrthog: /* Default: k=1 */
    {
        PLASMA_Complex32_t sqrtn = (PLASMA_Complex32_t) sqrt( 2. / (gN+1.) );
        float scale = pi / (float)(gN+1.);

        int ii, jj;
        for (j=0,jj=n0+1; j<N; j++,jj++) {
            for (i=0,ii=m0+1; i<M; i++,ii++) {
                A[j*LDA+i] = sqrtn * (PLASMA_Complex32_t) sin( (float)ii * (float)jj * scale );
            }
        }
    }
    break;

     /*
     * See http://www.mathworks.fr/fr/help/matlab/ref/wilkinson.html
     *
     * Wilkinson's eigenvalue test matrix
     *
     * Returns one of J. H. Wilkinson's eigenvalue test matrices. It
     * is a symmetric, tridiagonal matrix with pairs of nearly, but
     * not exactly, equal eigenvalues.
     *
     */
   case PlasmaMatrixWilkinson:
    {
        if (gM != gN) {
            coreblas_error(6, "Illegal value of gM (Matrix must be square for Wilkinson)");
            return -6;
        }

        int ii, jj;
        for (j=0,jj=n0; j<N; j++,jj++) {
            for (i=0,ii=m0; i<M; i++,ii++) {
                if (ii == jj) {
                    PLASMA_Complex32_t tmp = (PLASMA_Complex32_t)(( (gN - 1 - ii) < ii ) ? gN - 1 - ii : ii );
                     A[j*LDA+i] = (PLASMA_Complex32_t)(gN - 2. * tmp - 1.) / 2.;
                }
                else if ( (ii == jj+1) || (ii == jj-1) ) {
                     A[j*LDA+i] = (PLASMA_Complex32_t)1.;
                }
                else {
                     A[j*LDA+i] = (PLASMA_Complex32_t)0.;
                }
           }
       }
    }
    break;

    /*
     * See [1] L. V. Foster, Gaussian Elimination with Partial
     *         Pivoting Can Fail in Practice, SIAM J. Matrix
     *         Anal. Appl., 15 (1994), pp. 1354-1362.
     *
     *     [2] L. V. Foster, The growth factor and efficiency of
     *         Gaussian elimination with rook pivoting,
     *         J. Comput. Appl. Math., 86 (1997), pp. 177-194
     *
     * A pathological case for LU with gaussian elimination.
     *
     */
    case PlasmaMatrixFoster: /* Default: k=h=c=1 */
    {
        float k=1., h=1., c=1.;

        int ii, jj;
        for (j=0,jj=n0; j<N; j++,jj++) {
            for (i=0,ii=m0; i<M; i++,ii++) {

                if (ii == jj) {
                    if (jj == 0)
                        A[j*LDA+i] = (PLASMA_Complex32_t)1.;
                    else if (jj == gN-1)
                        A[j*LDA+i] = (PLASMA_Complex32_t)(1. - (1. / c) - (k*h)/2. );
                    else
                        A[j*LDA+i] = (PLASMA_Complex32_t)(1. - (k*h)/2. );
                }
                else if (jj == 0) {
                    A[j*LDA+i] = (PLASMA_Complex32_t)(-k*h/2.);
                }
                else if (jj == gN-1) {
                    A[j*LDA+i] = (PLASMA_Complex32_t)(-1./c);
                }
                else if (ii > jj) {
                    A[j*LDA+i] = (PLASMA_Complex32_t)(-k*h);
                }
                else {
                    A[j*LDA+i] = (PLASMA_Complex32_t)0.;
                }
            }
        }
    }
    break;

    /*
     * See [3] S. J. Wright, A collection of problems for which
     *         Gaussian elimination with partial pivoting is unstable,
     *         SIAM J. SCI. STATIST. COMPUT., 14 (1993), pp. 231-238.
     *
     * A pathological case for LU with gaussian elimination.
     *
     */
    /*
     * Default: h=0.01, M=[-10 -19, 19 30]. Then,
     *   exp(h*M)=[0.9048 0.8270, 1.2092 1.3499]
     */
    case PlasmaMatrixWright:
    {
        int ii, jj;
        for (j=0,jj=n0; j<N; j++,jj++) {
            for (i=0,ii=m0; i<M; i++,ii++) {

                if (ii == jj)
                    A[j*LDA+i] = (PLASMA_Complex32_t)1.;
                else if ((ii == jj + 2) && (jj % 2 == 0))
                    A[j*LDA+i] = (PLASMA_Complex32_t)(-0.9048);
                else if ((ii == jj + 3) && (jj % 2 == 0))
                    A[j*LDA+i] = (PLASMA_Complex32_t)(-1.2092);
                else if ((ii == jj + 2) && (jj % 2 == 1))
                    A[j*LDA+i] = (PLASMA_Complex32_t)(-0.8270);
                else if ((ii == jj + 3) && (jj % 2 == 1))
                    A[j*LDA+i] = (PLASMA_Complex32_t)(-1.3499);
                else if ((jj == gM-2) && (ii == 0))
                    A[j*LDA+i] = (PLASMA_Complex32_t)1.;
                else if ((jj == gM-1) && (ii == 1))
                    A[j*LDA+i] = (PLASMA_Complex32_t)1.;
                else
                    A[j*LDA+i] = (PLASMA_Complex32_t)0.;
            }
        }
    }
    break;

    /*
     * Generates a pathological case for LU with gaussian elimination.
     *
     * Returns a random matrix on which, the columns from N/4 to N/2
     * are scaled down by eps.
     * These matrices fails on LU with partial pivoting, but Hybrid
     * LU-QR algorithms manage to recover the scaled down columns.
     *
     */
    case PlasmaMatrixLangou:
    {
        PLASMA_Complex32_t eps = (PLASMA_Complex32_t) LAPACKE_slamch_work( 'e' );
        int ii, jj, mm, minMN;
        int firstcol, lastcol;

         /* Create random tile */
         CORE_cplrnt( M, N, A, LDA, gM, m0, n0, seed );

         /* Scale down the columns gN/4 to gN/2 below the diagonal */
         minMN = min( gM, gN );
         firstcol = minMN / 4;
         lastcol  = minMN / 2;

         if ( (m0 >= n0) && ((n0+N) >= firstcol ) && (n0 < lastcol) ) {

             jj = max( n0, firstcol );
             j = jj - n0;

             for (; j<N && jj < lastcol; j++,jj++) {

                 ii = max( m0, jj );
                 i  = ii - m0;
                 mm = M - i;
                 cblas_cscal( mm, CBLAS_SADDR(eps), A + j*LDA + i, 1);
             }
         }
    }
    break;

    default:
        coreblas_error(1, "Illegal value of mtxtype");
        return -1;
    }

    return PLASMA_SUCCESS;
}


/* specfunc/coupling.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., 675 Mass Ave, Cambridge, MA 02139, USA.
 */

/* Author:  G. Jungman */

#include <config.h>
#include <stdlib.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_errno.h>
#include "gsl_sf_gamma.h"
#include "gsl_sf_coupling.h"

#include "error.h"

inline
static
int locMax3(const int a, const int b, const int c)
{
  int d = GSL_MAX(a, b);
  return GSL_MAX(d, c);
}

inline
static
int locMin3(const int a, const int b, const int c)
{
  int d = GSL_MIN(a, b);
  return GSL_MIN(d, c);
}

inline
static
int locMin5(const int a, const int b, const int c, const int d, const int e)
{
  int f = GSL_MIN(a, b);
  int g = GSL_MIN(c, d);
  int h = GSL_MIN(f, g);
  return GSL_MIN(e, h);
}

/* See: [Thompson, Atlas for Computing Mathematical Functions] */

static
int
delta(int ta, int tb, int tc, gsl_sf_result * d)
{
  gsl_sf_result f1, f2, f3, f4;
  int status = 0;
  status += gsl_sf_fact_e((ta + tb - tc)/2, &f1);
  status += gsl_sf_fact_e((ta + tc - tb)/2, &f2);
  status += gsl_sf_fact_e((tb + tc - ta)/2, &f3);
  status += gsl_sf_fact_e((ta + tb + tc)/2 + 1, &f4);
  if(status != 0) {
    OVERFLOW_ERROR(d);
  }
  d->val = f1.val * f2.val * f3.val / f4.val;
  d->err = 4.0 * GSL_DBL_EPSILON * fabs(d->val);
  return GSL_SUCCESS;
}

static
int
triangle_selection_fails(int two_ja, int two_jb, int two_jc)
{
  return ((two_jb < abs(two_ja - two_jc)) || (two_jb > two_ja + two_jc));
}

static
int
m_selection_fails(int two_ja, int two_jb, int two_jc,
                  int two_ma, int two_mb, int two_mc)
{
  return (   abs(two_ma) > two_ja
          || abs(two_mb) > two_jb
	  || abs(two_mc) > two_jc
	  || GSL_IS_ODD(two_ja + two_ma)
	  || GSL_IS_ODD(two_jb + two_mb)
	  || GSL_IS_ODD(two_jc + two_mc)
          || (two_ma + two_mb + two_mc) != 0
	  );
}

/*-*-*-*-*-*-*-*-*-*-*-* Functions with Error Codes *-*-*-*-*-*-*-*-*-*-*-*/

int
gsl_sf_coupling_3j_e(int two_ja, int two_jb, int two_jc,
                        int two_ma, int two_mb, int two_mc,
			gsl_sf_result * result)
{
  /* CHECK_POINTER(result) */

  if(two_ja < 0 || two_jb < 0 || two_jc < 0) {
    DOMAIN_ERROR(result);
  }
  else if(   triangle_selection_fails(two_ja, two_jb, two_jc)
          || m_selection_fails(two_ja, two_jb, two_jc, two_ma, two_mb, two_mc)
     ) {
    result->val = 0.0;
    result->err = 0.0;
    return GSL_SUCCESS;
  }
  else {
    gsl_sf_result n1_a, n1_b, n3_a, n3_b;
    gsl_sf_result d1_a, d1_b, d2_a, d2_b, d3_a, d3_b;
    gsl_sf_result n1, n2, n3;
    gsl_sf_result d1, d2, d3;
    double norm;
    double sign = (GSL_IS_ODD((two_ja - two_jb - two_mc)/2) ? -1.0 : 1.0);
    int tk, tkmin, tkmax;
    double sum_pos = 0.0;
    double sum_neg = 0.0;
    double phase;
    int status = 0;
    status += gsl_sf_fact_e((two_jc + two_ja - two_jb)/2, &n1_a);
    status += gsl_sf_fact_e((two_jc - two_ja + two_jb)/2, &n1_b);
    status += gsl_sf_fact_e((two_ja + two_jb - two_jc)/2, &n2);
    status += gsl_sf_fact_e((two_jc - two_mc)/2, &n3_a);
    status += gsl_sf_fact_e((two_jc + two_mc)/2, &n3_b);
    status += gsl_sf_fact_e((two_ja + two_jb + two_jc)/2 + 1, &d1);
    status += gsl_sf_fact_e((two_ja - two_ma)/2, &d2_a);
    status += gsl_sf_fact_e((two_ja + two_ma)/2, &d2_b);
    status += gsl_sf_fact_e((two_jb - two_mb)/2, &d3_a);
    status += gsl_sf_fact_e((two_jb + two_mb)/2, &d3_b);

    if(status != 0) {
      OVERFLOW_ERROR(result);
    }

    n1.val = n1_a.val * n1_b.val;
    n3.val = n3_a.val * n3_b.val;
    d2.val = d2_a.val * d2_b.val;
    d3.val = d3_a.val * d3_b.val;

    norm = sign * sqrt(n1.val*n2.val*n3.val)/sqrt(d1.val*d2.val*d3.val);

    tkmin = GSL_MAX(0, two_jb - two_ja - two_mc);
    tkmax = GSL_MIN(two_jc - two_ja + two_jb, two_jc - two_mc);

    phase = GSL_IS_ODD((tkmin + two_jb + two_mb)/2) ? -1.0 : 1.0;

    for(tk=tkmin; tk<=tkmax; tk += 2) {
      double term;

      status = 0;
      status += gsl_sf_fact_e((two_jb + two_jc + two_ma - tk)/2, &n1);
      status += gsl_sf_fact_e((two_ja - two_ma + tk)/2, &n2);
      status += gsl_sf_fact_e(tk/2, &d1_a);
      status += gsl_sf_fact_e((two_jc - two_ja + two_jb - tk)/2, &d1_b);
      status += gsl_sf_fact_e((two_jc - two_mc - tk)/2, &d2);
      status += gsl_sf_fact_e((two_ja - two_jb + two_mc + tk)/2, &d3);

      if(status != 0) {
        OVERFLOW_ERROR(result);
      }

      d1.val = d1_a.val * d1_b.val;

      term = phase * n1.val * n2.val / (d1.val * d2.val * d3.val);
      phase = -phase;

      if(norm*term >= 0.0) {
        sum_pos += norm*term;
      }
      else {
        sum_neg -= norm*term;
      }
    }

    result->val  = sum_pos - sum_neg;
    result->err  = 2.0 * GSL_DBL_EPSILON * (sum_pos + sum_neg);
    result->err += 2.0 * GSL_DBL_EPSILON * (tkmax - tkmin) * fabs(result->val);

    return GSL_SUCCESS;
  }
}

int
gsl_sf_coupling_6j_e(int two_ja, int two_jb, int two_jc,
                        int two_jd, int two_je, int two_jf,
			gsl_sf_result * result)
{
  /* CHECK_POINTER(result) */

  if(   two_ja < 0 || two_jb < 0 || two_jc < 0
     || two_jd < 0 || two_je < 0 || two_je < 0
     ) {
    DOMAIN_ERROR(result);
  }
  else if(   triangle_selection_fails(two_ja, two_jb, two_je)
          || triangle_selection_fails(two_ja, two_jc, two_jf)
          || triangle_selection_fails(two_jb, two_jd, two_jf)
          || triangle_selection_fails(two_jc, two_jd, two_je)
     ) {
    result->val = 0.0;
    result->err = 0.0;
    return GSL_SUCCESS;
  }
  else {
    gsl_sf_result n1;
    gsl_sf_result d1, d2, d3, d4, d5, d6;
    double norm;
    int tk, tkmin, tkmax;
    double phase;
    double sum_pos = 0.0;
    double sum_neg = 0.0;
    double sumsq_err = 0.0;
    int status = 0;
    status += delta(two_ja, two_jb, two_je, &d1);
    status += delta(two_ja, two_jc, two_jf, &d2);
    status += delta(two_jb, two_jd, two_jf, &d3);
    status += delta(two_jc, two_jd, two_je, &d4);
    if(status != GSL_SUCCESS) {
      OVERFLOW_ERROR(result);
    }
    norm = sqrt(d1.val) * sqrt(d2.val) * sqrt(d3.val) * sqrt(d4.val);

    tkmin = locMax3(0,
                   two_ja + two_jd - two_je - two_jf,
                   two_jb + two_jc - two_je - two_jf);

    tkmax = locMin5(two_ja + two_jb + two_jc + two_jd + 2,
                    two_ja + two_jb - two_je,
		    two_jc + two_jd - two_je,
		    two_ja + two_jc - two_jf,
		    two_jb + two_jd - two_jf);

    phase = GSL_IS_ODD((two_ja + two_jb + two_jc + two_jd + tkmin)/2)
            ? -1.0
	    :  1.0;

    for(tk=tkmin; tk<=tkmax; tk += 2) {
      double term;
      double term_err;
      gsl_sf_result den_1, den_2;
      gsl_sf_result d1_a, d1_b;
      status = 0;

      status += gsl_sf_fact_e((two_ja + two_jb + two_jc + two_jd - tk)/2 + 1, &n1);
      status += gsl_sf_fact_e(tk/2, &d1_a);
      status += gsl_sf_fact_e((two_je + two_jf - two_ja - two_jd + tk)/2, &d1_b);
      status += gsl_sf_fact_e((two_je + two_jf - two_jb - two_jc + tk)/2, &d2);
      status += gsl_sf_fact_e((two_ja + two_jb - two_je - tk)/2, &d3);
      status += gsl_sf_fact_e((two_jc + two_jd - two_je - tk)/2, &d4);
      status += gsl_sf_fact_e((two_ja + two_jc - two_jf - tk)/2, &d5);
      status += gsl_sf_fact_e((two_jb + two_jd - two_jf - tk)/2, &d6);

      if(status != GSL_SUCCESS) {
        OVERFLOW_ERROR(result);
      }

      d1.val = d1_a.val * d1_b.val;
      d1.err = d1_a.err * fabs(d1_b.val) + fabs(d1_a.val) * d1_b.err;

      den_1.val  = d1.val*d2.val*d3.val;
      den_1.err  = d1.err * fabs(d2.val*d3.val);
      den_1.err += d2.err * fabs(d1.val*d3.val);
      den_1.err += d3.err * fabs(d1.val*d2.val);

      den_2.val  = d4.val*d5.val*d6.val;
      den_2.err  = d4.err * fabs(d5.val*d6.val);
      den_2.err += d5.err * fabs(d4.val*d6.val);
      den_2.err += d6.err * fabs(d4.val*d5.val);

      term  = phase * n1.val / den_1.val / den_2.val;
      phase = -phase;
      term_err  = n1.err / fabs(den_1.val) / fabs(den_2.val);
      term_err += fabs(term / den_1.val) * den_1.err;
      term_err += fabs(term / den_2.val) * den_2.err;

      if(term >= 0.0) {
        sum_pos += norm*term;
      }
      else {
        sum_neg -= norm*term;
      }

      sumsq_err += norm*norm * term_err*term_err;
    }

    result->val  = sum_pos - sum_neg;
    result->err  = 2.0 * GSL_DBL_EPSILON * (sum_pos + sum_neg);
    result->err += sqrt(sumsq_err / (0.5*(tkmax-tkmin)+1.0));
    result->err += 2.0 * GSL_DBL_EPSILON * (tkmax - tkmin + 2.0) * fabs(result->val);

    return GSL_SUCCESS;
  }
}

int
gsl_sf_coupling_9j_e(int two_ja, int two_jb, int two_jc,
                        int two_jd, int two_je, int two_jf,
			int two_jg, int two_jh, int two_ji,
			gsl_sf_result * result)
{
  /* CHECK_POINTER(result) */

  if(   two_ja < 0 || two_jb < 0 || two_jc < 0
     || two_jd < 0 || two_je < 0 || two_jf < 0
     || two_jg < 0 || two_jh < 0 || two_ji < 0
     ) {
    DOMAIN_ERROR(result);
  }
  else if(   triangle_selection_fails(two_ja, two_jb, two_jc)
          || triangle_selection_fails(two_jd, two_je, two_jf)
          || triangle_selection_fails(two_jg, two_jh, two_ji)
          || triangle_selection_fails(two_ja, two_jd, two_jg)
          || triangle_selection_fails(two_jb, two_je, two_jh)
          || triangle_selection_fails(two_jc, two_jf, two_ji)
     ) {
    result->val = 0.0;
    result->err = 0.0;
    return GSL_SUCCESS;
  }
  else {
    int tk;
    int tkmin = locMax3(abs(two_ja-two_ji), abs(two_jh-two_jd), abs(two_jb-two_jf));
    int tkmax = locMin3(two_ja + two_ji, two_jh + two_jd, two_jb + two_jf);
    double sum_pos = 0.0;
    double sum_neg = 0.0;
    double sumsq_err = 0.0;
    double phase;
    for(tk=tkmin; tk<=tkmax; tk += 2) {
      gsl_sf_result s1, s2, s3;
      double term;
      double term_err;
      int status = 0;
      status += gsl_sf_coupling_6j_e(two_ja, two_ji, two_jd,  two_jh, tk, two_jg,  &s1);
      status += gsl_sf_coupling_6j_e(two_jb, two_jf, two_jh,  two_jd, tk, two_je,  &s2);
      status += gsl_sf_coupling_6j_e(two_ja, two_ji, two_jb,  two_jf, tk, two_jc,  &s3);
      if(status != GSL_SUCCESS) {
        OVERFLOW_ERROR(result);
      }
      term = s1.val * s2.val * s3.val;
      term_err  = s1.err * fabs(s2.val*s3.val);
      term_err += s2.err * fabs(s1.val*s3.val);
      term_err += s3.err * fabs(s1.val*s2.val);

      if(term >= 0.0) {
        sum_pos += (tk + 1) * term;
      }
      else {
        sum_neg -= (tk + 1) * term;
      }

      sumsq_err += ((tk+1) * term_err) * ((tk+1) * term_err);
    }

    phase = GSL_IS_ODD(tkmin) ? -1.0 : 1.0;

    result->val  = phase * (sum_pos - sum_neg);
    result->err  = 2.0 * GSL_DBL_EPSILON * (sum_pos + sum_neg);
    result->err += sqrt(sumsq_err / (0.5*(tkmax-tkmin)+1.0));
    result->err += 2.0 * GSL_DBL_EPSILON * (tkmax-tkmin + 2.0) * fabs(result->val);

    return GSL_SUCCESS;
  }
}

/*-*-*-*-*-*-*-*-*-* Functions w/ Natural Prototypes *-*-*-*-*-*-*-*-*-*-*/

#include "eval.h"

double gsl_sf_coupling_3j(int two_ja, int two_jb, int two_jc,
                          int two_ma, int two_mb, int two_mc)
{
  EVAL_RESULT(gsl_sf_coupling_3j_e(two_ja, two_jb, two_jc,
                                   two_ma, two_mb, two_mc,
                                   &result));
}

double gsl_sf_coupling_6j(int two_ja, int two_jb, int two_jc,
                          int two_jd, int two_je, int two_jf)
{
  EVAL_RESULT(gsl_sf_coupling_6j_e(two_ja, two_jb, two_jc,
                                   two_jd, two_je, two_jf,
                                   &result));
}

double gsl_sf_coupling_9j(int two_ja, int two_jb, int two_jc,
                          int two_jd, int two_je, int two_jf,
                          int two_jg, int two_jh, int two_ji)
{
  EVAL_RESULT(gsl_sf_coupling_9j_e(two_ja, two_jb, two_jc,
                                   two_jd, two_je, two_jf,
                                   two_jg, two_jh, two_ji,
                                   &result));
}


/* interpolation/interp2d.c
 *
 * Copyright 2012 David Zaslavsky
 *
 * 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.
 */

#include <config.h>
#include <stdlib.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_interp.h>
#include <gsl/gsl_interp2d.h>

/**
 * Triggers a GSL error if the argument is not equal to GSL_SUCCESS.
 * If the argument is GSL_SUCCESS, this does nothing.
 */
#define DISCARD_STATUS(s) if ((s) != GSL_SUCCESS) { GSL_ERROR_VAL("interpolation error", (s),  GSL_NAN); }

#define IDX2D(i, j, w) ((j) * ((w)->xsize) + (i))

gsl_interp2d *
gsl_interp2d_alloc(const gsl_interp2d_type * T, const size_t xsize,
                   const size_t ysize)
{
  gsl_interp2d * interp;

  if (xsize < T->min_size || ysize < T->min_size)
    {
      GSL_ERROR_NULL ("insufficient number of points for interpolation type",
                      GSL_EINVAL);
    }

  interp = (gsl_interp2d *) calloc(1, sizeof(gsl_interp2d));
  if (interp == NULL)
    {
      GSL_ERROR_NULL ("failed to allocate space for gsl_interp2d struct",
                      GSL_ENOMEM);
    }

  interp->type = T;
  interp->xsize = xsize;
  interp->ysize = ysize;

  if (interp->type->alloc == NULL)
    {
      interp->state = NULL;
      return interp;
    }

  interp->state = interp->type->alloc(xsize, ysize);
  if (interp->state == NULL)
    {
      free(interp);
      GSL_ERROR_NULL ("failed to allocate space for gsl_interp2d state",
                      GSL_ENOMEM);
    }

  return interp;
} /* gsl_interp2d_alloc() */

void
gsl_interp2d_free (gsl_interp2d * interp)
{
  RETURN_IF_NULL(interp);

  if (interp->type->free)
    interp->type->free(interp->state);

  free(interp);
} /* gsl_interp2d_free() */

int
gsl_interp2d_init (gsl_interp2d * interp, const double xarr[], const double yarr[],
                   const double zarr[], const size_t xsize, const size_t ysize)
{
  size_t i;

  if (xsize != interp->xsize || ysize != interp->ysize)
    {
      GSL_ERROR("data must match size of interpolation object", GSL_EINVAL);
    }

  for (i = 1; i < xsize; i++)
    {
      if (xarr[i-1] >= xarr[i])
        {
          GSL_ERROR("x values must be strictly increasing", GSL_EINVAL);
        }
    }

  for (i = 1; i < ysize; i++)
    {
      if (yarr[i-1] >= yarr[i])
        {
          GSL_ERROR("y values must be strictly increasing", GSL_EINVAL);
        }
    }

  interp->xmin = xarr[0];
  interp->xmax = xarr[xsize - 1];
  interp->ymin = yarr[0];
  interp->ymax = yarr[ysize - 1];

  {
    int status = interp->type->init(interp->state, xarr, yarr, zarr,
                                    xsize, ysize);
    return status;
  }
} /* gsl_interp2d_init() */

/*
 * A wrapper function that checks boundary conditions, calls an evaluator
 * which implements the actual calculation of the function value or
 * derivative etc., and checks the return status.
 */
static int
interp2d_eval(int (*evaluator)(const void *, const double xa[], const double ya[],
                               const double za[], size_t xsize, size_t ysize,
                               double x, double y, gsl_interp_accel *,
                               gsl_interp_accel *, double * z),
              const gsl_interp2d * interp, const double xarr[],
              const double yarr[], const double zarr[],
              const double x, const double y,
              gsl_interp_accel * xa, gsl_interp_accel * ya,
              double * result)
{
  if (x < interp->xmin || x > interp->xmax)
    {
      GSL_ERROR ("interpolation x value out of range", GSL_EDOM);
    }
  else if (y < interp->ymin || y > interp->ymax)
    {
      GSL_ERROR ("interpolation y value out of range", GSL_EDOM);
    }

  return evaluator(interp->state, xarr, yarr, zarr,
                   interp->xsize, interp->ysize,
                   x, y, xa, ya, result);
}

/*
 * Another wrapper function that serves as a drop-in replacement for
 * interp2d_eval but does not check the bounds. This can be used
 * for extrapolation.
 */
static int
interp2d_eval_extrap(int (*evaluator)(const void *, const double xa[],
                                      const double ya[], const double za[],
                                      size_t xsize, size_t ysize,
                                      double x, double y,
                                      gsl_interp_accel *,
                                      gsl_interp_accel *, double * z),
                     const gsl_interp2d * interp, const double xarr[],
                     const double yarr[], const double zarr[],
                     const double x, const double y,
                     gsl_interp_accel * xa, gsl_interp_accel * ya,
                     double * result)
{
  return evaluator(interp->state, xarr, yarr, zarr,
                   interp->xsize, interp->ysize, x, y, xa, ya, result);
}

double
gsl_interp2d_eval (const gsl_interp2d * interp, const double xarr[],
                   const double yarr[], const double zarr[],
                   const double x, const double y,
                   gsl_interp_accel * xa, gsl_interp_accel * ya)
{
  double z;
  int status = gsl_interp2d_eval_e(interp, xarr, yarr, zarr, x, y, xa, ya, &z);
  DISCARD_STATUS(status)
  return z;
} /* gsl_interp2d_eval() */

double
gsl_interp2d_eval_extrap (const gsl_interp2d * interp,
                          const double xarr[],
                          const double yarr[],
                          const double zarr[],
                          const double x,
                          const double y,
                          gsl_interp_accel * xa,
                          gsl_interp_accel * ya)
{
  double z;
  int status =
    interp2d_eval_extrap(interp->type->eval, interp,
                         xarr, yarr, zarr, x, y, xa, ya, &z);
  DISCARD_STATUS(status)
  return z;
}

int
gsl_interp2d_eval_e (const gsl_interp2d * interp, const double xarr[],
                     const double yarr[], const double zarr[],
                     const double x, const double y,
                     gsl_interp_accel * xa, gsl_interp_accel * ya, double * z)
{
  return interp2d_eval(interp->type->eval, interp,
                       xarr, yarr, zarr, x, y, xa, ya, z);
} /* gsl_interp2d_eval_e() */

int
gsl_interp2d_eval_e_extrap (const gsl_interp2d * interp,
                            const double xarr[], const double yarr[],
                            const double zarr[], const double x,
                            const double y, gsl_interp_accel * xa,
                            gsl_interp_accel * ya, double * z)
{
  return interp2d_eval_extrap(interp->type->eval, interp,
                              xarr, yarr, zarr, x, y, xa, ya, z);
}

double
gsl_interp2d_eval_deriv_x (const gsl_interp2d * interp, const double xarr[],
                           const double yarr[], const double zarr[],
                           const double x, const double y,
                           gsl_interp_accel * xa, gsl_interp_accel * ya)
{
  double z;
  int status = gsl_interp2d_eval_deriv_x_e(interp, xarr, yarr, zarr, x, y, xa, ya, &z);
  DISCARD_STATUS(status)
  return z;
}

int
gsl_interp2d_eval_deriv_x_e (const gsl_interp2d * interp, const double xarr[],
                             const double yarr[], const double zarr[],
                             const double x, const double y,
                             gsl_interp_accel * xa, gsl_interp_accel * ya, double * z)
{
  return interp2d_eval(interp->type->eval_deriv_x, interp,
                       xarr, yarr, zarr, x, y, xa, ya, z);
}

double
gsl_interp2d_eval_deriv_y (const gsl_interp2d * interp, const double xarr[],
                           const double yarr[], const double zarr[],
                           const double x, const double y,
                           gsl_interp_accel * xa, gsl_interp_accel * ya)
{
  double z;
  int status = gsl_interp2d_eval_deriv_y_e(interp, xarr, yarr, zarr, x, y, xa, ya, &z);
  DISCARD_STATUS(status)
  return z;
}

int
gsl_interp2d_eval_deriv_y_e (const gsl_interp2d * interp, const double xarr[],
                             const double yarr[], const double zarr[],
                             const double x, const double y,
                             gsl_interp_accel * xa, gsl_interp_accel * ya, double * z)
{
  return interp2d_eval(interp->type->eval_deriv_y, interp,
                       xarr, yarr, zarr, x, y, xa, ya, z);
}

double
gsl_interp2d_eval_deriv_xx (const gsl_interp2d * interp, const double xarr[],
                            const double yarr[], const double zarr[],
                            const double x, const double y,
                            gsl_interp_accel * xa, gsl_interp_accel * ya)
{
  double z;
  int status = gsl_interp2d_eval_deriv_xx_e(interp, xarr, yarr, zarr, x, y, xa, ya, &z);
  DISCARD_STATUS(status)
  return z;
}

int
gsl_interp2d_eval_deriv_xx_e (const gsl_interp2d * interp, const double xarr[],
                              const double yarr[], const double zarr[],
                              const double x, const double y,
                              gsl_interp_accel * xa, gsl_interp_accel * ya, double * z)
{
  return interp2d_eval(interp->type->eval_deriv_xx, interp,
                       xarr, yarr, zarr, x, y, xa, ya, z);
}

double
gsl_interp2d_eval_deriv_yy (const gsl_interp2d * interp, const double xarr[],
                            const double yarr[], const double zarr[],
                            const double x, const double y,
                            gsl_interp_accel * xa, gsl_interp_accel * ya)
{
  double z;
  int status = gsl_interp2d_eval_deriv_yy_e(interp, xarr, yarr, zarr, x, y, xa, ya, &z);
  DISCARD_STATUS(status)
  return z;
}

int
gsl_interp2d_eval_deriv_yy_e (const gsl_interp2d * interp, const double xarr[],
                              const double yarr[], const double zarr[],
                              const double x, const double y,
                              gsl_interp_accel * xa, gsl_interp_accel * ya, double * z)
{
  return interp2d_eval(interp->type->eval_deriv_yy, interp,
                       xarr, yarr, zarr, x, y, xa, ya, z);
}

double
gsl_interp2d_eval_deriv_xy (const gsl_interp2d * interp, const double xarr[],
                            const double yarr[], const double zarr[],
                            const double x, const double y,
                            gsl_interp_accel * xa, gsl_interp_accel * ya)
{
  double z;
  int status = gsl_interp2d_eval_deriv_xy_e(interp, xarr, yarr, zarr, x, y, xa, ya, &z);
  DISCARD_STATUS(status)
  return z;
}

int
gsl_interp2d_eval_deriv_xy_e (const gsl_interp2d * interp, const double xarr[],
                              const double yarr[], const double zarr[],
                              const double x, const double y,
                              gsl_interp_accel * xa, gsl_interp_accel * ya, double * z)
{
  return interp2d_eval(interp->type->eval_deriv_xy, interp,
                       xarr, yarr, zarr, x, y, xa, ya, z);
}

size_t
gsl_interp2d_type_min_size(const gsl_interp2d_type * T)
{
  return T->min_size;
}

size_t
gsl_interp2d_min_size(const gsl_interp2d * interp)
{
  return interp->type->min_size;
}

const char *
gsl_interp2d_name(const gsl_interp2d * interp)
{
  return interp->type->name;
}

size_t
gsl_interp2d_idx(const gsl_interp2d * interp,
                 const size_t i, const size_t j)
{
  if (i >= interp->xsize)
    {
      GSL_ERROR_VAL ("x index out of range", GSL_ERANGE, 0);
    }
  else if (j >= interp->ysize)
    {
      GSL_ERROR_VAL ("y index out of range", GSL_ERANGE, 0);
    }
  else
    {
      return IDX2D(i, j, interp);
    }
} /* gsl_interp2d_idx() */

int
gsl_interp2d_set(const gsl_interp2d * interp, double zarr[],
                 const size_t i, const size_t j, const double z)
{
  if (i >= interp->xsize)
    {
      GSL_ERROR ("x index out of range", GSL_ERANGE);
    }
  else if (j >= interp->ysize)
    {
      GSL_ERROR ("y index out of range", GSL_ERANGE);
    }
  else
    {
      zarr[IDX2D(i, j, interp)] = z;
      return GSL_SUCCESS;
    }
} /* gsl_interp2d_set() */

double
gsl_interp2d_get(const gsl_interp2d * interp, const double zarr[],
                 const size_t i, const size_t j)
{
  if (i >= interp->xsize)
    {
      GSL_ERROR_VAL ("x index out of range", GSL_ERANGE, 0);
    }
  else if (j >= interp->ysize)
    {
      GSL_ERROR_VAL ("y index out of range", GSL_ERANGE, 0);
    }
  else
    {
      return zarr[IDX2D(i, j, interp)];
    }
} /* gsl_interp2d_get() */

#undef IDX2D


/* specfunc/airy_der.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 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 <gsl/gsl_math.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_sf_exp.h>
#include <gsl/gsl_sf_airy.h>

#include "error.h"

#include "chebyshev.h"
#include "cheb_eval_mode.c"

/*-*-*-*-*-*-*-*-*-*-*-* Private Section *-*-*-*-*-*-*-*-*-*-*-*/

/* based on SLATEC aide.f, bide.f, aid.f, bid.f, r9admp.f */

/*
 series for aif on the interval -1.00000e+00 to  1.00000e+00
                                        with weighted error   5.22e-18
                                         log weighted error  17.28
                               significant figures required  16.01
                                    decimal places required  17.73
*/
static double aif_data[8] = {
   0.10527461226531408809,
   0.01183613628152997844,
   0.00012328104173225664,
   0.00000062261225638140,
   0.00000000185298887844,
   0.00000000000363328873,
   0.00000000000000504622,
   0.00000000000000000522
};
static cheb_series aif_cs = {
  aif_data,
  7,
  -1, 1,
  7
};

/*
 series for aig on the interval -1.00000e+00 to  1.00000e+00
                                        with weighted error   3.14e-19
                                         log weighted error  18.50
                               significant figures required  17.44
                                    decimal places required  18.98
*/
static double aig_data[9] = {
   0.021233878150918666852,
   0.086315930335214406752,
   0.001797594720383231358,
   0.000014265499875550693,
   0.000000059437995283683,
   0.000000000152403366479,
   0.000000000000264587660,
   0.000000000000000331562,
   0.000000000000000000314
};
static cheb_series aig_cs = {
  aig_data,
  8,
  -1, 1,
  8
};

/*
 series for aip2 on the interval  0.00000e+00 to  1.25000e-01
                                        with weighted error   2.15e-17
                                         log weighted error  16.67
                               significant figures required  14.27
                                    decimal places required  17.26
*/
static double aip2_data[15] = {
    0.0065457691989713757,
    0.0023833724120774592,
   -0.0000430700770220586,
    0.0000015629125858629,
   -0.0000000815417186163,
    0.0000000054103738057,
   -0.0000000004284130883,
    0.0000000000389497963,
   -0.0000000000039623161,
    0.0000000000004428184,
   -0.0000000000000536297,
    0.0000000000000069650,
   -0.0000000000000009620,
    0.0000000000000001403,
   -0.0000000000000000215
};
static cheb_series aip2_cs = {
  aip2_data,
  14,
  -1, 1,
  9
};

/*
 series for aip1 on the interval  1.25000e-01 to  1.00000e+00
                                        with weighted error   2.60e-17
                                         log weighted error  16.58
                               significant figures required  14.91
                                    decimal places required  17.28
*/
static double aip1_data[25] = {
    0.0358865097808301538,
    0.0114668575627764899,
   -0.0007592073583861400,
    0.0000869517610893841,
   -0.0000128237294298592,
    0.0000022062695681038,
   -0.0000004222295185921,
    0.0000000874686415726,
   -0.0000000192773588418,
    0.0000000044668460054,
   -0.0000000010790108052,
    0.0000000002700029447,
   -0.0000000000696480108,
    0.0000000000184489907,
   -0.0000000000050027817,
    0.0000000000013852243,
   -0.0000000000003908218,
    0.0000000000001121536,
   -0.0000000000000326862,
    0.0000000000000096619,
   -0.0000000000000028935,
    0.0000000000000008770,
   -0.0000000000000002688,
    0.0000000000000000832,
   -0.0000000000000000260
};
static cheb_series aip1_cs = {
  aip1_data,
  24,
  -1, 1,
  14
};

/*
 series for bif on the interval -1.00000e+00 to  1.00000e+00
                                        with weighted error   9.05e-18
                                         log weighted error  17.04
                               significant figures required  15.83
                                    decimal places required  17.49
*/
static double bif_data[8] = {
   0.1153536790828570243,
   0.0205007894049192875,
   0.0002135290278902876,
   0.0000010783960614677,
   0.0000000032094708833,
   0.0000000000062930407,
   0.0000000000000087403,
   0.0000000000000000090
};
static cheb_series bif_cs = {
  bif_data,
  7,
  -1, 1,
  7
};

/*
 series for big on the interval -1.00000e+00 to  1.00000e+00
                                        with weighted error   5.44e-19
                                         log weighted error  18.26
                               significant figures required  17.46
                                    decimal places required  18.74
*/
static double big_data[9] = {
   -0.097196440416443537390,
    0.149503576843167066571,
    0.003113525387121326042,
    0.000024708570579821297,
    0.000000102949627731379,
    0.000000000263970373987,
    0.000000000000458279271,
    0.000000000000000574283,
    0.000000000000000000544
};
static cheb_series big_cs = {
  big_data,
  8,
  -1, 1,
  8
};

/*
 series for bif2 on the interval  1.00000e+00 to  8.00000e+00
                                        with weighted error   3.82e-19
                                         log weighted error  18.42
                               significant figures required  17.68
                                    decimal places required  18.92
*/
static double bif2_data[10] = {
   0.323493987603522033521,
   0.086297871535563559139,
   0.002994025552655397426,
   0.000051430528364661637,
   0.000000525840250036811,
   0.000000003561751373958,
   0.000000000017146864007,
   0.000000000000061663520,
   0.000000000000000171911,
   0.000000000000000000382
};
static cheb_series bif2_cs = {
  bif2_data,
  9,
  -1, 1,
  9
};

/*
 series for big2 on the interval  1.00000e+00 to  8.00000e+00
                                        with weighted error   3.35e-17
                                         log weighted error  16.48
                               significant figures required  16.52
                                    decimal places required  16.98
*/
static double big2_data[10] = {
   1.6062999463621294578,
   0.7449088819876088652,
   0.0470138738610277380,
   0.0012284422062548239,
   0.0000173222412256624,
   0.0000001521901652368,
   0.0000000009113560249,
   0.0000000000039547918,
   0.0000000000000130017,
   0.0000000000000000335
};
static cheb_series big2_cs = {
  big2_data,
  9,
  -1, 1,
  9
};

/*
 series for bip2 on the interval  0.00000e+00 to  1.25000e-01
                                        with weighted error   2.07e-18
                                         log weighted error  17.69
                               significant figures required  16.51
                                    decimal places required  18.42
*/
static double bip2_data[29] = {
    -0.13269705443526630495,
    -0.00568443626045977481,
    -0.00015643601119611610,
    -0.00001136737203679562,
    -0.00000143464350991284,
    -0.00000018098531185164,
     0.00000000926177343611,
     0.00000001710005490721,
     0.00000000476698163504,
    -0.00000000035195022023,
    -0.00000000058890614316,
    -0.00000000006678499608,
     0.00000000006395565102,
     0.00000000001554529427,
    -0.00000000000792397000,
    -0.00000000000258326243,
     0.00000000000121655048,
     0.00000000000038707207,
    -0.00000000000022487045,
    -0.00000000000004953477,
     0.00000000000004563782,
     0.00000000000000332998,
    -0.00000000000000921750,
     0.00000000000000094157,
     0.00000000000000167154,
    -0.00000000000000055134,
    -0.00000000000000022369,
     0.00000000000000017487,
     0.00000000000000000207
};
static cheb_series bip2_cs = {
  bip2_data,
  28,
  -1, 1,
  14
};

/*
 series for bip1 on the interval  1.25000e-01 to  3.53553e-01
                                        with weighted error   1.86e-17
                                         log weighted error  16.73
                               significant figures required  15.67
                                    decimal places required  17.42
*/
static double bip1_data[24] = {
   -0.1729187351079553719,
   -0.0149358492984694364,
   -0.0005471104951678566,
    0.0001537966292958408,
    0.0000154353476192179,
   -0.0000065434113851906,
    0.0000003728082407879,
    0.0000002072078388189,
   -0.0000000658173336470,
    0.0000000074926746354,
    0.0000000011101336884,
   -0.0000000007265140553,
    0.0000000001782723560,
   -0.0000000000217346352,
   -0.0000000000020302035,
    0.0000000000019311827,
   -0.0000000000006044953,
    0.0000000000001209450,
   -0.0000000000000125109,
   -0.0000000000000019917,
    0.0000000000000015154,
   -0.0000000000000004977,
    0.0000000000000001155,
   -0.0000000000000000186
};
static cheb_series bip1_cs = {
  bip1_data,
  23,
  -1, 1,
  13
};

/*
 series for an22 on the interval -1.00000e+00 to -1.25000e-01
                                        with weighted error   3.30e-17
                                         log weighted error  16.48
                               significant figures required  14.95
                                    decimal places required  17.24
*/
static double an22_data[33] = {
    0.0537418629629794329,
   -0.0126661435859883193,
   -0.0011924334106593007,
   -0.0002032327627275655,
   -0.0000446468963075164,
   -0.0000113359036053123,
   -0.0000031641352378546,
   -0.0000009446708886149,
   -0.0000002966562236472,
   -0.0000000969118892024,
   -0.0000000326822538653,
   -0.0000000113144618964,
   -0.0000000040042691002,
   -0.0000000014440333684,
   -0.0000000005292853746,
   -0.0000000001967763374,
   -0.0000000000740800096,
   -0.0000000000282016314,
   -0.0000000000108440066,
   -0.0000000000042074801,
   -0.0000000000016459150,
   -0.0000000000006486827,
   -0.0000000000002574095,
   -0.0000000000001027889,
   -0.0000000000000412846,
   -0.0000000000000166711,
   -0.0000000000000067657,
   -0.0000000000000027585,
   -0.0000000000000011296,
   -0.0000000000000004645,
   -0.0000000000000001917,
   -0.0000000000000000794,
   -0.0000000000000000330
};
static cheb_series an22_cs = {
  an22_data,
  32,
  -1, 1,
  18
};

/*
 series for an21 on the interval -1.25000e-01 to -1.56250e-02
                                        with weighted error   3.43e-17
                                         log weighted error  16.47
                               significant figures required  14.48
                                    decimal places required  17.16
*/
static double an21_data[24] = {
    0.0198313155263169394,
   -0.0029376249067087533,
   -0.0001136260695958196,
   -0.0000100554451087156,
   -0.0000013048787116563,
   -0.0000002123881993151,
   -0.0000000402270833384,
   -0.0000000084996745953,
   -0.0000000019514839426,
   -0.0000000004783865344,
   -0.0000000001236733992,
   -0.0000000000334137486,
   -0.0000000000093702824,
   -0.0000000000027130128,
   -0.0000000000008075954,
   -0.0000000000002463214,
   -0.0000000000000767656,
   -0.0000000000000243883,
   -0.0000000000000078831,
   -0.0000000000000025882,
   -0.0000000000000008619,
   -0.0000000000000002908,
   -0.0000000000000000993,
   -0.0000000000000000343
};
static cheb_series an21_cs = {
  an21_data,
  23,
  -1, 1,
  12
};

/*
 series for an20 on the interval -1.56250e-02 to  0.00000e+00
                                        with weighted error   4.41e-17
                                         log weighted error  16.36
                               significant figures required  14.16
                                    decimal places required  16.96
*/
static double an20_data[16] = {
    0.0126732217145738027,
   -0.0005212847072615621,
   -0.0000052672111140370,
   -0.0000001628202185026,
   -0.0000000090991442687,
   -0.0000000007438647126,
   -0.0000000000795494752,
   -0.0000000000104050944,
   -0.0000000000015932426,
   -0.0000000000002770648,
   -0.0000000000000535343,
   -0.0000000000000113062,
   -0.0000000000000025772,
   -0.0000000000000006278,
   -0.0000000000000001621,
   -0.0000000000000000441
};
static cheb_series an20_cs = {
  an20_data,
  15,
  -1, 1,
  8
};

/*
 series for aph2 on the interval -1.00000e+00 to -1.25000e-01
                                        with weighted error   2.94e-17
                                         log weighted error  16.53
                               significant figures required  15.58
                                    decimal places required  17.28
*/
static double aph2_data[32] = {
   -0.2057088719781465107,
    0.0422196961357771922,
    0.0020482560511207275,
    0.0002607800735165006,
    0.0000474824268004729,
    0.0000105102756431612,
    0.0000026353534014668,
    0.0000007208824863499,
    0.0000002103236664473,
    0.0000000644975634555,
    0.0000000205802377264,
    0.0000000067836273921,
    0.0000000022974015284,
    0.0000000007961306765,
    0.0000000002813860610,
    0.0000000001011749057,
    0.0000000000369306738,
    0.0000000000136615066,
    0.0000000000051142751,
    0.0000000000019351689,
    0.0000000000007393607,
    0.0000000000002849792,
    0.0000000000001107281,
    0.0000000000000433412,
    0.0000000000000170801,
    0.0000000000000067733,
    0.0000000000000027017,
    0.0000000000000010835,
    0.0000000000000004367,
    0.0000000000000001769,
    0.0000000000000000719,
    0.0000000000000000294
};
static cheb_series aph2_cs = {
  aph2_data,
  31,
  -1, 1,
  16
};

/*
 series for aph1 on the interval -1.25000e-01 to -1.56250e-02
                                        with weighted error   6.38e-17
                                         log weighted error  16.20
                               significant figures required  14.91
                                    decimal places required  16.87
*/
static double aph1_data[22] = {
  -0.1024172908077571694,
   0.0071697275146591248,
   0.0001209959363122329,
   0.0000073361512841220,
   0.0000007535382954272,
   0.0000001041478171741,
   0.0000000174358728519,
   0.0000000033399795033,
   0.0000000007073075174,
   0.0000000001619187515,
   0.0000000000394539982,
   0.0000000000101192282,
   0.0000000000027092778,
   0.0000000000007523806,
   0.0000000000002156369,
   0.0000000000000635283,
   0.0000000000000191757,
   0.0000000000000059143,
   0.0000000000000018597,
   0.0000000000000005950,
   0.0000000000000001934,
   0.0000000000000000638
};
static cheb_series aph1_cs = {
  aph1_data,
  21,
  -1, 1,
  10
};

/*
 series for aph0 on the interval -1.56250e-02 to  0.00000e+00
                                        with weighted error   2.29e-17
                                         log weighted error  16.64
                               significant figures required  15.27
                                    decimal places required  17.23
*/
static double aph0_data[15] = {
 -0.0855849241130933257,
  0.0011214378867065261,
  0.0000042721029353664,
  0.0000000817607381483,
  0.0000000033907645000,
  0.0000000002253264423,
  0.0000000000206284209,
  0.0000000000023858763,
  0.0000000000003301618,
  0.0000000000000527010,
  0.0000000000000094555,
  0.0000000000000018709,
  0.0000000000000004024,
  0.0000000000000000930,
  0.0000000000000000229
};
static cheb_series aph0_cs = {
  aph0_data,
  14,
  -1, 1,
  7
};

static
int
airy_deriv_mod_phase(const double x, gsl_mode_t mode,
                     gsl_sf_result * ampl, gsl_sf_result * phi)
{
  const double pi34 = 2.356194490192344928847;
  gsl_sf_result result_a;
  gsl_sf_result result_p;
  double a, p;
  double sqx;

  if(x <= -4.0) {
    double z = 128.0/(x*x*x) + 1.0;
    cheb_eval_mode_e(&an20_cs, z, mode, &result_a);
    cheb_eval_mode_e(&aph0_cs, z, mode, &result_p);
  }
  else if(x <= -2.0) {
    double z = (128.0/(x*x*x) + 9.0) / 7.0;
    cheb_eval_mode_e(&an21_cs, z, mode, &result_a);
    cheb_eval_mode_e(&aph1_cs, z, mode, &result_p);
  }
  else if(x <= -1.0) {
    double z = (16.0/(x*x*x) + 9.0) / 7.0;
    cheb_eval_mode_e(&an22_cs, z, mode, &result_a);
    cheb_eval_mode_e(&aph2_cs, z, mode, &result_p);
  }
  else {
    ampl->val = 0.0;
    ampl->err = 0.0;
    phi->val  = 0.0;
    phi->err  = 0.0;
    GSL_ERROR ("x is greater than 1.0", GSL_EDOM);
  }

  a =  0.3125 + result_a.val;
  p = -0.625  + result_p.val;

  sqx = sqrt(-x);

  ampl->val = sqrt(a * sqx);
  ampl->err = fabs(ampl->val) * (GSL_DBL_EPSILON + fabs(result_a.err/result_a.val));
  phi->val  = pi34 - x * sqx * p;
  phi->err = fabs(phi->val) * (GSL_DBL_EPSILON + fabs(result_p.err/result_p.val));

  return GSL_SUCCESS;
}

/*-*-*-*-*-*-*-*-*-*-*-* Functions with Error Codes *-*-*-*-*-*-*-*-*-*-*-*/

int
gsl_sf_airy_Ai_deriv_scaled_e(const double x, gsl_mode_t mode, gsl_sf_result * result)
{
  /* CHECK_POINTER(result) */

  if(x < -1.0) {
    gsl_sf_result a;
    gsl_sf_result p;
    int status_ap = airy_deriv_mod_phase(x, mode, &a, &p);
    double c    = cos(p.val);
    result->val  = a.val * c;
    result->err  = fabs(result->val * p.err) + fabs(c * a.err);
    result->err += GSL_DBL_EPSILON * fabs(result->val);
    return status_ap;
  }
  else if(x <= 1.0) {
    const double x3 = x*x*x;
    const double x2 = x*x;
    gsl_sf_result result_c0;
    gsl_sf_result result_c1;
    cheb_eval_mode_e(&aif_cs, x3, mode, &result_c0);
    cheb_eval_mode_e(&aig_cs, x3, mode, &result_c1);

    result->val  = (x2*(0.125 + result_c0.val) - result_c1.val) - 0.25;
    result->err  = fabs(x2*result_c0.val) + result_c1.err;
    result->err += GSL_DBL_EPSILON * fabs(result->val);

    if(x > GSL_ROOT3_DBL_EPSILON*GSL_ROOT3_DBL_EPSILON) {
      /* scale only if x is positive */
      double s = exp(2.0*x*sqrt(x)/3.0);
      result->val *= s;
      result->err *= s;
    }

    return GSL_SUCCESS;
  }
  else if(x <= 4.0) {
    const double sqrtx = sqrt(x);
    const double z = (16.0/(x*sqrtx) - 9.0)/7.0;
    const double s = sqrt(sqrtx);
    gsl_sf_result result_c0;
    cheb_eval_mode_e(&aip1_cs, z, mode, &result_c0);
    result->val  = -(0.28125 + result_c0.val) * s;
    result->err  = result_c0.err * s;
    result->err += GSL_DBL_EPSILON * fabs(result->val);
    return GSL_SUCCESS;
  }
  else {
    const double sqrtx = sqrt(x);
    const double z = 16.0/(x*sqrtx) - 1.0;
    const double s = sqrt(sqrtx);
    gsl_sf_result result_c0;
    cheb_eval_mode_e(&aip2_cs, z, mode, &result_c0);
    result->val  = -(0.28125 + result_c0.val) * s;
    result->err  = result_c0.err * s;
    result->err += GSL_DBL_EPSILON * fabs(result->val);
    return GSL_SUCCESS;
  }
}

int
gsl_sf_airy_Ai_deriv_e(const double x, gsl_mode_t mode, gsl_sf_result * result)
{
  /* CHECK_POINTER(result) */

  if(x < -1.0) {
    gsl_sf_result a;
    gsl_sf_result p;
    int status_ap = airy_deriv_mod_phase(x, mode, &a, &p);
    double c    = cos(p.val);
    result->val  = a.val * c;
    result->err  = fabs(result->val * p.err) + fabs(c * a.err);
    result->err += GSL_DBL_EPSILON * fabs(result->val);
    return status_ap;
  }
  else if(x < 1.0) {
    const double x3 = x*x*x;
    gsl_sf_result result_c1;
    gsl_sf_result result_c2;
    cheb_eval_mode_e(&aif_cs, x3, mode, &result_c1);
    cheb_eval_mode_e(&aig_cs, x3, mode, &result_c2);
    result->val  = (x*x*(0.125 + result_c1.val) - result_c2.val) - 0.25;
    result->err  = fabs(x*x*result_c1.err) + result_c2.err;
    result->err += GSL_DBL_EPSILON * fabs(result->val);
    return GSL_SUCCESS;
  }
  else if(x*x*x < 9.0/4.0 * GSL_LOG_DBL_MIN*GSL_LOG_DBL_MIN) {
    gsl_sf_result result_aps;
    const double arg = -2.0*x*sqrt(x)/3.0;
    const int stat_a = gsl_sf_airy_Ai_deriv_scaled_e(x, mode, &result_aps);
    const int stat_e = gsl_sf_exp_mult_err_e(arg, 1.5*fabs(arg*GSL_DBL_EPSILON),
                                                result_aps.val, result_aps.err,
                                                result);
    return GSL_ERROR_SELECT_2(stat_e, stat_a);
  }
  else {
    UNDERFLOW_ERROR(result);
  }
}

int
gsl_sf_airy_Bi_deriv_scaled_e(const double x, gsl_mode_t mode, gsl_sf_result * result)
{
  const double atr =  8.7506905708484345;   /* 16./(sqrt(8)-1) */
  const double btr = -2.0938363213560543;   /* -(sqrt(8)+1)/(sqrt(8)-1) */

  /* CHECK_POINTER(result) */

  if(x < -1.0) {
    gsl_sf_result a;
    gsl_sf_result p;
    int status_ap = airy_deriv_mod_phase(x, mode, &a, &p);
    double s     = sin(p.val);
    result->val  = a.val * s;
    result->err  = fabs(result->val * p.err) + fabs(s * a.err);
    result->err += GSL_DBL_EPSILON * fabs(result->val);
    return status_ap;
  }
  else if(x < 1.0) {
    const double x3 = x*x*x;
    const double x2 = x*x;
    gsl_sf_result result_c1;
    gsl_sf_result result_c2;
    cheb_eval_mode_e(&bif_cs, x3, mode, &result_c1);
    cheb_eval_mode_e(&big_cs, x3, mode, &result_c2);
    result->val  = x2 * (result_c1.val + 0.25) + result_c2.val + 0.5;
    result->err  = x2 * result_c1.err + result_c2.err;
    result->err += GSL_DBL_EPSILON * fabs(result->val);

    if(x > GSL_ROOT3_DBL_EPSILON*GSL_ROOT3_DBL_EPSILON) {
      /* scale only if x is positive */
      const double s = exp(-2.0*x*sqrt(x)/3.0);
      result->val *= s;
      result->err *= s;
    }

    return GSL_SUCCESS;
  }
  else if(x < 2.0) {
    const double z = (2.0*x*x*x - 9.0) / 7.0;
    const double s = exp(-2.0*x*sqrt(x)/3.0);
    gsl_sf_result result_c0;
    gsl_sf_result result_c1;
    cheb_eval_mode_e(&bif2_cs, z, mode, &result_c0);
    cheb_eval_mode_e(&big2_cs, z, mode, &result_c1);
    result->val  = s * (x*x * (0.25 + result_c0.val) + 0.5 + result_c1.val);
    result->err  = s * (x*x * result_c0.err + result_c1.err);
    result->err += GSL_DBL_EPSILON * fabs(result->val);
    return GSL_SUCCESS;
  }
  else if(x < 4.0) {
    const double sqrtx = sqrt(x);
    const double z = atr/(x*sqrtx) + btr;
    const double s = sqrt(sqrtx);
    gsl_sf_result result_c0;
    cheb_eval_mode_e(&bip1_cs, z, mode, &result_c0);
    result->val  = s * (0.625 + result_c0.val);
    result->err  = s * result_c0.err;
    result->err += GSL_DBL_EPSILON * fabs(result->val);
    return GSL_SUCCESS;
  }
  else {
    const double sqrtx = sqrt(x);
    const double z = 16.0/(x*sqrtx) - 1.0;
    const double s = sqrt(sqrtx);
    gsl_sf_result result_c0;
    cheb_eval_mode_e(&bip2_cs, z, mode, &result_c0);
    result->val  = s * (0.625 + result_c0.val);
    result->err  = s * result_c0.err;
    result->err += GSL_DBL_EPSILON * fabs(result->val);
    return GSL_SUCCESS;
  }
}

int
gsl_sf_airy_Bi_deriv_e(const double x, gsl_mode_t mode, gsl_sf_result * result)
{
  /* CHECK_POINTER(result) */

  if(x < -1.0) {
    gsl_sf_result a;
    gsl_sf_result p;
    int status_ap = airy_deriv_mod_phase(x, mode, &a, &p);
    double s    = sin(p.val);
    result->val  = a.val * s;
    result->err  = fabs(result->val * p.err) + fabs(s * a.err);
    result->err += GSL_DBL_EPSILON * fabs(result->val);
    return status_ap;
  }
  else if(x < 1.0) {
    const double x3 = x*x*x;
    const double x2 = x*x;
    gsl_sf_result result_c1;
    gsl_sf_result result_c2;
    cheb_eval_mode_e(&bif_cs, x3, mode, &result_c1);
    cheb_eval_mode_e(&big_cs, x3, mode, &result_c2);
    result->val  = x2 * (result_c1.val + 0.25) + result_c2.val + 0.5;
    result->err  = x2 * result_c1.err + result_c2.err;
    result->err += GSL_DBL_EPSILON * fabs(result->val);
    return GSL_SUCCESS;
  }
  else if(x < 2.0) {
    const double z = (2.0*x*x*x - 9.0) / 7.0;
    gsl_sf_result result_c1;
    gsl_sf_result result_c2;
    cheb_eval_mode_e(&bif2_cs, z, mode, &result_c1);
    cheb_eval_mode_e(&big2_cs, z, mode, &result_c2);
    result->val  = x*x * (result_c1.val + 0.25) + result_c2.val + 0.5;
    result->err  = x*x * result_c1.err + result_c2.err;
    result->err += GSL_DBL_EPSILON * fabs(result->val);
    return GSL_SUCCESS;
  }
  else if(x < GSL_ROOT3_DBL_MAX*GSL_ROOT3_DBL_MAX) {
    gsl_sf_result result_bps;
    const double arg = 2.0*(x*sqrt(x)/3.0);
    int stat_b = gsl_sf_airy_Bi_deriv_scaled_e(x, mode, &result_bps);
    int stat_e = gsl_sf_exp_mult_err_e(arg, 1.5*fabs(arg*GSL_DBL_EPSILON),
                                          result_bps.val, result_bps.err,
                                          result);
    return GSL_ERROR_SELECT_2(stat_e, stat_b);
  }
  else {
    OVERFLOW_ERROR(result);
  }
}

/*-*-*-*-*-*-*-*-*-* Functions w/ Natural Prototypes *-*-*-*-*-*-*-*-*-*-*/

#include "eval.h"

double gsl_sf_airy_Ai_deriv_scaled(const double x, gsl_mode_t mode)
{
  EVAL_RESULT(gsl_sf_airy_Ai_deriv_scaled_e(x, mode, &result));
}

double gsl_sf_airy_Ai_deriv(const double x, gsl_mode_t mode)
{
  EVAL_RESULT(gsl_sf_airy_Ai_deriv_e(x, mode, &result));
}

double gsl_sf_airy_Bi_deriv_scaled(const double x, gsl_mode_t mode)
{
  EVAL_RESULT(gsl_sf_airy_Bi_deriv_scaled_e(x, mode, &result));
}

double gsl_sf_airy_Bi_deriv(const double x, gsl_mode_t mode)
{
  EVAL_RESULT(gsl_sf_airy_Bi_deriv_e(x, mode, &result));
}


#ifdef HAVE_CONFIG_H
#include "config.h"
#endif

#include <php.h>
#include <cblas.h>
#include <lapacke.h>
#include "kernel/operators.h"

/**
 * Matrix-matrix multiplication i.e. linear transformation of matrices A and B.
 *
 * @param return_value
 * @param a
 * @param b
 */
void tensor_matmul(zval * return_value, zval * a, zval * b)
{
    unsigned int i, j;
    Bucket * row;
    zval rowC, c;

    zend_array * aa = Z_ARR_P(a);
    zend_array * ab = Z_ARR_P(b);

    Bucket * ba = aa->arData;
    Bucket * bb = ab->arData;

    unsigned int m = zend_array_count(aa);
    unsigned int p = zend_array_count(ab);
    unsigned int n = zend_array_count(Z_ARR(bb[0].val));

    double * va = emalloc(m * p * sizeof(double));
    double * vb = emalloc(n * p * sizeof(double));
    double * vc = emalloc(m * n * sizeof(double));

    for (i = 0; i < m; ++i) {
        row = Z_ARR(ba[i].val)->arData;

        for (j = 0; j < p; ++j) {
            va[i * p + j] = zephir_get_doubleval(&row[j].val);
        }
    }

    for (i = 0; i < p; ++i) {
        row = Z_ARR(bb[i].val)->arData;

        for (j = 0; j < n; ++j) {
            vb[i * n + j] = zephir_get_doubleval(&row[j].val);
        }
    }

    cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, m, n, p, 1.0, va, p, vb, n, 0.0, vc, n);

    array_init_size(&c, m);

    for (i = 0; i < m; ++i) {
        array_init_size(&rowC, n);

        for (j = 0; j < n; ++j) {
            add_next_index_double(&rowC, vc[i * n + j]);
        }

        add_next_index_zval(&c, &rowC);
    }

    RETVAL_ARR(Z_ARR(c));

    efree(va);
    efree(vb);
    efree(vc);
}

/**
 * Dot product between vectors A and B.
 *
 * @param return_value
 * @param a
 * @param b
 */
void tensor_dot(zval * return_value, zval * a, zval * b)
{
    unsigned int i;

    zend_array * aa = Z_ARR_P(a);
    zend_array * ab = Z_ARR_P(b);

    Bucket * ba = aa->arData;
    Bucket * bb = ab->arData;

    unsigned int n = zend_array_count(aa);

    double sigma = 0.0;

    for (i = 0; i < n; ++i) {
        sigma += zephir_get_doubleval(&ba[i].val) * zephir_get_doubleval(&bb[i].val);
    }

    RETVAL_DOUBLE(sigma);
}

/**
 * Return the multiplicative inverse of a square matrix A.
 *
 * @param return_value
 * @param a
 */
void tensor_inverse(zval * return_value, zval * a)
{
    unsigned int i, j;
    Bucket * row;
    zval rowB, b;

    zend_array * aa = Z_ARR_P(a);

    Bucket * ba = aa->arData;

    unsigned int n = zend_array_count(aa);

    double * va = emalloc(n * n * sizeof(double));
    int * pivots = emalloc(n * sizeof(int));

    for (i = 0; i < n; ++i) {
        row = Z_ARR(ba[i].val)->arData;

        for (j = 0; j < n; ++j) {
            va[i * n + j] = zephir_get_doubleval(&row[j].val);
        }
    }

    lapack_int status;

    status = LAPACKE_dgetrf(LAPACK_ROW_MAJOR, n, n, va, n, pivots);

    if (status != 0) {
        RETURN_NULL();
    }

    status = LAPACKE_dgetri(LAPACK_ROW_MAJOR, n, va, n, pivots);

    if (status != 0) {
        RETURN_NULL();
    }

    array_init_size(&b, n);

    for (i = 0; i < n; ++i) {
        array_init_size(&rowB, n);

        for (j = 0; j < n; ++j) {
            add_next_index_double(&rowB, va[i * n + j]);
        }

        add_next_index_zval(&b, &rowB);
    }

    RETVAL_ARR(Z_ARR(b));

    efree(va);
    efree(pivots);
}

/**
 * Return the (Moore-Penrose) pseudoinverse of a general matrix A.
 *
 * @param return_value
 * @param a
 */
void tensor_pseudoinverse(zval * return_value, zval * a)
{
    unsigned int i, j;
    Bucket * row;
    zval b, rowB;

    zend_array * aa = Z_ARR_P(a);

    Bucket * ba = aa->arData;

    unsigned int m = zend_array_count(aa);
    unsigned int n = zend_array_count(Z_ARR(ba[0].val));
    unsigned int k = MIN(m, n);

    double * va = emalloc(m * n * sizeof(double));
    double * vu = emalloc(m * m * sizeof(double));
    double * vs = emalloc(k * sizeof(double));
    double * vvt = emalloc(n * n * sizeof(double));
    double * vb = emalloc(n * m * sizeof(double));

    for (i = 0; i < m; ++i) {
        row = Z_ARR(ba[i].val)->arData;

        for (j = 0; j < n; ++j) {
            va[i * n + j] = zephir_get_doubleval(&row[j].val);
        }
    }

    lapack_int status = LAPACKE_dgesdd(LAPACK_ROW_MAJOR, 'A', m, n, va, n, vs, vu, m, vvt, n);

    if (status != 0) {
        RETURN_NULL();
    }

    for (i = 0; i < k; ++i) {
        cblas_dscal(m, 1.0 / vs[i], &vu[i], m);
    }

    cblas_dgemm(CblasRowMajor, CblasTrans, CblasTrans, n, m, m, 1.0, vvt, n, vu, m, 0.0, vb, m);

    array_init_size(&b, n);

    for (i = 0; i < n; ++i) {
        array_init_size(&rowB, m);

        for (j = 0; j < m; ++j) {
            add_next_index_double(&rowB, vb[i * m + j]);
        }

        add_next_index_zval(&b, &rowB);
    }

    RETVAL_ARR(Z_ARR(b));

    efree(va);
    efree(vu);
    efree(vs);
    efree(vvt);
    efree(vb);
}

/**
 * Return the row echelon form of matrix A.
 *
 * @param return_value
 * @param a
 */
void tensor_ref(zval * return_value, zval * a)
{
    unsigned int i, j;
    Bucket * row;
    zval rowB, b;
    zval tuple;

    zend_array * aa = Z_ARR_P(a);

    Bucket * ba = aa->arData;

    unsigned int m = zend_array_count(aa);
    unsigned int n = zend_array_count(Z_ARR(ba[0].val));

    double * va = emalloc(m * n * sizeof(double));
    int * pivots = emalloc(MIN(m, n) * sizeof(int));

    for (i = 0; i < m; ++i) {
        row = Z_ARR(ba[i].val)->arData;

        for (j = 0; j < n; ++j) {
            va[i * n + j] = zephir_get_doubleval(&row[j].val);
        }
    }

    lapack_int status = LAPACKE_dgetrf(LAPACK_ROW_MAJOR, m, n, va, n, pivots);

    if (status != 0) {
        RETURN_NULL();
    }

    array_init_size(&b, m);

    long swaps = 0;

    for (i = 0; i < m; ++i) {
        array_init_size(&rowB, n);

        for (j = 0; j < i; ++j) {
            add_next_index_double(&rowB, 0.0);
        }

        for (j = i; j < n; ++j) {
            add_next_index_double(&rowB, va[i * n + j]);
        }

        add_next_index_zval(&b, &rowB);

        if (i + 1 != pivots[i]) {
            ++swaps;
        }
    }

    array_init_size(&tuple, 2);

    add_next_index_zval(&tuple, &b);
    add_next_index_long(&tuple, swaps);

    RETVAL_ARR(Z_ARR(tuple));

    efree(va);
    efree(pivots);
}

/**
 * Compute the Cholesky decomposition of matrix A and return the lower triangular matrix.
 *
 * @param return_value
 * @param a
 */
void tensor_cholesky(zval * return_value, zval * a)
{
    unsigned int i, j;
    Bucket * row;
    zval rowB, b;

    zend_array * aa = Z_ARR_P(a);

    Bucket * ba = aa->arData;

    unsigned int n = zend_array_count(aa);

    double * va = emalloc(n * n * sizeof(double));

    for (i = 0; i < n; ++i) {
        row = Z_ARR(ba[i].val)->arData;

        for (j = 0; j < n; ++j) {
            va[i * n + j] = zephir_get_doubleval(&row[j].val);
        }
    }

    lapack_int status = LAPACKE_dpotrf(LAPACK_ROW_MAJOR, 'L', n, va, n);

    if (status != 0) {
        RETURN_NULL();
    }

    array_init_size(&b, n);

    for (i = 0; i < n; ++i) {
        array_init_size(&rowB, n);

        for (j = 0; j <= i; ++j) {
            add_next_index_double(&rowB, va[i * n + j]);
        }

        for (j = i + 1; j < n; ++j) {
            add_next_index_double(&rowB, 0.0);
        }

        add_next_index_zval(&b, &rowB);
    }

    RETVAL_ARR(Z_ARR(b));

    efree(va);
}

/**
 * Compute the LU factorization of matrix A and return a tuple with lower, upper, and permutation matrices.
 *
 * @param return_value
 * @param a
 */
void tensor_lu(zval * return_value, zval * a)
{
    unsigned int i, j;
    Bucket * row;
    zval rowL, l, rowU, u, rowP, p;
    zval tuple;

    zend_array * aa = Z_ARR_P(a);

    Bucket * ba = aa->arData;

    unsigned int n = zend_array_count(aa);

    double * va = emalloc(n * n * sizeof(double));
    int * pivots = emalloc(n * sizeof(int));

    for (i = 0; i < n; ++i) {
        row = Z_ARR(ba[i].val)->arData;

        for (j = 0; j < n; ++j) {
            va[i * n + j] = zephir_get_doubleval(&row[j].val);
        }
    }

    lapack_int status = LAPACKE_dgetrf(LAPACK_ROW_MAJOR, n, n, va, n, pivots);

    if (status != 0) {
        RETURN_NULL();
    }

    array_init_size(&l, n);
    array_init_size(&u, n);
    array_init_size(&p, n);

    for (i = 0; i < n; ++i) {
        array_init_size(&rowL, n);

        for (j = 0; j < i; ++j) {
            add_next_index_double(&rowL, va[i * n + j]);
        }

        add_next_index_double(&rowL, 1.0);

        for (j = i + 1; j < n; ++j) {
            add_next_index_double(&rowL, 0.0);
        }

        add_next_index_zval(&l, &rowL);
    }

    for (i = 0; i < n; ++i) {
        array_init_size(&rowU, n);

        for (j = 0; j < i; ++j) {
            add_next_index_double(&rowU, 0.0);
        }

        for (j = i; j < n; ++j) {
            add_next_index_double(&rowU, va[i * n + j]);
        }

        add_next_index_zval(&u, &rowU);
    }

    for (i = 0; i < n; ++i) {
        array_init_size(&rowP, n);

        for (j = 0; j < n; ++j) {
            if (j == pivots[i] - 1) {
                add_next_index_long(&rowP, 1);
            } else {
                add_next_index_long(&rowP, 0);
            }
        }

        add_next_index_zval(&p, &rowP);
    }

    array_init_size(&tuple, 3);

    add_next_index_zval(&tuple, &l);
    add_next_index_zval(&tuple, &u);
    add_next_index_zval(&tuple, &p);

    RETVAL_ARR(Z_ARR(tuple));

    efree(va);
    efree(pivots);
}

/**
 * Compute the eigendecomposition of a general matrix A and return the eigenvalues and eigenvectors in a tuple.
 *
 * @param return_value
 * @param a
 */
void tensor_eig(zval * return_value, zval * a)
{
    unsigned int i, j;
    Bucket * row;
    zval eigenvalues;
    zval eigenvectors;
    zval eigenvector;
    zval tuple;

    zend_array * aa = Z_ARR_P(a);

    Bucket * ba = aa->arData;

    unsigned int n = zend_array_count(aa);

    double * va = emalloc(n * n * sizeof(double));
    double * wr = emalloc(n * sizeof(double));
    double * wi = emalloc(n * sizeof(double));
    double * vr = emalloc(n * n * sizeof(double));

    for (i = 0; i < n; ++i) {
        row = Z_ARR(ba[i].val)->arData;

        for (j = 0; j < n; ++j) {
            va[i * n + j] = zephir_get_doubleval(&row[j].val);
        }
    }

    lapack_int status = LAPACKE_dgeev(LAPACK_ROW_MAJOR, 'N', 'V', n, va, n, wr, wi, NULL, n, vr, n);

    if (status != 0) {
        RETURN_NULL();
    }

    array_init_size(&eigenvalues, n);
    array_init_size(&eigenvectors, n);

    for (i = 0; i < n; ++i) {
        add_next_index_double(&eigenvalues, wr[i]);

        array_init_size(&eigenvector, n);

        for (j = 0; j < n; ++j) {
            add_next_index_double(&eigenvector, vr[i * n + j]);
        }

        add_next_index_zval(&eigenvectors, &eigenvector);
    }

    array_init_size(&tuple, 2);

    add_next_index_zval(&tuple, &eigenvalues);
    add_next_index_zval(&tuple, &eigenvectors);

    RETVAL_ARR(Z_ARR(tuple));

    efree(va);
    efree(wr);
    efree(wi);
    efree(vr);
}

/**
 * Compute the eigendecomposition of a symmetric matrix A and return the eigenvalues and eigenvectors in a tuple.
 *
 * @param return_value
 * @param a
 */
void tensor_eig_symmetric(zval * return_value, zval * a)
{
    unsigned int i, j;
    Bucket * row;
    zval eigenvalues;
    zval eigenvectors;
    zval eigenvector;
    zval tuple;

    zend_array * aa = Z_ARR_P(a);

    Bucket * ba = aa->arData;

    unsigned int n = zend_array_count(aa);

    double * va = emalloc(n * n * sizeof(double));
    double * wr = emalloc(n * sizeof(double));

    for (i = 0; i < n; ++i) {
        row = Z_ARR(ba[i].val)->arData;

        for (j = 0; j < n; ++j) {
            va[i * n + j] = zephir_get_doubleval(&row[j].val);
        }
    }

    lapack_int status = LAPACKE_dsyev(LAPACK_ROW_MAJOR, 'V', 'U', n, va, n, wr);

    if (status != 0) {
        RETURN_NULL();
    }

    array_init_size(&eigenvalues, n);
    array_init_size(&eigenvectors, n);

    for (i = 0; i < n; ++i) {
        add_next_index_double(&eigenvalues, wr[i]);

        array_init_size(&eigenvector, n);

        for (j = 0; j < n; ++j) {
            add_next_index_double(&eigenvector, va[i * n + j]);
        }

        add_next_index_zval(&eigenvectors, &eigenvector);
    }

    array_init_size(&tuple, 2);

    add_next_index_zval(&tuple, &eigenvalues);
    add_next_index_zval(&tuple, &eigenvectors);

    RETVAL_ARR(Z_ARR(tuple));

    efree(va);
    efree(wr);
}

/**
 * Compute the singular value decomposition of a matrix A and return the singular values, and unitary matrices U and VT in a tuple.
 *
 * @param return_value
 * @param a
 */
void tensor_svd(zval * return_value, zval * a)
{
    unsigned int i, j;
    Bucket * row;
    zval u, rowU;
    zval s;
    zval vt, rowVt;
    zval tuple;

    zend_array * aa = Z_ARR_P(a);

    Bucket * ba = aa->arData;

    unsigned int m = zend_array_count(aa);
    unsigned int n = zend_array_count(Z_ARR(ba[0].val));
    unsigned int k = MIN(m, n);

    double * va = emalloc(m * n * sizeof(double));
    double * vu = emalloc(m * m * sizeof(double));
    double * vs = emalloc(k * sizeof(double));
    double * vvt = emalloc(n * n * sizeof(double));

    for (i = 0; i < m; ++i) {
        row = Z_ARR(ba[i].val)->arData;

        for (j = 0; j < n; ++j) {
            va[i * n + j] = zephir_get_doubleval(&row[j].val);
        }
    }

    lapack_int status = LAPACKE_dgesdd(LAPACK_ROW_MAJOR, 'A', m, n, va, n, vs, vu, m, vvt, n);

    if (status != 0) {
        RETURN_NULL();
    }

    array_init_size(&u, m);
    array_init_size(&s, k);
    array_init_size(&vt, n);

    for (i = 0; i < m; ++i) {
        array_init_size(&rowU, m);

        for (j = 0; j < m; ++j) {
            add_next_index_double(&rowU, vu[i * m + j]);
        }

        add_next_index_zval(&u, &rowU);
    }

    for (i = 0; i < k; ++i) {
        add_next_index_double(&s, vs[i]);
    }

    for (i = 0; i < n; ++i) {
        array_init_size(&rowVt, n);

        for (j = 0; j < n; ++j) {
            add_next_index_double(&rowVt, vvt[i * n + j]);
        }

        add_next_index_zval(&vt, &rowVt);
    }

    array_init_size(&tuple, 3);

    add_next_index_zval(&tuple, &u);
    add_next_index_zval(&tuple, &s);
    add_next_index_zval(&tuple, &vt);

    RETVAL_ARR(Z_ARR(tuple));

    efree(va);
    efree(vu);
    efree(vs);
    efree(vvt);
}