/**
 *
 * @file testing_zgels.c
 *
 *  PLASMA testing routines
 *  PLASMA is a software package provided by Univ. of Tennessee,
 *  Univ. of California Berkeley and Univ. of Colorado Denver
 *
 * @version 2.6.0
 * @author Bilel Hadri
 * @author Hatem Ltaief
 * @date 2010-11-15
 * @precisions normal z -> c d s
 *
 **/
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <math.h>

#include <plasma.h>
#include <cblas.h>
#include <lapacke.h>
#include <core_blas.h>
#include "testing_zmain.h"

#undef REAL
#define COMPLEX

enum blas_order_type {
            blas_rowmajor = 101,
            blas_colmajor = 102 };

enum blas_uplo_type  {
            blas_upper = 121,
            blas_lower = 122 };

enum blas_cmach_type {
            blas_base      = 151,
            blas_t         = 152,
            blas_rnd       = 153,
            blas_ieee      = 154,
            blas_emin      = 155,
            blas_emax      = 156,
            blas_eps       = 157,
            blas_prec      = 158,
            blas_underflow = 159,
            blas_overflow  = 160,
            blas_sfmin     = 161};

enum blas_norm_type {
            blas_one_norm       = 171,
            blas_real_one_norm  = 172,
            blas_two_norm       = 173,
            blas_frobenius_norm = 174,
            blas_inf_norm       = 175,
            blas_real_inf_norm  = 176,
            blas_max_norm       = 177,
            blas_real_max_norm  = 178 };

static void
BLAS_error(char *rname, int err, int val, int x) {
  fprintf( stderr, "%s %d %d %d\n", rname, err, val, x );
  abort();
}

static
void
BLAS_zsy_norm(enum blas_order_type order, enum blas_norm_type norm,
  enum blas_uplo_type uplo, int n, const PLASMA_Complex64_t *a, int lda, double *res) {
  int i, j; double anorm, v;
  char rname[] = "BLAS_zsy_norm";

  if (order != blas_colmajor) BLAS_error( rname, -1, order, 0 );

  if (norm == blas_inf_norm) {
    anorm = 0.0;
    if (blas_upper == uplo) {
      for (i = 0; i < n; ++i) {
        v = 0.0;
        for (j = 0; j < i; ++j) {
          v += cabs( a[j + i * lda] );
        }
        for (j = i; j < n; ++j) {
          v += cabs( a[i + j * lda] );
        }
        if (v > anorm)
          anorm = v;
      }
    } else {
      BLAS_error( rname, -3, norm, 0 );
      return;
    }
  } else {
    BLAS_error( rname, -2, norm, 0 );
    return;
  }

  if (res) *res = anorm;
}

static
void
BLAS_zge_norm(enum blas_order_type order, enum blas_norm_type norm,
  int m, int n, const PLASMA_Complex64_t *a, int lda, double *res) {
  int i, j; float anorm, v;
  char rname[] = "BLAS_zge_norm";

  if (order != blas_colmajor) BLAS_error( rname, -1, order, 0 );

  if (norm == blas_frobenius_norm) {
    anorm = 0.0f;
    for (j = n; j; --j) {
      for (i = m; i; --i) {
        v = a[0];
        anorm += v * v;
        a++;
      }
      a += lda - m;
    }
    anorm = sqrt( anorm );
  } else if (norm == blas_inf_norm) {
    anorm = 0.0f;
    for (i = 0; i < m; ++i) {
      v = 0.0f;
      for (j = 0; j < n; ++j) {
        v += cabs( a[i + j * lda] );
      }
      if (v > anorm)
        anorm = v;
    }
  } else {
    BLAS_error( rname, -2, norm, 0 );
    return;
  }

  if (res) *res = anorm;
}

static
double
BLAS_dpow_di(double x, int n) {
  double rv = 1.0;

  if (n < 0) {
    n = -n;
    x = 1.0 / x;
  }

  for (; n; n >>= 1, x *= x) {
    if (n & 1)
      rv *= x;
  }

  return rv;
}

static
double
BLAS_dfpinfo(enum blas_cmach_type cmach) {
  double eps = 1.0, r = 1.0, o = 1.0, b = 2.0;
  int t = 53, l = 1024, m = -1021;
  char rname[] = "BLAS_dfpinfo";

  if ((sizeof eps) == sizeof(float)) {
    t = 24;
    l = 128;
    m = -125;
  } else {
    t = 53;
    l = 1024;
    m = -1021;
  }

  /* for (i = 0; i < t; ++i) eps *= half; */
  eps = BLAS_dpow_di( b, -t );
  /* for (i = 0; i >= m; --i) r *= half; */
  r = BLAS_dpow_di( b, m-1 );

  o -= eps;
  /* for (i = 0; i < l; ++i) o *= b; */
  o = (o * BLAS_dpow_di( b, l-1 )) * b;

  switch (cmach) {
    case blas_eps: return eps;
    case blas_sfmin: return r;
    default:
      BLAS_error( rname, -1, cmach, 0 );
      break;
  }
  return 0.0;
}

static int check_orthogonality(int, int, int, PLASMA_Complex64_t*, double);
static int check_factorization(int, int, PLASMA_Complex64_t*, PLASMA_Complex64_t*, int, PLASMA_Complex64_t*, double);
static int check_solution(int, int, int, PLASMA_Complex64_t*, int, PLASMA_Complex64_t*, PLASMA_Complex64_t*, int, double);

int testing_zgels(int argc, char **argv)
{
    int mode = 0;

    if ( argc < 1 ){
        goto usage;
    } else {
        mode = atoi(argv[0]);
    }

    /* Check for number of arguments*/
    if ( ((mode == 0) && (argc != 6)) ||
         ((mode != 0) && (argc != 7)) ){
      usage:
        USAGE("GELS", "MODE M N LDA NRHS LDB [RH]",
              "   - MODE : 0: flat, 1: tree (RH needed)\n"
              "   - M    : number of rows of the matrix A\n"
              "   - N    : number of columns of the matrix A\n"
              "   - LDA  : leading dimension of the matrix A\n"
              "   - NRHS : number of RHS\n"
              "   - LDB  : leading dimension of the matrix B\n"
              "   - RH   : Size of each subdomains\n");
        return -1;
    }

    int M     = atoi(argv[1]);
    int N     = atoi(argv[2]);
    int LDA   = atoi(argv[3]);
    int NRHS  = atoi(argv[4]);
    int LDB   = atoi(argv[5]);
    int rh;

    int K = min(M, N);
    double eps;
    int info_ortho, info_solution, info_factorization;
    int i,j;
    int LDAxN = LDA*N;
    int LDBxNRHS = LDB*NRHS;

    PLASMA_Complex64_t *A1 = (PLASMA_Complex64_t *)malloc(LDA*N*sizeof(PLASMA_Complex64_t));
    PLASMA_Complex64_t *A2 = (PLASMA_Complex64_t *)malloc(LDA*N*sizeof(PLASMA_Complex64_t));
    PLASMA_Complex64_t *B1 = (PLASMA_Complex64_t *)malloc(LDB*NRHS*sizeof(PLASMA_Complex64_t));
    PLASMA_Complex64_t *B2 = (PLASMA_Complex64_t *)malloc(LDB*NRHS*sizeof(PLASMA_Complex64_t));
    PLASMA_Complex64_t *Q  = (PLASMA_Complex64_t *)malloc(LDA*N*sizeof(PLASMA_Complex64_t));
    PLASMA_desc *T;

    /* Check if unable to allocate memory */
    if ((!A1)||(!A2)||(!B1)||(!B2)||(!Q)){
        printf("Out of Memory \n ");
        return -2;
    }

    if ( mode ) {
        rh = atoi(argv[6]);

        PLASMA_Set(PLASMA_HOUSEHOLDER_MODE, PLASMA_TREE_HOUSEHOLDER);
        PLASMA_Set(PLASMA_HOUSEHOLDER_SIZE, rh);
    }

    PLASMA_Alloc_Workspace_zgels(M, N, &T);
    eps = BLAS_dfpinfo( blas_eps );

    /*----------------------------------------------------------
    *  TESTING ZGELS
    */

    /* Initialize A1 and A2 */
    LAPACKE_zlarnv_work(IONE, ISEED, LDAxN, A1);
    for (i = 0; i < M; i++)
        for (j = 0; j < N; j++)
            A2[LDA*j+i] = A1[LDA*j+i] ;

    /* Initialize B1 and B2 */
    LAPACKE_zlarnv_work(IONE, ISEED, LDBxNRHS, B1);
    for (i = 0; i < M; i++)
        for (j = 0; j < NRHS; j++)
            B2[LDB*j+i] = B1[LDB*j+i] ;

    memset((void*)Q, 0, LDA*N*sizeof(PLASMA_Complex64_t));
    for (i = 0; i < K; i++)
        Q[LDA*i+i] = 1.0;

    /* PLASMA ZGELS */
    PLASMA_zgels(PlasmaNoTrans, M, N, NRHS, A2, LDA, T, B2, LDB);

    /* PLASMA ZGELS */
    if (M >= N)
       /* Building the economy-size Q */
       PLASMA_zungqr(M, N, K, A2, LDA, T, Q, LDA);
    else
       /* Building the economy-size Q */
       PLASMA_zunglq(M, N, K, A2, LDA, T, Q, LDA);

    printf("\n");
    printf("------ TESTS FOR PLASMA ZGELS ROUTINE -------  \n");
    printf("            Size of the Matrix %d by %d\n", M, N);
    printf("\n");
    printf(" The matrix A is randomly generated for each test.\n");
    printf("============\n");
    printf(" The relative machine precision (eps) is to be %e \n",eps);
    printf(" Computational tests pass if scaled residuals are less than 60.\n");

    /* Check the orthogonality, factorization and the solution */
    info_ortho = check_orthogonality(M, N, LDA, Q, eps);
    info_factorization = check_factorization(M, N, A1, A2, LDA, Q, eps);
    info_solution = check_solution(M, N, NRHS, A1, LDA, B1, B2, LDB, eps);

    if ((info_solution == 0)&(info_factorization == 0)&(info_ortho == 0)) {
        printf("***************************************************\n");
        printf(" ---- TESTING ZGELS ...................... PASSED !\n");
        printf("***************************************************\n");
    }
    else {
        printf("************************************************\n");
        printf(" - TESTING ZGELS ... FAILED !\n");
        printf("************************************************\n");
    }

    /*-------------------------------------------------------------
    *  TESTING ZGEQRF + ZGEQRS or ZGELQF + ZGELQS
    */

    /* Initialize A1 and A2 */
    LAPACKE_zlarnv_work(IONE, ISEED, LDAxN, A1);
    for (i = 0; i < M; i++)
        for (j = 0; j < N; j++)
            A2[LDA*j+i] = A1[LDA*j+i];

    /* Initialize B1 and B2 */
    LAPACKE_zlarnv_work(IONE, ISEED, LDBxNRHS, B1);
    for (i = 0; i < M; i++)
        for (j = 0; j < NRHS; j++)
             B2[LDB*j+i] = B1[LDB*j+i];

    memset((void*)Q, 0, LDA*N*sizeof(PLASMA_Complex64_t));
    for (i = 0; i < K; i++)
        Q[LDA*i+i] = 1.0;

    if (M >= N) {
        printf("\n");
        printf("------ TESTS FOR PLASMA ZGEQRF + ZGEQRS ROUTINE -------  \n");
        printf("            Size of the Matrix %d by %d\n", M, N);
        printf("\n");
        printf(" The matrix A is randomly generated for each test.\n");
        printf("============\n");
        printf(" The relative machine precision (eps) is to be %e \n", eps);
        printf(" Computational tests pass if scaled residuals are less than 60.\n");

        /* Plasma routines */
        PLASMA_zgeqrf(M, N, A2, LDA, T);
        PLASMA_zungqr(M, N, K, A2, LDA, T, Q, LDA);
        PLASMA_zgeqrs(M, N, NRHS, A2, LDA, T, B2, LDB);

        /* Check the orthogonality, factorization and the solution */
        info_ortho = check_orthogonality(M, N, LDA, Q, eps);
        info_factorization = check_factorization(M, N, A1, A2, LDA, Q, eps);
        info_solution = check_solution(M, N, NRHS, A1, LDA, B1, B2, LDB, eps);

        if ((info_solution == 0)&(info_factorization == 0)&(info_ortho == 0)) {
            printf("***************************************************\n");
            printf(" ---- TESTING ZGEQRF + ZGEQRS ............ PASSED !\n");
            printf("***************************************************\n");
        }
        else{
            printf("***************************************************\n");
            printf(" - TESTING ZGEQRF + ZGEQRS ... FAILED !\n");
            printf("***************************************************\n");
        }
    }
    else  {
        printf("\n");
        printf("------ TESTS FOR PLASMA ZGELQF + ZGELQS ROUTINE -------  \n");
        printf("            Size of the Matrix %d by %d\n", M, N);
        printf("\n");
        printf(" The matrix A is randomly generated for each test.\n");
        printf("============\n");
        printf(" The relative machine precision (eps) is to be %e \n", eps);
        printf(" Computational tests pass if scaled residuals are less than 60.\n");

        /* Plasma routines */
        PLASMA_zgelqf(M, N, A2, LDA, T);
        PLASMA_zunglq(M, N, K, A2, LDA, T, Q, LDA);
        PLASMA_zgelqs(M, N, NRHS, A2, LDA, T, B2, LDB);

       /* Check the orthogonality, factorization and the solution */
       info_ortho = check_orthogonality(M, N, LDA, Q, eps);
       info_factorization = check_factorization(M, N, A1, A2, LDA, Q, eps);
       info_solution = check_solution(M, N, NRHS, A1, LDA, B1, B2, LDB, eps);

       if ( (info_solution == 0) & (info_factorization == 0) & (info_ortho == 0) ) {
          printf("***************************************************\n");
          printf(" ---- TESTING ZGELQF + ZGELQS ............ PASSED !\n");
          printf("***************************************************\n");
       }
       else {
          printf("***************************************************\n");
          printf(" - TESTING ZGELQF + ZGELQS ... FAILED !\n");
          printf("***************************************************\n");
        }
    }

    /*----------------------------------------------------------
    *  TESTING ZGEQRF + ZORMQR + ZTRSM
    */

    /* Initialize A1 and A2 */
    LAPACKE_zlarnv_work(IONE, ISEED, LDAxN, A1);
    for (i = 0; i < M; i++)
        for (j = 0; j < N; j++)
            A2[LDA*j+i] = A1[LDA*j+i];

    /* Initialize B1 and B2 */
    memset(B2, 0, LDB*NRHS*sizeof(PLASMA_Complex64_t));
    LAPACKE_zlarnv_work(IONE, ISEED, LDBxNRHS, B1);
    for (i = 0; i < M; i++)
        for (j = 0; j < NRHS; j++)
            B2[LDB*j+i] = B1[LDB*j+i];

    /* PLASMA ZGEQRF+ ZUNMQR + ZTRSM */
    memset((void*)Q, 0, LDA*N*sizeof(PLASMA_Complex64_t));
    for (i = 0; i < K; i++)
        Q[LDA*i+i] = 1.0;

    if (M >= N) {
        printf("\n");
        printf("------ TESTS FOR PLASMA ZGEQRF + ZUNMQR + ZTRSM  ROUTINE -------  \n");
        printf("            Size of the Matrix %d by %d\n", M, N);
        printf("\n");
        printf(" The matrix A is randomly generated for each test.\n");
        printf("============\n");
        printf(" The relative machine precision (eps) is to be %e \n",eps);
        printf(" Computational tests pass if scaled residuals are less than 60.\n");

        PLASMA_zgeqrf(M, N, A2, LDA, T);
        PLASMA_zungqr(M, N, K, A2, LDA, T, Q, LDA);
        PLASMA_zunmqr(PlasmaLeft, PlasmaConjTrans, M, NRHS, N, A2, LDA, T, B2, LDB);
        PLASMA_ztrsm(PlasmaLeft, PlasmaUpper, PlasmaNoTrans, PlasmaNonUnit, N, NRHS, 1.0, A2, LDA, B2, LDB);
    }
    else {
        printf("\n");
        printf("------ TESTS FOR PLASMA ZGELQF + ZUNMLQ + ZTRSM  ROUTINE -------  \n");
        printf("            Size of the Matrix %d by %d\n", M, N);
        printf("\n");
        printf(" The matrix A is randomly generated for each test.\n");
        printf("============\n");
        printf(" The relative machine precision (eps) is to be %e \n",eps);
        printf(" Computational tests pass if scaled residuals are less than 60.\n");

        PLASMA_zgelqf(M, N, A2, LDA, T);
        PLASMA_ztrsm(PlasmaLeft, PlasmaLower, PlasmaNoTrans, PlasmaNonUnit, M, NRHS, 1.0, A2, LDA, B2, LDB);
        PLASMA_zunglq(M, N, K, A2, LDA, T, Q, LDA);
        PLASMA_zunmlq(PlasmaLeft, PlasmaConjTrans, N, NRHS, M, A2, LDA, T, B2, LDB);
    }

    /* Check the orthogonality, factorization and the solution */
    info_ortho = check_orthogonality(M, N, LDA, Q, eps);
    info_factorization = check_factorization(M, N, A1, A2, LDA, Q, eps);
    info_solution = check_solution(M, N, NRHS, A1, LDA, B1, B2, LDB, eps);

    if ( (info_solution == 0) & (info_factorization == 0) & (info_ortho == 0) ) {
        if (M >= N) {
            printf("***************************************************\n");
            printf(" ---- TESTING ZGEQRF + ZUNMQR + ZTRSM .... PASSED !\n");
            printf("***************************************************\n");
        }
        else {
            printf("***************************************************\n");
            printf(" ---- TESTING ZGELQF + ZTRSM + ZUNMLQ .... PASSED !\n");
            printf("***************************************************\n");
        }
    }
    else {
        if (M >= N) {
            printf("***************************************************\n");
            printf(" - TESTING ZGEQRF + ZUNMQR + ZTRSM ... FAILED !\n");
            printf("***************************************************\n");
        }
        else {
            printf("***************************************************\n");
            printf(" - TESTING ZGELQF + ZTRSM + ZUNMLQ ... FAILED !\n");
            printf("***************************************************\n");
        }
    }

    free(A1); free(A2); free(B1); free(B2); free(Q);
    PLASMA_Dealloc_Handle_Tile( &T );

    return 0;
}

/*-------------------------------------------------------------------
 * Check the orthogonality of Q
 */

static int check_orthogonality(int M, int N, int LDQ, PLASMA_Complex64_t *Q, double eps)
{
    double alpha, beta;
    double normQ;
    int info_ortho;
    int i;
    int minMN = min(M, N);

    double *work = (double *)malloc(minMN*sizeof(double));

    alpha = 1.0;
    beta  = -1.0;

    /* Build the idendity matrix USE DLASET?*/
    PLASMA_Complex64_t *Id = (PLASMA_Complex64_t *) malloc(minMN*minMN*sizeof(PLASMA_Complex64_t));
    memset((void*)Id, 0, minMN*minMN*sizeof(PLASMA_Complex64_t));
    for (i = 0; i < minMN; i++)
        Id[i*minMN+i] = (PLASMA_Complex64_t)1.0;

    /* Perform Id - Q'Q */
    if (M >= N)
        cblas_zherk(CblasColMajor, CblasUpper, CblasConjTrans, N, M, alpha, Q, LDQ, beta, Id, N);
    else
        cblas_zherk(CblasColMajor, CblasUpper, CblasNoTrans, M, N, alpha, Q, LDQ, beta, Id, M);

    BLAS_zsy_norm( blas_colmajor, blas_inf_norm, blas_upper, minMN, Id, minMN, &normQ );

    printf("============\n");
    printf("Checking the orthogonality of Q \n");
    printf("||Id-Q'*Q||_oo / (N*eps) = %e \n", normQ/(minMN*eps));

    if ( isnan(normQ / (minMN * eps)) || isinf(normQ / (minMN * eps)) || (normQ / (minMN * eps) > 60.0) ) {
        printf("-- Orthogonality is suspicious ! \n");
        info_ortho=1;
    }
    else {
        printf("-- Orthogonality is CORRECT ! \n");
        info_ortho=0;
    }

    free(work); free(Id);

    return info_ortho;
}

/*------------------------------------------------------------
 *  Check the factorization QR
 */

static int check_factorization(int M, int N, PLASMA_Complex64_t *A1, PLASMA_Complex64_t *A2, int LDA, PLASMA_Complex64_t *Q, double eps )
{
    double Anorm, Rnorm;
    PLASMA_Complex64_t alpha, beta;
    int info_factorization;
    int i,j;

    PLASMA_Complex64_t *Ql       = (PLASMA_Complex64_t *)malloc(M*N*sizeof(PLASMA_Complex64_t));
    PLASMA_Complex64_t *Residual = (PLASMA_Complex64_t *)malloc(M*N*sizeof(PLASMA_Complex64_t));
    double *work              = (double *)malloc(max(M,N)*sizeof(double));

    alpha=1.0;
    beta=0.0;

    if (M >= N) {
        /* Extract the R */
        PLASMA_Complex64_t *R = (PLASMA_Complex64_t *)malloc(N*N*sizeof(PLASMA_Complex64_t));
        memset((void*)R, 0, N*N*sizeof(PLASMA_Complex64_t));
        LAPACKE_zlacpy_work(LAPACK_COL_MAJOR,'u', M, N, A2, LDA, R, N);

        /* Perform Ql=Q*R */
        memset((void*)Ql, 0, M*N*sizeof(PLASMA_Complex64_t));
        cblas_zgemm(CblasColMajor, CblasNoTrans, CblasNoTrans, M, N, N, CBLAS_SADDR(alpha), Q, LDA, R, N, CBLAS_SADDR(beta), Ql, M);
        free(R);
    }
    else {
        /* Extract the L */
        PLASMA_Complex64_t *L = (PLASMA_Complex64_t *)malloc(M*M*sizeof(PLASMA_Complex64_t));
        memset((void*)L, 0, M*M*sizeof(PLASMA_Complex64_t));
        LAPACKE_zlacpy_work(LAPACK_COL_MAJOR,'l', M, N, A2, LDA, L, M);

    /* Perform Ql=LQ */
        memset((void*)Ql, 0, M*N*sizeof(PLASMA_Complex64_t));
        cblas_zgemm(CblasColMajor, CblasNoTrans, CblasNoTrans, M, N, M, CBLAS_SADDR(alpha), L, M, Q, LDA, CBLAS_SADDR(beta), Ql, M);
        free(L);
    }

    /* Compute the Residual */
    for (i = 0; i < M; i++)
        for (j = 0 ; j < N; j++)
            Residual[j*M+i] = A1[j*LDA+i]-Ql[j*M+i];

    BLAS_zge_norm( blas_colmajor, blas_inf_norm, M, N, Residual, M, &Rnorm );
    BLAS_zge_norm( blas_colmajor, blas_inf_norm, M, N, A2, LDA, &Anorm );

    if (M >= N) {
        printf("============\n");
        printf("Checking the QR Factorization \n");
        printf("-- ||A-QR||_oo/(||A||_oo.N.eps) = %e \n",Rnorm/(Anorm*N*eps));
    }
    else {
        printf("============\n");
        printf("Checking the LQ Factorization \n");
        printf("-- ||A-LQ||_oo/(||A||_oo.N.eps) = %e \n",Rnorm/(Anorm*N*eps));
    }

    if (isnan(Rnorm / (Anorm * N *eps)) || isinf(Rnorm / (Anorm * N *eps)) || (Rnorm / (Anorm * N * eps) > 60.0) ) {
        printf("-- Factorization is suspicious ! \n");
        info_factorization = 1;
    }
    else {
        printf("-- Factorization is CORRECT ! \n");
        info_factorization = 0;
    }

    free(work); free(Ql); free(Residual);

    return info_factorization;
}

/*--------------------------------------------------------------
 * Check the solution
 */

static int check_solution(int M, int N, int NRHS, PLASMA_Complex64_t *A, int LDA, PLASMA_Complex64_t *B, PLASMA_Complex64_t *X, int LDB, double eps)
{
    int info_solution;
    double Rnorm, Anorm, Xnorm, Bnorm;
    PLASMA_Complex64_t zone, mzone, zzero;
    double result;
    double *work = (double *)malloc(max(M, N)* sizeof(double));

    zone  =  1.0;
    mzone = -1.0;
    zzero =  0.0;

    BLAS_zge_norm( blas_colmajor, blas_inf_norm, M, N,    A, LDA, &Anorm );
    BLAS_zge_norm( blas_colmajor, blas_inf_norm, M, NRHS, B, LDB, &Bnorm );
    BLAS_zge_norm( blas_colmajor, blas_inf_norm, N, NRHS, X, LDB, &Xnorm );

    /* Compute Ax - b */
    cblas_zgemm(CblasColMajor, CblasNoTrans, CblasNoTrans, M, NRHS, N, CBLAS_SADDR(zone), A, LDA, X, LDB, CBLAS_SADDR(mzone), B, LDB);

    /* Compute A' * (Ax - b) */
    cblas_zgemm(CblasColMajor, CblasConjTrans, CblasNoTrans, N, NRHS, M, CBLAS_SADDR(zone), A, LDA, B, LDB, CBLAS_SADDR(zzero), X, LDB);
    BLAS_zge_norm( blas_colmajor, blas_inf_norm, N, NRHS, X, LDB, &Rnorm );

    if (getenv("PLASMA_TESTING_VERBOSE"))
       printf( "||A||_oo=%f\n||X||_oo=%f\n||B||_oo=%f\n||A X - B||_oo=%e\n", Anorm, Xnorm, Bnorm, Rnorm );

    result = Rnorm / ( (Anorm*Xnorm+Bnorm)*N*eps ) ;
    printf("============\n");
    printf("Checking the Residual of the solution \n");
    printf("-- ||Ax-B||_oo/((||A||_oo||x||_oo+||B||_oo).N.eps) = %e \n", result);

    if (  isnan(Xnorm) || isinf(Xnorm) || isnan(result) || isinf(result) || (result > 60.0) ) {
        printf("-- The solution is suspicious ! \n");
        info_solution = 1;
     }
    else{
        printf("-- The solution is CORRECT ! \n");
        info_solution = 0;
    }
    free(work);
    return info_solution;
}


/* multiroots/fdfsolver.c
 *
 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2007 Brian Gough
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 3 of the License, or (at
 * your option) any later version.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 */

#include <config.h>
#include <stdlib.h>
#include <string.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_multiroots.h>

gsl_multiroot_fdfsolver *
gsl_multiroot_fdfsolver_alloc (const gsl_multiroot_fdfsolver_type * T,
                                       size_t n)
{
  int status;

  gsl_multiroot_fdfsolver * s;

  s = (gsl_multiroot_fdfsolver *) malloc (sizeof (gsl_multiroot_fdfsolver));

  if (s == 0)
    {
      GSL_ERROR_VAL ("failed to allocate space for multiroot solver struct",
                        GSL_ENOMEM, 0);
    }

  s->x = gsl_vector_calloc (n);

  if (s->x == 0)
    {
      free (s);
      GSL_ERROR_VAL ("failed to allocate space for x", GSL_ENOMEM, 0);
    }

  s->f = gsl_vector_calloc (n);

  if (s->f == 0)
    {
      gsl_vector_free (s->x);
      free (s);
      GSL_ERROR_VAL ("failed to allocate space for f", GSL_ENOMEM, 0);
    }

  s->J = gsl_matrix_calloc (n,n);

  if (s->J == 0)
    {
      gsl_vector_free (s->x);
      gsl_vector_free (s->f);
      free (s);
      GSL_ERROR_VAL ("failed to allocate space for g", GSL_ENOMEM, 0);
    }

  s->dx = gsl_vector_calloc (n);

  if (s->dx == 0)
    {
      gsl_matrix_free (s->J);
      gsl_vector_free (s->x);
      gsl_vector_free (s->f);
      free (s);
      GSL_ERROR_VAL ("failed to allocate space for dx", GSL_ENOMEM, 0);
    }

  s->state = malloc (T->size);

  if (s->state == 0)
    {
      gsl_vector_free (s->dx);
      gsl_vector_free (s->x);
      gsl_vector_free (s->f);
      gsl_matrix_free (s->J);
      free (s);         /* exception in constructor, avoid memory leak */

      GSL_ERROR_VAL ("failed to allocate space for multiroot solver state",
                        GSL_ENOMEM, 0);
    }

  s->type = T ;

  status = (s->type->alloc)(s->state, n);

  if (status != GSL_SUCCESS)
    {
      free (s->state);
      gsl_vector_free (s->dx);
      gsl_vector_free (s->x);
      gsl_vector_free (s->f);
      gsl_matrix_free (s->J);
      free (s);         /* exception in constructor, avoid memory leak */

      GSL_ERROR_VAL ("failed to set solver", status, 0);
    }

  s->fdf = NULL;

  return s;
}

int
gsl_multiroot_fdfsolver_set (gsl_multiroot_fdfsolver * s,
                             gsl_multiroot_function_fdf * f,
                             const gsl_vector * x)
{
  if (s->x->size != f->n)
    {
      GSL_ERROR ("function incompatible with solver size", GSL_EBADLEN);
    }

  if (x->size != f->n)
    {
      GSL_ERROR ("vector length not compatible with function", GSL_EBADLEN);
    }

  s->fdf = f;
  gsl_vector_memcpy(s->x,x);

  return (s->type->set) (s->state, s->fdf, s->x, s->f, s->J, s->dx);
}

int
gsl_multiroot_fdfsolver_iterate (gsl_multiroot_fdfsolver * s)
{
  return (s->type->iterate) (s->state, s->fdf, s->x, s->f, s->J, s->dx);
}

void
gsl_multiroot_fdfsolver_free (gsl_multiroot_fdfsolver * s)
{
  RETURN_IF_NULL (s);
  (s->type->free) (s->state);
  free (s->state);
  gsl_vector_free (s->dx);
  gsl_vector_free (s->x);
  gsl_vector_free (s->f);
  gsl_matrix_free (s->J);
  free (s);
}

const char *
gsl_multiroot_fdfsolver_name (const gsl_multiroot_fdfsolver * s)
{
  return s->type->name;
}

gsl_vector *
gsl_multiroot_fdfsolver_root (const gsl_multiroot_fdfsolver * s)
{
  return s->x;
}

gsl_vector *
gsl_multiroot_fdfsolver_dx (const gsl_multiroot_fdfsolver * s)
{
  return s->dx;
}

gsl_vector *
gsl_multiroot_fdfsolver_f (const gsl_multiroot_fdfsolver * s)
{
  return s->f;
}


#ifndef __GSL_STATISTICS_H__
#define __GSL_STATISTICS_H__

#include <gsl/gsl_statistics_long_double.h>
#include <gsl/gsl_statistics_double.h>
#include <gsl/gsl_statistics_float.h>

#include <gsl/gsl_statistics_ulong.h>
#include <gsl/gsl_statistics_long.h>

#include <gsl/gsl_statistics_uint.h>
#include <gsl/gsl_statistics_int.h>

#include <gsl/gsl_statistics_ushort.h>
#include <gsl/gsl_statistics_short.h>

#include <gsl/gsl_statistics_uchar.h>
#include <gsl/gsl_statistics_char.h>

#endif /* __GSL_STATISTICS_H__ */


#include <erl_nif.h>
#include <stdio.h>
#include <string.h>
#include <math.h>
#include <cblas.h>

/*
--------------------------------------------------------------------|
            ------------------------------                          |
            |          LAPACKE           |                          |
            ------------------------------                          |
--------------------------------------------------------------------|
*/

void dgetrf_(int* M, int *N, double* A, int* lda, int* IPIV, int* INFO);
void dgetri_(int* N, double* A, int* lda, int* IPIV, double* WORK, int* lwork, int* INFO);

/*
--------------------------------------------------------------------|
            ------------------------------                          |
            |           INIT FC          |                          |
            ------------------------------                          |
--------------------------------------------------------------------|
*/

ERL_NIF_TERM atom_nok;
ERL_NIF_TERM atom_true;
ERL_NIF_TERM atom_false;
ERL_NIF_TERM atom_matrix;

ErlNifResourceType *MULT_YIELDING_ARG = NULL;

int load(ErlNifEnv* env, void** priv_data, ERL_NIF_TERM load_info){
    atom_nok = enif_make_atom(env, "nok\0");
    atom_true = enif_make_atom(env, "true\0");
    atom_false = enif_make_atom(env, "false\0");
    atom_matrix = enif_make_atom(env, "matrix\0");
    return 0;
}

int upgrade(ErlNifEnv* caller_env, void** priv_data, void** old_priv_data, ERL_NIF_TERM load_info){
    return 0;
}

//Gives easier access to an ErlangBinary containing a matrix.
typedef struct{
    int n_rows;
    int n_cols;

    //Content of the matrix, in row major format.
    double* content;

    //Erlang binary containing the matrix.
    ErlNifBinary bin;
} Matrix;

//Access asked coordinates of matrix
double* matrix_at(int col, int row, Matrix m){
    return &m.content[row*m.n_cols + col];
}

//Allocates memory space of for matrix of dimensions n_rows, n_cols.
//The matrix_content can be modified, until a call to array_to_erl.
//Matrix content is stored in row major format.
Matrix matrix_alloc(int n_rows, int n_cols){
    ErlNifBinary bin;

    enif_alloc_binary(sizeof(double)*n_rows*n_cols, &bin);

    Matrix matrix;
    matrix.n_cols = n_cols;
    matrix.n_rows = n_rows;
    matrix.bin = bin;
    matrix.content = (double*) bin.data;

    return matrix;
}

//Creates a duplicate of a matrix.
//This duplicate can be modified until uploaded.
Matrix matrix_dup(Matrix m){
    Matrix d = matrix_alloc(m.n_rows, m.n_cols);
    memcpy(d.content, m.content, d.bin.size);
    return d;
}

//Free an allocated matrix that was not sent back to Erlang.
void matrix_free(Matrix m){
    enif_release_binary(&m.bin);
}

//Constructs a matrix erlang term.
//No modifications can be made afterwards to the matrix.
ERL_NIF_TERM matrix_to_erl(ErlNifEnv* env, Matrix m){
    ERL_NIF_TERM term = enif_make_binary(env, &m.bin);
    return enif_make_tuple4(env, atom_matrix, enif_make_int(env,m.n_rows), enif_make_int(env,m.n_cols), term);
}

int enif_is_matrix(ErlNifEnv* env, ERL_NIF_TERM term){
    int arity;
    const ERL_NIF_TERM* content;

    if(!enif_is_tuple(env, term))
        return 0;

    enif_get_tuple(env, term, &arity, &content);
    if(arity != 4)
        return 0;

    if(content[0] != atom_matrix
        || !enif_is_number(env, content[1])
        || !enif_is_number(env, content[2])
        || !enif_is_binary(env, content[3]))

            return 0;
    return 1;
}

//Reads an erlang term as a matrix.
//As such, no modifications can be made to the red matrix.
//Returns true if it was possible to read a matrix, false otherwise
int enif_get_matrix(ErlNifEnv* env, ERL_NIF_TERM term, Matrix *dest){

    int arity;
    const ERL_NIF_TERM* content;

    if(!enif_is_tuple(env, term))
        return 0;

    enif_get_tuple(env, term, &arity, &content);
    if(arity != 4)
        return 0;

    if(content[0] != atom_matrix
        || !enif_get_int(env, content[1], &dest->n_rows)
        || !enif_get_int(env, content[2], &dest->n_cols)
        || !enif_inspect_binary(env, content[3], &dest->bin))
    {
        return 0;
    }

    dest->content = (double*) (dest->bin.data);
    return 1;
}

//Used to translate at once a number of ERL_NIF_TERM.
//Data types are inferred via content of format string:
//  n: number (int or double) translated to double.
//  m: matrix
//  i: int
int enif_get(ErlNifEnv* env, const ERL_NIF_TERM* erl_terms, const char* format, ...){
    va_list valist;
    va_start(valist, format);
    int valid = 1;

    while(valid && *format != '\0'){
        switch(*format++){
            case 'n':
                //Read a number as a double.
                ;
                double *d = va_arg(valist, double*);
                int i;
                if(!enif_get_double(env, *erl_terms, d))
                    if(enif_get_int(env, *erl_terms, &i))
                        *d = (double) i;
                    else valid = 0;
                break;

            case 'm':
                //Reads a matrix.
                valid = enif_get_matrix(env, *erl_terms, va_arg(valist, Matrix*));
                break;

            case 'i':
                //Reads an int.
                valid = enif_get_int(env, *erl_terms, va_arg(valist, int*));
                break;

            default:
                //Unknown type... give an error.
                valid = 0;
                break;
        }
        erl_terms ++;
    }

    va_end(valist);
    return valid;
}

//----------------------------------------------------------------------------------------------------|
//                        ------------------------------------------                                  |
//                        |                   NIFS                 |                                  |
//                        ------------------------------------------                                  |
//----------------------------------------------------------------------------------------------------|

//@arg 0: List of Lists of numbers.
//@return: Matrix of dimension
ERL_NIF_TERM nif_matrix(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]){
    unsigned n_rows, line_length, dest = 0, n_cols = -1;
    ERL_NIF_TERM list = argv[0], row, elem;
    Matrix m;

    //Reading incoming matrix.
    if(!enif_get_list_length(env, list, &n_rows) && n_rows > 0)
        return enif_make_badarg(env);

    for(int i = 0; enif_get_list_cell(env, list, &row, &list); i++){
        if(!enif_get_list_length(env, row, &line_length))
            return enif_make_badarg(env);

        if(n_cols == -1){
            //Allocate binary, make matrix accessor.
            n_cols = line_length;
            m = matrix_alloc(n_rows,n_cols);
        }

        if(n_cols != line_length)
            return enif_make_badarg(env);

        for(int j = 0; enif_get_list_cell(env, row, &elem, &row); j++){
            if(!enif_get_double(env, elem, &m.content[dest])){
                int i;
                if(enif_get_int(env, elem, &i)){
                    m.content[dest] = (double) i;
                }
                else{
                    return enif_make_badarg(env);
                }
            }
            dest++;
        }
    }

    return matrix_to_erl(env, m);
}

#define PRECISION 10

//Used for debug purpose.
void debug_write(char info[]){
    FILE* fp = fopen("debug.txt", "a");
    fprintf(fp, info);
    fprintf(fp, "\n");
    fclose(fp);
}

void debug_write_matrix(Matrix m){
    char *content = enif_alloc(sizeof(char)*((2*m.n_cols-1)*m.n_rows*PRECISION + m.n_rows*2 + 3));
    content[0] = '[';
    content[1] = '\0';
    char converted[PRECISION];

    for(int i=0; i<m.n_rows; i++){
        strcat(content, "[");
        for(int j = 0; j<m.n_cols; j++){
            snprintf(converted, PRECISION-1, "%.5lf", m.content[i*m.n_cols+j]);
            strcat(content, converted);
            if(j != m.n_cols-1)
                strcat(content, " ");
        }
        strcat(content, "]");
    }
    strcat(content, "]");
    debug_write(content);
    enif_free(content);

}

//@arg 0: matrix.
//@arg 1: int, coord m: row
//@arg 2: int, coord n: col
//@return: double, at cord Matrix(m,n).
ERL_NIF_TERM nif_get(ErlNifEnv * env, int argc, const ERL_NIF_TERM argv[]){
    int m,n;
    Matrix matrix;

    if(!enif_get(env, argv, "iim", &m, &n, &matrix))
        return enif_make_badarg(env);
    m--, n--;

    if(m < 0 || m >= matrix.n_rows || n < 0 || n >= matrix.n_cols)
        return enif_make_badarg(env);

    int index = m*matrix.n_cols+n;
    return enif_make_double(env, matrix.content[index]);
}

ERL_NIF_TERM nif_at(ErlNifEnv * env, int argc, const ERL_NIF_TERM argv[]){
    int n;
    Matrix matrix;

    if(!enif_get(env, argv, "mi", &matrix, &n))
        return enif_make_badarg(env);
    n--;

    if( n < 0 || n >= matrix.n_cols * matrix.n_rows)
        return enif_make_badarg(env);

    return enif_make_double(env, matrix.content[n]);
}

//Matrix to flattened list of ints
ERL_NIF_TERM nif_mtfli(ErlNifEnv * env, int argc, const ERL_NIF_TERM argv[]){
    Matrix M;
    if(!enif_get(env, argv, "m", &M)){
        return enif_make_badarg(env);
    }

    int n_elems = M.n_cols * M.n_rows;
    ERL_NIF_TERM *arr = enif_alloc(sizeof(ERL_NIF_TERM)*n_elems);
    for(int i = 0; i<n_elems; i++){
        arr[i] = enif_make_int(env, (int)M.content[i]);
    }

    ERL_NIF_TERM result = enif_make_list_from_array(env, arr, n_elems);
    enif_free(arr);
    return result;
}

//Matrix to flattened list of ints
ERL_NIF_TERM nif_mtfl(ErlNifEnv * env, int argc, const ERL_NIF_TERM argv[]){
    Matrix M;
    if(!enif_get(env, argv, "m", &M)){
        return enif_make_badarg(env);
    }

    int n_elems = M.n_cols * M.n_rows;
    ERL_NIF_TERM *arr = enif_alloc(sizeof(ERL_NIF_TERM)*n_elems);
    for(int i = 0; i<n_elems; i++){
        arr[i] = enif_make_double(env, M.content[i]);
    }

    ERL_NIF_TERM result = enif_make_list_from_array(env, arr, n_elems);
    enif_free(arr);
    return result;
}

//Equal all doubles
//Compares whether all doubles are approximately the same.
int equal_ad(double* a, double* b, int size){
    for(int i = 0; i<size; i++){
        if(fabs(a[i] - b[i])> 1e-6)
            return 0;
    }
    return 1;
}

//@arg 0: Array.
//@arg 1: Array.
//@return: true if arrays share content, false if they have different content || size..
ERL_NIF_TERM nif_equals(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]){
    Matrix a,b;

    if(!enif_get(env, argv, "mm", &a, &b))
        return atom_false;

    //Compare number of columns and rows
    if((a.n_cols != b.n_cols || a.n_rows != b.n_rows))
        return atom_false;

    //Compare content of arrays
    if(!equal_ad(a.content, b.content, a.n_cols*a.n_rows))
        return atom_false;

    return atom_true;
}

//@arg 0: int.
//@arg 1: Array.
//@return: returns an array, containing requested row.
ERL_NIF_TERM nif_row(ErlNifEnv * env, int argc, const ERL_NIF_TERM argv[]){
    int row_req;
    Matrix matrix;
    if(!enif_get(env, argv, "im", &row_req, &matrix))
        return enif_make_badarg(env);

    row_req--;
    if(row_req<0 || row_req >= matrix.n_rows)
        return enif_make_badarg(env);

    Matrix row = matrix_alloc(1, matrix.n_cols);
    memcpy(row.content, matrix.content + (row_req * matrix.n_cols), matrix.n_cols*sizeof(double));

    return matrix_to_erl(env, row);
}

//@arg 0: int.
//@arg 1: Array.
//@return: returns an array, containing requested col.
ERL_NIF_TERM nif_col(ErlNifEnv * env, int argc, const ERL_NIF_TERM argv[]){
    int col_req;
    Matrix matrix;
    if(!enif_get(env, argv, "im", &col_req, &matrix))
        return enif_make_badarg(env);

    col_req--;
    if(col_req<0 || col_req >= matrix.n_cols)
        return enif_make_badarg(env);

    Matrix col = matrix_alloc(matrix.n_rows, 1);

    for(int i = 0; i < matrix.n_rows; i++){
        col.content[i] = matrix.content[i * matrix.n_rows + col_req];
    }

    return matrix_to_erl(env, col);
}

//@arg 0: int.
//@arg 1: int.
//@return: empty Matrix of requested dimension..
ERL_NIF_TERM nif_zeros(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]){
    int m,n;
    if(!enif_get(env, argv, "ii", &m, &n))
        return enif_make_badarg(env);

    Matrix a = matrix_alloc(m,n);
    memset(a.content, 0, sizeof(double)*m*n);
    return matrix_to_erl(env, a);
}

//@arg 0: int.
//@arg 1: int.
//@return: empty matrix of dimension [arg 0, arg 1]..
ERL_NIF_TERM nif_eye(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]){
    int m;
    if(!enif_get_int(env, argv[0], &m))
        return enif_make_badarg(env);

    if(m <= 0)
        return enif_make_badarg(env);

    Matrix a = matrix_alloc(m,m);
    memset(a.content, 0, sizeof(double)*m*m);
    for(int i = 0; i<m; i++){
        a.content[i*m+i] = 1.0;
    }
    return matrix_to_erl(env, a);
}

//Either element-wise multiplication, or multiplication of a matrix by a number.
ERL_NIF_TERM nif_mult(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]){

    Matrix a,b;
    double c;

    if(enif_get(env, argv, "mn", &a, &c)){
        Matrix d = matrix_alloc(a.n_rows, a.n_cols);

        for(int i = 0; i<a.n_cols*a.n_rows; i++){
            d.content[i] = a.content[i] * c;
        }
        return matrix_to_erl(env, d);
    }
    else
    if(enif_get(env, argv, "mm", &a, &b)
            && a.n_rows*a.n_cols == b.n_rows*b.n_cols){

        Matrix d = matrix_alloc(a.n_rows, a.n_cols);

        for(int i = 0; i < a.n_rows*a.n_cols; i++){
            d.content[i] = a.content[i] * b.content[i];
        }
        return matrix_to_erl(env, d);
    }

    return enif_make_badarg(env);
}

//Either element-wise addition, or addition of a matrix by a number.
ERL_NIF_TERM nif_add(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]){

    Matrix a,b;
    double c;

    if(enif_get(env, argv, "mn", &a, &c)){
        Matrix d = matrix_alloc(a.n_rows, a.n_cols);

        for(int i = 0; i<a.n_cols*a.n_rows; i++){
            d.content[i] = a.content[i] + c;
        }
        return matrix_to_erl(env, d);
    }
    else
    if(enif_get(env, argv, "mm", &a, &b)
            && a.n_rows*a.n_cols == b.n_rows*b.n_cols){

        Matrix d = matrix_alloc(a.n_rows, a.n_cols);

        for(int i = 0; i < a.n_rows*a.n_cols; i++){
            d.content[i] = a.content[i] + b.content[i];
        }
        return matrix_to_erl(env, d);
    }

    return enif_make_badarg(env);
}

//Either element-wise subtraction, or subtraction of a matrix by a number.
ERL_NIF_TERM nif_sub(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]){

    Matrix a,b;
    double c;

    if(enif_get(env, argv, "mn", &a, &c)){
        Matrix d = matrix_alloc(a.n_rows, a.n_cols);

        for(int i = 0; i<a.n_cols*a.n_rows; i++){
            d.content[i] = a.content[i] - c;
        }
        return matrix_to_erl(env, d);
    }
    else
    if(enif_get(env, argv, "mm", &a, &b)
            && a.n_rows*a.n_cols == b.n_rows*b.n_cols){

        Matrix d = matrix_alloc(a.n_rows, a.n_cols);

        for(int i = 0; i < a.n_rows*a.n_cols; i++){
            d.content[i] = a.content[i] - b.content[i];
        }
        return matrix_to_erl(env, d);
    }

    return enif_make_badarg(env);
}

//Either element-wise division, or division of a matrix by a number.
ERL_NIF_TERM nif_divide(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]){

    Matrix a,b;
    double c;

    if(enif_get(env, argv, "mn", &a, &c)){

        if(c!=0.0){
            Matrix d = matrix_alloc(a.n_rows, a.n_cols);

            for(int i = 0; i<a.n_cols*a.n_rows; i++){
                d.content[i] = a.content[i] / c;
            }
            return matrix_to_erl(env, d);
        }
    }
    else if(enif_get(env, argv, "mm", &a, &b)
            && a.n_rows*a.n_cols == b.n_rows*b.n_cols){

        Matrix d = matrix_alloc(a.n_rows, a.n_cols);

        for(int i = 0; i < a.n_rows*a.n_cols; i++){
            if(b.content[i] == 0.0){
                return enif_make_badarg(env);
            }
            else{
                d.content[i] = a.content[i] / b.content[i];
            }
        }
        return matrix_to_erl(env, d);
    }

    return enif_make_badarg(env);
}

//Transpose of a matrix.
Matrix tr(Matrix a){
    Matrix result = matrix_alloc(a.n_cols ,a.n_rows);

    for(int j = 0; j < a.n_rows; j++){
        for(int i = 0; i < a.n_cols; i++){
            result.content[i*result.n_cols+j] = a.content[j*a.n_cols+i];
        }
    }
    return result;
}
ERL_NIF_TERM nif_transpose(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]){

    Matrix a;
    if(!enif_get_matrix(env, argv[0], &a))
        return enif_make_badarg(env);

    return matrix_to_erl(env, tr(a));
}

//arg0: Matrix.
ERL_NIF_TERM nif_inv(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]){

    Matrix a;
    if(!enif_get_matrix(env, argv[0], &a))
        return enif_make_badarg(env);

    Matrix inv = matrix_dup(a);

    int N = a.n_rows;
    int *IPIV = enif_alloc(sizeof(int)*N);
    int LWORK = N*N;
    double* WORK = enif_alloc(sizeof(int)*N*N);
    int INFO1, INFO2;

    dgetrf_(&N,&N,inv.content,&N,IPIV,&INFO1);
    dgetri_(&N,inv.content,&N,IPIV,WORK,&LWORK,&INFO2);

    enif_free(IPIV);
    enif_free(WORK);
    ERL_NIF_TERM result;

    if(INFO1 > 0 || INFO2 > 0){
        result = enif_raise_exception(env, enif_make_atom(env, "nif_inv: could not invert singular matrix."));
        matrix_free(inv);
    }
    else if(INFO1 < 0 || INFO2 < 0){
        result = enif_raise_exception(env, enif_make_atom(env, "nif_inv: LAPACK error."));
        matrix_free(inv);
    }
    else result = matrix_to_erl(env, inv);

    return result;
}

//----------------------------------------------------------------------------------------------------|
//                        ------------------------------------------                                  |
//                        |                   CBLAS                |                                  |
//                        ------------------------------------------                                  |
//----------------------------------------------------------------------------------------------------|
//Some CBLAS wrappers.

//Calculates the norm of input vector/matrix, aka the square root of the sum of its composants.
ERL_NIF_TERM nif_dnrm2(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]){
    Matrix x;

    if(!enif_get(env, argv, "m", &x)){
        return enif_make_badarg(env);
    }

    double result = cblas_dnrm2(x.n_cols*x.n_rows, x.content, 1);

    return enif_make_double(env, result);
}

//Performs blas_ddot
//Input: two vectors / matrices
ERL_NIF_TERM nif_ddot(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]){
    Matrix x,y;

    if(!enif_get(env, argv, "mm", &x, &y)){
        return enif_make_badarg(env);
    }

    int n = fmin(x.n_rows*x.n_cols, y.n_rows*y.n_cols);
    if(n <= 0){
        return enif_make_badarg(env);
    }

    double result = cblas_ddot(n, x.content, 1, y.content, 1);

    return enif_make_double(env, result);
}

//Performs blas_daxpy
//Input: a number, vectors X and Y
//Output: a vector of same dimension then Y, containing alpha X + Y
//------------------------------------------------------------------------
ERL_NIF_TERM nif_daxpy(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]){
    Matrix x,y;
    int n;
    double alpha;

    if(!enif_get(env, argv, "inmm", &n, &alpha, &x, &y)){
        return enif_make_badarg(env);
    }

    if(fmin(x.n_rows, x.n_cols) * fmin(y.n_rows, y.n_cols) != 1){
        //We are not using vectors...
        return enif_make_badarg(env);
    }

    Matrix ny = matrix_dup(y);

    cblas_daxpy(n, alpha, x.content, 1, ny.content, 1);

    return matrix_to_erl(env, ny);
}

// Arguments: alpha, A, x, beta, y
// Performs alpha*A*x + beta*y.
// alpha, beta are numbers
// A, x, y are matrices (x and y being vectors)
// x and y are expected to have a length of A.n_cols
ERL_NIF_TERM nif_dgemv(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]){
    Matrix A,x,y;
    double alpha, beta;

    if(!enif_get(env, argv, "nmmnm", &alpha, &A, &x, &beta, &y)){
        enif_make_badarg(env);
    }

    //Check dimensions compatibility
    int vec_length = fmin(fmax(x.n_cols, x.n_rows), fmax(y.n_cols, y.n_rows));
    if(vec_length < A.n_cols || fmin(x.n_cols, x.n_rows) != 1 || fmin(y.n_cols, y.n_rows) != 1){
        enif_make_badarg(env);
    }

    Matrix ny = matrix_dup(y);

    cblas_dgemv(CblasRowMajor, CblasNoTrans, A.n_rows, A.n_cols, alpha, A.content, A.n_rows, x.content, 1,  beta, ny.content, 1);

    return matrix_to_erl(env, ny);
}

//Arguments: double alpha, matrix A, matrix B, double beta, matrix C
ERL_NIF_TERM nif_dgemm(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]){
    Matrix A, B;
    double alpha = 1.0;
    double beta = 0.0;

    if(!enif_get(env, argv, "mm", &A, &B)
            || A.n_cols != B.n_rows){

        return enif_make_badarg(env);
    }

    Matrix C = matrix_alloc(A.n_rows, B.n_cols);

    cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans,
    A.n_rows, B.n_cols, A.n_cols,
    alpha, A.content, A.n_cols, B.content, B.n_rows,
    1.0, C.content, C.n_cols);

    return matrix_to_erl(env, C);
}

ErlNifFunc nif_funcs[] = {
    {"matrix", 1, nif_matrix},
    {"get", 3, nif_get},
    {"at", 2, nif_at},
    {"mtfli", 1, nif_mtfli},
    {"mtfl", 1, nif_mtfl},
    {"equals", 2, nif_equals},
    {"row", 2, nif_row},
    {"col", 2, nif_col},
    {"zeros", 2, nif_zeros},
    {"eye", 1, nif_eye},
    {"mult", 2, nif_mult},
    {"add",  2, nif_add},
    {"sub",  2, nif_sub},
    {"divide", 2, nif_divide},
    {"transpose", 1, nif_transpose},
    {"inv", 1, nif_inv},

    //--- BLAS----------
    {"nrm2", 1, nif_dnrm2},
    {"vec_dot", 2, nif_ddot},
    {"dot", 2, nif_dgemm}
};

ERL_NIF_INIT(numerl, nif_funcs, load, NULL, upgrade, NULL)


//#####################################################################
// Header blas
//#####################################################################
#ifdef GEODE_BLAS

// On Mac, we can't include Accelerate.h unless __SSE__ is available
#if !defined(__APPLE__) || (defined(__SSE__) && !defined(__COVERITY__))

#ifndef __blas_wrap_iterating__
#ifndef __blas_wrap_h__
#define __blas_wrap_h__

#ifdef GEODE_MKL
#include <mkl_lapack.h>
#include <mkl_cblas.h>
#include <mkl_blas.h>
#include <mkl_trans.h>
#else
#ifdef __APPLE__
#include <Accelerate/Accelerate.h>
#else
extern "C" {
#include <cblas.h>
}
#endif
#endif
#include <geode/array/RawArray.h>
#include <geode/array/Array2d.h>
#include <geode/geometry/Box.h>
namespace geode {

// Problem-dependent parameter inspection
template<class T> GEODE_CORE_EXPORT int ilaenv(int ispec,const char* name,const char* opts,int m,int n);

template<> struct FromPython<CBLAS_TRANSPOSE>{GEODE_CORE_EXPORT static CBLAS_TRANSPOSE convert(PyObject* object);};

#define WRAP(declaration) \
  static declaration GEODE_UNUSED; \
  static declaration

#define __blas_wrap_iterating__

#ifdef GEODE_MKL
#  define BC(name) s##name
#  define MKL_BC(name) mkl_s##name
#  define DECLARE(name,...)
#else
#  define BC(name) s##name##_
#  define DECLARE(name,...) extern "C" { int s##name##_(__VA_ARGS__); }
#endif
#define CBC(name) cblas_s##name
#define SA(name) ("a" #name)
#define T float
#include "blas.h"
#undef SA
#undef BC
#undef CBC
#undef MKL_BC
#undef DECLARE
#undef T

#ifdef GEODE_MKL
#  define BC(name) d##name
#  define MKL_BC(name) mkl_d##name
#  define DECLARE(name,...)
#else
#  define BC(name) d##name##_
#  define DECLARE(name,...) extern "C" { int d##name##_(__VA_ARGS__); }
#endif
#define CBC(name) cblas_d##name
#define SA(name) ("d" #name)
#define T double
#include "blas.h"
#undef SA
#undef BC
#undef CBC
#undef MKL_BC
#undef DECLARE
#undef T

#undef __blas_wrap_iterating__
#undef WRAP

}
#endif
#else // __blas_wrap_iterating__

// Scale a vector: x = ax
WRAP(void scal(int n, T alpha, T* x)) {
  if(alpha) CBC(scal)(n,alpha,x,1);
  else memset(x,0,n*sizeof(T)); // mkl scal doesn't work for alpha = 0
}

// Scale a vector: x = ax
WRAP(void scal(T alpha, RawArray<T> x)) {
  scal(x.size(),alpha,x.data());
}

// Scale a vector: x = ax
WRAP(void scal(T alpha, Subarray<T> x)) {
  if(alpha) CBC(scal)(x.m,alpha,x.data(),x.stride);
  else x.fill(0);
}

DECLARE(geqrf,int*,int*,T*,int*,T*,T*,int*,int*)
DECLARE(gelqf,int*,int*,T*,int*,T*,T*,int*,int*)

// QR factorize a dense matrix without pivoting.  Call geqrf_work to define the required work size
WRAP(void geqrf(CBLAS_UPLO uplo, RawArray<T,2> A, RawArray<T> tau, Array<T>& work)) {
  int info,lda=max(1,A.n),r=min(A.m,A.n),lwork=work.max_size();
  GEODE_ASSERT(tau.size()==r);if(!r) return; // lapack requires tau.size()=1 here, so do nothing instead
  (uplo==CblasUpper?BC(gelqf):BC(geqrf))(const_cast<int*>(&A.n),const_cast<int*>(&A.m),A.data(),&lda,tau.data(),work.data(),&lwork,&info);
  GEODE_ASSERT(!info);
}

// Compute work.size() required for geqrf
WRAP(int geqrf_work(CBLAS_UPLO uplo, RawArray<T,2> A)) {
  if(!A.m || !A.n) return 0;
  T work;int info,lda=max(1,A.n),lwork=-1;
  (uplo==CblasUpper?BC(gelqf):BC(geqrf))(const_cast<int*>(&A.n),const_cast<int*>(&A.m),0,&lda,0,&work,&lwork,&info);
  return max((int)work,A.m,A.n); // Mkl returns the wrong work size, so grow it if necessary
}

DECLARE(geqp3,int*,int*,T*,int*,int*,T*,T*,int*,int*)

// QR factorize a dense matrix with column pivoting
WRAP(void geqp3(RawArray<T,2> A, RawArray<int> p, RawArray<T> tau, Array<T>& work)) {
  GEODE_ASSERT(tau.size()==max(1,min(A.m,A.n)) && p.size()==A.m);
  int info,lda=max(1,A.n),lwork=work.max_size();p.fill(0);
  BC(geqp3)(const_cast<int*>(&A.n),const_cast<int*>(&A.m),A.data(),&lda,p.data(),tau.data(),work.data(),&lwork,&info);
}

// Compute work.size() required for geqp3
WRAP(int geqp3_work(RawArray<T,2> A)) {
  T work;int info,lda=max(1,A.n),lwork=-1;
  BC(geqp3)(const_cast<int*>(&A.n),const_cast<int*>(&A.m),0,&lda,0,0,&work,&lwork,&info);
  return (int)work;
}

DECLARE(ormqr,char*,char*,int*,int*,int*,T*,int*,T*,T*,int*,T*,int*,int*)
DECLARE(ormlq,char*,char*,int*,int*,int*,T*,int*,T*,T*,int*,T*,int*,int*)

// Multiply a matrix C by Q or Q^T, where Q is computed by geqrf
WRAP(void ormqr(CBLAS_UPLO uplo, CBLAS_SIDE s, CBLAS_TRANSPOSE t, Subarray<const T,2> A, RawArray<const T> tau, Subarray<T,2> C, Array<T>& work)) {
  const char *side=s==CblasLeft?"R":"L",*trans=t==CblasTrans?"T":"N"; // side flipped due to row-major vs. column major
  int k=min(A.m,A.n),c=s==CblasLeft?C.m:C.n,lda=max(1,A.stride),ldc=max(1,C.stride),lwork=work.max_size(),info;
  GEODE_ASSERT(k<=c && c<=(uplo==CblasUpper?A.m:A.n) && tau.size()==k);
  if(!k) return; // lapack requires tau.size()=1 here, so do nothing instead
  (uplo==CblasUpper?BC(ormlq):BC(ormqr))(const_cast<char*>(side),const_cast<char*>(trans),const_cast<int*>(&C.n),const_cast<int*>(&C.m),&k,
      const_cast<T*>(A.data()),&lda,const_cast<T*>(tau.data()),C.data(),&ldc,work.data(),&lwork,&info);
  GEODE_ASSERT(!info);
}

// Compute work.size() required by ormqr
WRAP(int ormqr_work(CBLAS_UPLO uplo, CBLAS_SIDE s, CBLAS_TRANSPOSE t, Subarray<const T,2> A, Subarray<T,2> C)) {
  const char *side=s==CblasLeft?"R":"L",*trans=t==CblasTrans?"T":"N"; // side flipped due to row-major vs. column major
  int k=min(A.m,A.n),lda=max(1,A.stride),ldc=max(1,C.stride),lwork=-1,info;T work;
  GEODE_ASSERT((uplo==CblasUpper?A.m:A.n)>=(s==CblasLeft?C.m:C.n));
  if(!k) return 0; // lapack requires tau.size()=1 here, so do nothing instead
  (uplo==CblasUpper?BC(ormlq):BC(ormqr))(const_cast<char*>(side),const_cast<char*>(trans),const_cast<int*>(&C.n),const_cast<int*>(&C.m),&k,0,&lda,0,0,&ldc,&work,&lwork,&info);
  GEODE_ASSERT(!info);
  return (int)work;
}

// Multiply a vector C by Q or Q^T, where Q is computed by geqrf (the single vector case of ormqr above)
WRAP(void ormqr(CBLAS_UPLO uplo, CBLAS_SIDE s, CBLAS_TRANSPOSE t, Subarray<const T,2> A, RawArray<const T> tau, RawArray<T> C, Array<T>& work)) {
  int r=C.size(),c=1;if(s==CblasRight) swap(r,c);
  ormqr(uplo,s,t,A,tau,C.reshape(r,c),work);
}

// Compute work.size() required by the vector case of ormqr
WRAP(int ormqr_work(CBLAS_UPLO uplo,CBLAS_SIDE s,CBLAS_TRANSPOSE t,Subarray<const T,2> A,RawArray<T> C)) {
  int r=C.size(),c=1;if(s==CblasRight) swap(r,c);
  return ormqr_work(uplo,s,t,A,C.reshape(r,c));
}

DECLARE(orgqr,int*,int*,int*,T*,int*,T*,T*,int*,int*)
DECLARE(orglq,int*,int*,int*,T*,int*,T*,T*,int*,int*)

// Expand the QR factorization computed by geqrf into a dense matrix in standard format
WRAP(void orgqr(CBLAS_UPLO uplo, int r, Subarray<T,2> A, RawArray<const T> tau, Array<T>& work)) {
  int info,m=A.m,n=A.n,lda=max(1,A.stride),lwork=work.max_size();
  GEODE_ASSERT(r<=min(m,n) && (uplo==CblasUpper?n<=m:m<=n) && tau.size()==r);
  (uplo==CblasUpper?BC(orglq):BC(orgqr))(&n,&m,&r,A.data(),&lda,const_cast<T*>(tau.data()),work.data(),&lwork,&info);
}

// Compute work.size() required by orgqr
WRAP(int orgqr_work(CBLAS_UPLO uplo, int r, Subarray<T,2> A)) {
  T work;int info,m=A.m,n=A.n,lda=max(1,A.stride),lwork=-1;
  GEODE_ASSERT(r<=min(m,n) && (uplo==CblasUpper?n<=m:m<=n));
  (uplo==CblasUpper?BC(orglq):BC(orgqr))(&n,&m,&r,0,&lda,0,&work,&lwork,&info);
  return (int)work;
}

// y = alpha*A^op x + beta*y
WRAP(void gemv(CBLAS_TRANSPOSE t, T alpha, Subarray<const T,2> A, const T* x, T beta, T* y)) {
  int m=A.m,n=A.n;if(t==CblasTrans) swap(m,n);
  if(!n) scal(m,beta,y); // work around bug in mkl
  else CBC(gemv)(CblasRowMajor,t,A.m,A.n,alpha,A.data(),max(1,A.stride),x,1,beta,y,1);
}

// y = alpha*A^op x + beta*y
WRAP(void gemv(CBLAS_TRANSPOSE t, T alpha, Subarray<const T,2> A, RawArray<const T> x, T beta, RawArray<T> y)) {
  int m=A.m,n=A.n;if(t==CblasTrans) swap(m,n);
  GEODE_ASSERT(x.size()==n && m==y.size());
  gemv(t,alpha,A,x.data(),beta,y.data());
}

// y = alpha*A x + beta*y
WRAP(void gemv(T alpha, Subarray<const T,2> A, const T* x, T beta, T* y)) {
  gemv(CblasNoTrans,alpha,A,x,beta,y);
}

// y = alpha*A x + beta*y
WRAP(void gemv(T alpha, Subarray<const T,2> A, RawArray<const T> x, T beta, RawArray<T> y)) {
  gemv(CblasNoTrans,alpha,A,x,beta,y);
}

// y = alpha*A x + beta*y for symmetric A
WRAP(void symv(CBLAS_UPLO uplo, T alpha, Subarray<const T,2> A, RawArray<const T> x, T beta, RawArray<T> y)) {
  GEODE_ASSERT(A.m==A.n && x.size()==A.m && y.size()==A.m);
  CBC(symv)(CblasRowMajor,uplo,A.m,alpha,A.data(),max(1,A.stride),x.data(),1,beta,y.data(),1);
}

// // y = alpha*A^op+beta*y for banded A with kl subdiagonals and ku superdiagonals.
WRAP(void gbmv(CBLAS_TRANSPOSE t, int m, int n, int kl, int ku, T alpha, RawArray<const T> A, const T* x, T beta, T* y)) {
  int lda=kl+ku+1;GEODE_ASSERT(kl>=0 && ku>=0 && A.size()==n*lda);
  CBC(gbmv)(CblasColMajor,t,m,n,kl,ku,alpha,A.data(),lda,x,1,beta,y,1);
}

DECLARE(gesdd,char*,int*,int*,T*,int*,T*,T*,int*,T*,int*,T*,int*,int*,int*)

// Compute the singular value decomposition of a dense matrix.  A is destroyed.
WRAP(void gesdd(Array<T,2>& A, Array<T>& s, Array<T,2>& U, Array<T,2>& Vt, Array<T>& work, bool all)) {
  char job=all?'A':'S';int r=min(A.m,A.n),liwork=8*r,lwork=(work.max_size()*sizeof(T)-liwork*sizeof(int))/sizeof(T),info;
  U.resize(A.m,all?A.m:r);Vt.resize(all?A.n:r,A.n);s.resize(r);
  BC(gesdd)(&job,&A.n,&A.m,A.data(),&A.n,s.data(),Vt.data(),&Vt.n,U.data(),&U.n,work.data(),&lwork,reinterpret_cast<int*>(work.data()+lwork),&info);
}

// Compute work.size() required by gesdd with singular vectors
WRAP(int gesdd_work(Array<T,2>& A, Array<T,2>& U, Array<T,2>& Vt, bool all)) {
  T work;char job=all?'A':'S';int r=min(A.m,A.n),liwork=max(1,8*r),lwork=-1,iwork,info;
  BC(gesdd)(&job,&A.n,&A.m,0,&A.n,0,0,&A.n,0,&A.m,&work,&lwork,&iwork,&info);
  return int(work+(liwork*sizeof(int)+sizeof(T)-1)/sizeof(T));
}

// Compute the singular values of a dense matrix without the singular vectors.  A is destroyed.
WRAP(void gesdd(Array<T,2>& A, Array<T>& s, Array<T>& work)) {
  char job='N';int r=min(A.m,A.n),one=1,info,liwork=8*r,lwork=(work.max_size()*sizeof(T)-liwork*sizeof(int))/sizeof(T);
  s.resize(r);
  BC(gesdd)(&job,&A.n,&A.m,A.data(),&A.n,s.data(),0,&one,0,&one,work.data(),&lwork,reinterpret_cast<int*>(work.data()+lwork),&info);
}

// Compute work.size() required by gesdd without singular vectors
WRAP(int gesdd_work(Array<T,2>& A)) {
  char job='N';T work;int r=min(A.m,A.n),one=1,info,liwork=8*r,iwork,lwork=-1;
  BC(gesdd)(&job,&A.n,&A.m,0,&A.n,0,0,&one,0,&one,&work,&lwork,&iwork,&info);
  return int(work+(liwork*sizeof(int)+sizeof(T)-1)/sizeof(T));
}

DECLARE(syevd,char*,char*,int*,T*,int*,T*,T*,int*,int*,int*,int*)

// Compute the eigenvalues of a symmetric matrix.  A is destroyed.
WRAP(void syevd(CBLAS_UPLO uplo, Subarray<T,2> A, Array<T>& w, Array<T>& work)) {
  int n=A.n;
  GEODE_ASSERT(A.m==n);
  T lwork_;int liwork,query=-1,lda=A.stride,info;
  char *job=const_cast<char*>("N"),*uplo_=const_cast<char*>(uplo==CblasLower?"U":"L");
  BC(syevd)(job,uplo_,&n,A.data(),&lda,0,&lwork_,&query,&liwork,&query,&info);
  int lwork=(int)lwork_;
  GEODE_ASSERT(lwork*sizeof(T)+liwork*sizeof(int)>=work.max_size()*sizeof(T));
  w.resize(n);
  BC(syevd)(job,uplo_,&n,A.data(),&lda,w.data(),work.data(),&lwork,reinterpret_cast<int*>(work.data()+lwork),&liwork,&info);
}

// Compute work.size() required by syevd
WRAP(int syevd_work(CBLAS_UPLO uplo, Subarray<const T,2> A)) {
  int n=A.n;
  GEODE_ASSERT(A.m==n);
  T work;int iwork,lda=A.stride,info,lwork=-1;
  char *job=const_cast<char*>("N"),*uplo_=const_cast<char*>(uplo==CblasLower?"U":"L");
  BC(syevd)(job,uplo_,&n,const_cast<T*>(A.data()),&lda,0,&work,&lwork,&iwork,&lwork,&info);
  return int(work+(iwork*sizeof(int)+sizeof(T)-1)/sizeof(T));
}

DECLARE(stedc,char*,int*,T*,T*,T*,int*,T*,int*,int*,int*,int*)

// Compute all eigenvalues and eigenvectors of a symmetric tridiagonal matrix.  work is automatically resized.
WRAP(void stedc(RawArray<T> d, RawArray<T> e, Array<T,2>& z, Array<char>& work)) {
  int n=d.size();
  GEODE_ASSERT(n-1<=e.size() && e.size()<=n);
  z.resize(n,n,uninit);
  if(!n) return;
  char *compz=const_cast<char*>("I");
  T lwork_T;int liwork,query=-1,ldz=z.n,info;
  BC(stedc)(compz,&n,d.data(),e.data(),z.data(),&ldz,&lwork_T,&query,&liwork,&query,&info);
  GEODE_ASSERT(!info);
  int lwork=(int)lwork_T;
  static_assert(sizeof(T)/sizeof(int)*sizeof(int)==sizeof(T),"");
  work.preallocate(lwork*sizeof(T)+liwork*sizeof(int));
  BC(stedc)(compz,&n,d.data(),e.data(),z.data(),&ldz,reinterpret_cast<T*>(work.data()),&lwork,
    reinterpret_cast<int*>(work.data()+lwork*sizeof(T)),&liwork,&info);
  GEODE_ASSERT(!info);
}

DECLARE(stegr,char*,char*,int*,T*,T*,T*,T*,int*,int*,T*,int*,T*,T*,int*,int*,T*,int*,int*,int*,int*)

// Compute selected eigenvalues and eigenvectors of a symmetric tridiagonal matrix.  WARNING: Does not work in Mkl 10.2.3.
WRAP(void stegr(RawArray<T> d,RawArray<T> e,Box<T> range,Array<T>& w,Array<T,2>& z,Array<int>& isuppz,Array<char>& work)) {
  int n=d.size();
  GEODE_ASSERT(n==e.size());
  w.resize(n,uninit);z.resize(n,n,uninit);isuppz.resize(2*n,uninit);
  if(!n) return;
  char *jobz=const_cast<char*>("V"),*ran=const_cast<char*>(range.contains(Box<T>::full_box())?"A":"V");
  T lwork_T,unused_T;int liwork,m,query=-1,unused,ldz=z.n,info;
  BC(stegr)(jobz,ran,&n,d.data(),e.data(),&range.min,&range.max,&unused,&unused,&unused_T,&m,w.data(),z.data(),&ldz,
      isuppz.data(),&lwork_T,&query,&liwork,&query,&info);
  GEODE_ASSERT(!info);
  int lwork=(int)lwork_T;
  static_assert(sizeof(T)/sizeof(int)*sizeof(int)==sizeof(T),"");
  work.preallocate(lwork*sizeof(T)+liwork*sizeof(int));
  BC(stegr)(jobz,ran,&n,d.data(),e.data(),&range.min,&range.max,&unused,&unused,&unused_T,&m,w.data(),z.data(),&ldz,
      isuppz.data(),reinterpret_cast<T*>(work.data()),&lwork,reinterpret_cast<int*>(work.data()+lwork*sizeof(T)),&liwork,&info);
  GEODE_ASSERT(!info);
  w.resize(m);z.resize(m,n);isuppz.resize(m);
}

// Matrix-matrix multiply: C = alpha*A^ta B^tb+beta*C
WRAP(void gemm(CBLAS_TRANSPOSE ta, CBLAS_TRANSPOSE tb, T alpha, Subarray<const T,2> A, Subarray<const T,2> B, T beta, Subarray<T,2> C)) {
  int k=ta==CblasTrans?A.m:A.n;
  GEODE_ASSERT(C.m==A.m+A.n-k && k==(tb==CblasTrans?B.n:B.m) && B.m+B.n-k==C.n);
  int lda=max(1,A.stride),ldb=max(1,B.stride),ldc=max(1,C.stride);
  CBC(gemm)(CblasRowMajor,ta,tb,C.m,C.n,k,alpha,A.data(),lda,B.data(),ldb,beta,C.data(),ldc);
}

// Matrix-matrix multiply: C = alpha*AB+beta*C
WRAP(void gemm(T alpha, Subarray<const T,2> A, Subarray<const T,2> B, T beta, Subarray<T,2> C)) {
  gemm(CblasNoTrans,CblasNoTrans,alpha,A,B,beta,C);
}

// Perform a symmetric rank-k update of a matrix: C = alpha*A^t A^!t + beta*C
WRAP(void syrk(CBLAS_UPLO uplo, CBLAS_TRANSPOSE t, T alpha, Subarray<const T,2> A, T beta, Subarray<T,2> C)) {
  int k=t==CblasTrans?A.m:A.n,lda=max(A.stride,1),ldc=max(C.stride,1);
  GEODE_ASSERT(C.m==C.n && C.m==A.m+A.n-k);
  CBC(syrk)(CblasRowMajor,uplo,t,C.m,k,alpha,A.data(),lda,beta,C.data(),ldc);
}

DECLARE(gels,char*,int*,int*,int*,T*,int*,T*,int*,T*,int*,int*)

// Solve a full rank least squares problem.  work is automatically resized.
WRAP(void gels(char t,Subarray<T,2> A,RawArray<T> b,Array<T>& work)) {
  GEODE_ASSERT((t=='N' || t=='T') && max(A.m,A.n)==b.size() && (t=='N'?A.m:A.n)==b.size());
  char ot=t=='N'?'T':'N';int one=1,ldb=max(1,b.size()),lwork=work.size(),info;
  if(!lwork){work.resize(1);lwork=-1;}
  BC(gels)(&ot,const_cast<int*>(&A.n),const_cast<int*>(&A.m),&one,A.data(),const_cast<int*>(&A.stride),b.data(),&ldb,work.data(),&lwork,&info);
  if(lwork<0) work.resize(max(1,(int)work[0]));
}

DECLARE(gelsy,int*,int*,int*,T*,int*,T*,int*,int*,T*,int*,T*,int*,int*)

// Compute a minimum-norm solution to the linear least squares problem A^T x = b.  work is automatically resized.
WRAP(void gelsy(Subarray<T,2> A,RawArray<T> b,Array<T>& work)) {
  GEODE_ASSERT(max(A.m,A.n)==b.size() && A.n==b.size());
  int one=1,ldb=max(1,b.size()),lwork=work.size(),info;
  if(!lwork){work.resize(1);lwork=-1;}
  Array<int> jpvt(A.m);T rcond;int rank;
  BC(gelsy)(const_cast<int*>(&A.n),const_cast<int*>(&A.m),&one,A.data(),const_cast<int*>(&A.stride),b.data(),&ldb,jpvt.data(),&rcond,&rank,work.data(),&lwork,&info);
  if(lwork<0) work.resize(max(1,(int)work[0]));
}

DECLARE(gelsd,int*,int*,int*,T*,int*,T*,int*,T*,T*,int*,T*,int*,int*,int*)

// If iwork is zero size, we will call gelsd in workspace query mode.
// This function will then resize work to be the proper size.
// Nothing else will have been done, so you have to call this function again.
// b.n must be equal to max(A.m,A.n). If A.m > A.n, only the first A.n rows
// contain the solution, the rest contain residuals.
WRAP(void gelsd(Subarray<T,2> A,RawArray<T> b,Array<T>& work,Array<int>& iwork)) { // solves A^T x = b
  int m=A.m,n=A.n;GEODE_ASSERT(max(m,n)==b.size());
  int one=1,ldb=max(1,b.size()),lwork=work.size(),info;
  if(!lwork){work.resize(1);iwork.resize(1);lwork=-1;}
  Array<T> s(max(1,min(m,n)),uninit);T rcond;int rank;
  BC(gelsd)(&n,&m,&one,A.data(),const_cast<int*>(&A.stride),b.data(),&ldb,s.data(),&rcond,&rank,work.data(),&lwork,iwork.data(),&info);
  if(lwork<0){work.resize(max(1,(int)work[0]));iwork.resize(max(1,(int)iwork[0]));}
  if (info)
    std::cout << "error in gelsd: " << info << std::endl;
}

// If iwork is zero size, we will call gelsd in workspace query mode.
// This function will then resize work to be the proper size.
// Nothing else will have been done, so you have to call this function again.
WRAP(void gelsd(Subarray<T,2> A,Array<T,2>b,Array<T>& work,Array<int>& iwork)) { // solves A^T X^T = B^T for all columns of X and B
  int m=A.m,n=A.n;
  GEODE_ASSERT(max(m,n)==b.n);
  int nrhs=b.m, ldb=b.n, lwork=work.size(), info;
  if(!lwork) {
    work.resize(1);
    iwork.resize(1);
    lwork=-1;
  }
  Array<T> s(min(m,n),uninit);
  T rcond;
  int rank;
  BC(gelsd)(&n,&m,&nrhs,A.data(),const_cast<int*>(&A.stride),b.data(),&ldb,s.data(),&rcond,&rank,work.data(),&lwork,iwork.data(),&info);
  if (lwork<0) {
    work.resize((int)work[0]);
    iwork.resize((int)iwork[0]);
  }
  if (info)
    std::cout << "error in gelsd: " << info << std::endl;
}

// y = ax + y
WRAP(void axpy(int n, T alpha, const T* x, T* y)) {
  CBC(axpy)(n,alpha,x,1,y,1);
}

// y = ax + y
WRAP(void axpy(T alpha, RawArray<const T> x, RawArray<T> y)) {
  int n=x.size();GEODE_ASSERT(n==y.size());
  CBC(axpy)(n,alpha,x.data(),1,y.data(),1);
}

// Squared norm: |x|^2 = dot(x,x)
WRAP(T nrm2(RawArray<const T> x)) {
  return CBC(nrm2)(x.size(),x.data(),1);
}

// sum_i x_i
WRAP(T asum(RawArray<const T> x)) {
  return CBC(asum)(x.size(),x.data(),1);
}

// dot(x,y)
WRAP(T dot(RawArray<const T> x, RawArray<const T> y)) {
  int n=x.size();GEODE_ASSERT(n==y.size());
  return CBC(dot)(n,x.data(),1,y.data(),1);
}

// Swap the contents of two subarrays
WRAP(void blas_swap(Subarray<T> x, Subarray<T> y)) {
  int n=x.size();GEODE_ASSERT(n==y.size());CBC(swap)(n,x.data(),x.stride,y.data(),y.stride);
}

// Rank one update: A = A + alpha*x y^T
WRAP(void ger(T alpha, Subarray<const T> x, Subarray<const T> y, Subarray<T,2> A)) {
  GEODE_ASSERT(x.size()==A.m && A.n==y.size());
  int lda=max(1,A.stride),xinc=max(1,x.stride),yinc=max(1,y.stride);
  CBC(ger)(CblasRowMajor,A.m,A.n,alpha,x.data(),xinc,y.data(),yinc,A.data(),lda);
}

DECLARE(laset,char*,int*,int*,T*,T*,T*,int*)

// Initialize the diagonal and offdiagonal of a matrix to the given values
WRAP(void laset(char uplo, T offdiagonal, T diagonal, Subarray<T,2> A)) {
  char uplo_s[2]={uplo,0};int lda=max(1,A.stride);
  BC(laset)(uplo_s,const_cast<int*>(&A.n),const_cast<int*>(&A.m),&offdiagonal,&diagonal,A.data(),&lda);
}

// Compute a scalar matrix-matrix product with one matrix triangular.  TODO: Give details.
WRAP(void trmm(CBLAS_SIDE side, CBLAS_UPLO uplo, CBLAS_TRANSPOSE transA, CBLAS_DIAG diag, T alpha, Subarray<const T,2> A, Subarray<T,2> B)) {
  int k=side==CblasLeft?B.m:B.n;
  GEODE_ASSERT(A.m>=k && A.n>=k && (uplo==CblasLower?A.m:A.n)==k);
  CBC(trmm)(CblasRowMajor,side,uplo,transA,diag,B.m,B.n,alpha,A.data(),max(1,A.stride),B.data(),max(1,B.stride));
}

// Solve a triangular matrix equation.  TODO: Give details.
WRAP(void trsm(CBLAS_SIDE side, CBLAS_UPLO uplo, CBLAS_TRANSPOSE transA, CBLAS_DIAG diag, T alpha, Subarray<const T,2> A, Subarray<T,2> B)) {
  int k=side==CblasLeft?B.m:B.n;
  GEODE_ASSERT(A.m>=k && A.n>=k && (uplo==CblasLower?A.m:A.n)==k);
  CBC(trsm)(CblasRowMajor,side,uplo,transA,diag,B.m,B.n,alpha,A.data(),max(1,A.stride),B.data(),max(1,B.stride));
}

// Solve a triangular matrix equation.  TODO: Give details.
WRAP(void trsm(CBLAS_SIDE side, CBLAS_UPLO uplo, CBLAS_TRANSPOSE transA, CBLAS_DIAG diag, T alpha, Subarray<const T,2> A, RawArray<T> B))
{
  int r=B.size(),c=1;if(side==CblasRight) swap(r,c);
  trsm(side,uplo,transA,diag,alpha,A,B.reshape(r,c));
}

DECLARE(gesv,int*,int*,T*,int*,int*,T*,int*,int*)

// Solve a linear system: b = A^-T b.  WARNING: Note that the matrix is transposed.
WRAP(void gesv(RawArray<T,2> A,RawArray<T> b)) {
  GEODE_ASSERT(A.m==A.n && A.m==b.size());
  int one=1,lda=max(1,A.n),info;
  Array<int> ipiv(A.m,uninit);
  BC(gesv)(const_cast<int*>(&A.m),&one,A.data(),&lda,ipiv.data(),b.data(),const_cast<int*>(&A.n),&info);
}

DECLARE(getrf,int*,int*,T*,int*,int*,int*)

// Compute the pivoted LU factorization of a square matrix.
WRAP(void getrf(RawArray<T,2> A, RawArray<int> ipiv)) {
  int r=min(A.m,A.n),info;GEODE_ASSERT(ipiv.size()==r);
  if(!r) return;
  BC(getrf)(&A.n,&A.m,A.data(),&A.n,ipiv.data(),&info);
}

DECLARE(gecon,char*,int*,T*,int*,T*,T*,T*,int*,int*)

// Estimate the reciprocal of the condition number of a general matrix in the 1-norm or the infinity-norm.
WRAP(T gecon(char norm, RawArray<T,2> A, T anorm)) {
  GEODE_ASSERT(A.m==A.n && (norm=='1' || norm=='0' || norm=='I'));
  T rcond;int info;
  Array<T> work(max(1,4*A.m),uninit);
  Array<int> iwork(max(1,A.m),uninit);
  BC(gecon)(&norm,&A.m,A.data(),&A.n,&anorm,&rcond,work.data(),iwork.data(),&info);
  return rcond;
}

DECLARE(sytrf,char*,int*,T*,int*,int*,T*,int*,int*)

// Compute the Bunch-Kaufman factorization of a symmetric matrix.
WRAP(void sytrf(CBLAS_UPLO uplo, Subarray<T,2> A, RawArray<int> ipiv, Array<T>& work)) {
  GEODE_ASSERT(A.m==A.n && A.m==ipiv.size());
  const char *u=uplo==CblasLower?"L":"U";
  int n=A.m,lda=max(1,A.stride),lwork=work.max_size(),info;
  BC(sytrf)(const_cast<char*>(u),&n,A.data(),&lda,ipiv.data(),work.data(),&lwork,&info);
}

// Compute work.size() required by sytrf
WRAP(int sytrf_work(CBLAS_UPLO uplo,Subarray<T,2> A)) {
  // Mkl appears to have a bug in the sytrf work query, so we do it ourselves
  static const int nb=max(ilaenv<T>(1,SA(sytrf),"L",1024,-1),ilaenv<T>(1,SA(sytrf),"U",1024,-1));
  return max(1,nb*A.m);
}

DECLARE(sytrs,char*,int*,int*,T*,int*,int*,T*,int*,int*)

// Solve a linear system given the Bunch-Kaufman factorization computed by sytrf.  WARNING: Computes B = B A^{-1} since Lapack is column-major.
WRAP(void sytrs(CBLAS_UPLO uplo,Subarray<const T,2> A,RawArray<const int> ipiv,Subarray<T,2> B)) {
  GEODE_ASSERT(A.m==A.n && A.m==ipiv.size() && B.n==A.m);
  const char *u=uplo==CblasLower?"L":"U";
  int n=A.n,nrhs=B.m,lda=max(1,A.stride),ldb=max(1,B.stride),info;
  BC(sytrs)(const_cast<char*>(u),&n,&nrhs,const_cast<T*>(A.data()),&lda,const_cast<int*>(ipiv.data()),B.data(),&ldb,&info);
}

// Solve a linear system given the Bunch-Kaufman factorization computed by sytrf.
WRAP(void sytrs(CBLAS_UPLO uplo,Subarray<const T,2> A,RawArray<const int> ipiv,RawArray<T> B)) {
  sytrs(uplo,A,ipiv,B.reshape(1,B.size()));
}

#ifdef GEODE_MKL

// Perform scaling and in-place transposition/copying of matrices.
WRAP(void imatcopy(T alpha,Subarray<T,2> A)) {
  MKL_BC(imatcopy)('r','t',A.m,A.n,alpha,A.data(),A.n,A.m);
}

// Perform scaling and out-place transposition/copying of matrices.
WRAP(void omatcopy(CBLAS_TRANSPOSE trans,T alpha,Subarray<const T,2> A,Subarray<T,2> B)) {
  int k=trans==CblasTrans?A.n:A.m,lda=max(1,A.stride),ldb=max(1,B.stride);
  GEODE_ASSERT(k==B.m && A.m+A.n-k==B.n);
  MKL_BC(omatcopy)('r',trans==CblasTrans?'t':'n',A.m,A.n,alpha,A.data(),lda,B.data(),ldb);
}

#endif

#endif
#endif
#endif


#include <math.h>
#include <stdlib.h>
#if !defined(__APPLE__)
#include <malloc.h>
#endif
#include <stdio.h>
#include <assert.h>
#include <string.h>

#include <gsl/gsl_errno.h>
#include <gsl/gsl_integration.h>
#include <gsl/gsl_spline.h>
#include <gsl/gsl_sf_gamma.h>
#include <gsl/gsl_sf_legendre.h>
#include <gsl/gsl_sf_bessel.h>
#include <gsl/gsl_deriv.h>
#include <gsl/gsl_linalg.h>
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_eigen.h>
#include <gsl/gsl_sf_expint.h>

#include "../cosmolike_light/theory/baryons.h"
#include "../cosmolike_light/theory/basics.c"
#include "../cosmolike_light/theory/structs.c"
#include "../cosmolike_light/theory/parameters.c"
#include "../cosmolike_light/emu17/P_cb/emu.c"
#include "../cosmolike_light/theory/recompute.c"
#include "../cosmolike_light/theory/cosmo3D.c"
#include "../cosmolike_light/theory/redshift_spline.c"
#include "../cosmolike_light/theory/halo.c"
#include "../cosmolike_light/theory/HOD.c"
#include "../cosmolike_light/theory/cosmo2D_fourier.c"
#include "../cosmolike_light/theory/IA.c"
#include "../cosmolike_light/theory/BAO.c"
#include "../cosmolike_light/theory/external_prior.c"
#include "../cosmolike_light/theory/covariances_3D.c"
#include "../cosmolike_light/theory/covariances_fourier.c"
#include "../cosmolike_light/theory/covariances_real.c"
#include "../cosmolike_light/theory/run_covariances_real.c"
#include "../cosmolike_light/theory/init.c"

int main(int argc, char** argv)
{
  int hit=atoi(argv[1]);
  FILE *F1,*F2;
  int i,l,m,n,o,s,p,output;
  double ktmp;
  char OUTFILE[400],filename[400];

  printf("-----------------\n");
  printf("This is not production mode covariance code\n");
  printf("Please only use with care and at your own risk\n");
  printf("-----------------\n");

  Ntable.N_a=20;
  set_cov_parameters_to_("cov_Y1/cov_y1_mcal_revision.ini",1);
  //here: setting values internally

  // set this to zero to quickly run Gaussian-only covariances for testing
  if (covparams.ng==1){
    NG = 1;
  }
  else {
    NG = 0;
  }

  // set this to one to output details about inputs for diagnostics
  output = 0;
  FILE *F;
  printf("running multi_covariance_real with NG = %d\n",NG);

  set_cosmological_parameters_to_("cov_Y1/cov_y1_mcal_revision.ini",1);
  //here: setting values internally
  // cosmology.Omega_m   = 0.286;
  // cosmology.Omega_v   = 1.0-cosmology.Omega_m;
  // cosmology.sigma_8   = 0.82;
  // cosmology.n_spec    = 0.96;

  // cosmology.w0=-1.;
  // cosmology.wa=0.;
  // cosmology.omb=0.04868;
  // cosmology.h0=0.673;
  // cosmology.coverH0= 2997.92458;

  // cosmology.rho_crit = 7.4775e+21;
  // cosmology.f_NL = 0.0;
  // pdeltaparams.runmode="Halofit"

  set_survey_parameters_to_("cov_Y1/cov_y1_mcal_revision.ini",1);
  //here: setting values internally
  //survey.area=1000.0;
  //survey.m_lim=
  //survey.name=
  //survey.Kcorrect_File=
  // redshift.shear_REDSHIFT_FILE=source.nz
  // redshift.clustering_REDSHIFT_FILE=lens.nz
  // survey.sourcephotoz="multihisto";
  // survey.lensphotoz="multihisto";
  // survey.galsample=
  // tomo.shear_Nbin=5;
  // redshift.clustering_histogram_zbins =
  // tomo.clustering_Nbin=5;
  // tomo.clustering_Npowerspectra=tomo.clustering_Nbin;
  // survey.sigma_e=0.24;
  // survey.ggl_overlap_cut=
  // tomo.n_source[0]=1.07535691109;
  // tomo.n_source[1]=1.1606931903;
  // tomo.n_source[2]=1.2275933389;
  // tomo.n_source[3]=1.23453951309;
  // tomo.n_source[4]=1.3387876584;

  // tomo.n_lens[0]=0.02143277;
  // tomo.n_lens[1]=0.05426833;
  // tomo.n_lens[2]=0.08070083;
  // tomo.n_lens[3]=0.05130111;
  // tomo.n_lens[4]=0.01515694;
  // for (i=0;i<tomo.clustering_Nbin:i++) survey.n_lens+=tomo.n_lens[i];
  // for (i=0;i<tomo.shear_Nbin:i++) survey.n_gal+=tomo.n_source[i];

  init_source_sample_();
  init_lens_sample_();

  //init_clusters();
  //init_IA("none", "GAMA");
  //printf("test values: %d, %d, %s",redshift.clustering_photoz,tomo.clustering_Nbin,redshift.clustering_REDSHIFT_FILE);
  // printf("end of setup in main\n");

  double theta_min= covparams.tmin;
  double theta_max= covparams.tmax;
  int Ntheta=covparams.ntheta;

  double logdt=(log(theta_max)-log(theta_min))/Ntheta;
  double *theta,*thetamin,*thetamax, *dtheta;
  theta=create_double_vector(0,Ntheta-1);
  thetamin=create_double_vector(0,Ntheta);
  thetamax=create_double_vector(0,Ntheta-1);
  dtheta=create_double_vector(0,Ntheta-1);
  for(i=0; i<Ntheta ; i++){
    thetamin[i]=exp(log(theta_min)+(i+0.0)*logdt);
    thetamax[i]=exp(log(theta_min)+(i+1.0)*logdt);
    theta[i] = 2./3.*(pow(thetamax[i],3.)-pow(thetamin[i],3.))/(pow(thetamax[i],2.)-pow(thetamin[i],2.));
    dtheta[i]=thetamax[i]-thetamin[i];
  }
  thetamin[Ntheta] = thetamax[Ntheta-1];

  int k=1;
  if (strcmp(covparams.ss,"true")==0)
  {
    sprintf(OUTFILE,"%s_ssss_++_cov_Ntheta%d_Ntomo%d",covparams.filename,Ntheta,tomo.shear_Nbin);

    for (l=0;l<tomo.shear_Npowerspectra; l++){
      for (m=l;m<tomo.shear_Npowerspectra; m++){
        if(k==hit){
          sprintf(filename,"%s%s_%d",covparams.outdir,OUTFILE,k);
          if (fopen(filename, "r") != NULL){exit(1);}
          else {run_cov_shear_shear_real_bin(OUTFILE,covparams.outdir,thetamin,Ntheta,l,m,1,1,k);}
        }
        k=k+1;
      }
    }
    sprintf(OUTFILE,"%s_ssss_--_cov_Ntheta%d_Ntomo%d",covparams.filename,Ntheta,tomo.shear_Nbin);
    for (l=0;l<tomo.shear_Npowerspectra; l++){
      for (m=l;m<tomo.shear_Npowerspectra; m++){
        if(k==hit){
          sprintf(filename,"%s%s_%d",covparams.outdir,OUTFILE,k);
          if (fopen(filename, "r") != NULL){exit(1);}
          else {run_cov_shear_shear_real_bin(OUTFILE,covparams.outdir,thetamin,Ntheta,l,m,0,0,k);}
        }
        k=k+1;
      }
    }
    sprintf(OUTFILE,"%s_ssss_+-_cov_Ntheta%d_Ntomo%d",covparams.filename,Ntheta,tomo.shear_Nbin);
    for (l=0;l<tomo.shear_Npowerspectra; l++){
      for (m=0;m<tomo.shear_Npowerspectra; m++){
        if(k==hit){
          sprintf(filename,"%s%s_%d",covparams.outdir,OUTFILE,k);
          if (fopen(filename, "r") != NULL){exit(1);}
          else {run_cov_shear_shear_real_bin(OUTFILE,covparams.outdir,thetamin,Ntheta,l,m,1,0,k);}
        }
        k=k+1;
      }
    }
  }
  if (strcmp(covparams.ll,"true")==0)
  {
    sprintf(OUTFILE,"%s_llll_cov_Ntheta%d_Ntomo%d",covparams.filename,Ntheta,tomo.shear_Nbin);
    for (l=0;l<tomo.clustering_Npowerspectra; l++){
      for (m=l;m<tomo.clustering_Npowerspectra; m++){
        if(k==hit){
          sprintf(filename,"%s%s_%d",covparams.outdir,OUTFILE,k);
          if (fopen(filename, "r") != NULL){exit(1);}
          else {run_cov_clustering_real_bin(OUTFILE,covparams.outdir,thetamin,Ntheta,l,m,k);}
        }
        k=k+1;
      }
    }
  }
  if (strcmp(covparams.ls,"true")==0)
  {
    sprintf(OUTFILE,"%s_lsls_cov_Ntheta%d_Ntomo%d",covparams.filename,Ntheta,tomo.shear_Nbin);
    for (l=0;l<tomo.ggl_Npowerspectra; l++){
      for (m=l;m<tomo.ggl_Npowerspectra; m++){
        if(k==hit) {
          sprintf(filename,"%s%s_%d",covparams.outdir,OUTFILE,k);
          if (fopen(filename, "r") != NULL){exit(1);}
          else {run_cov_ggl_real_bin(OUTFILE,covparams.outdir,thetamin,Ntheta,l,m,k);}
        }
        k=k+1;
      }
    }
  }
  if (strcmp(covparams.ls,"true")==0 && strcmp(covparams.ss,"true")==0)
  {
    sprintf(OUTFILE,"%s_lsss_+_cov_Ntheta%d_Ntomo%d",covparams.filename,Ntheta,tomo.shear_Nbin);
    for (l=0;l<tomo.ggl_Npowerspectra; l++){
      for (m=0;m<tomo.shear_Npowerspectra; m++){
        if(k==hit) {
          sprintf(filename,"%s%s_%d",covparams.outdir,OUTFILE,k);
          if (fopen(filename, "r") != NULL){exit(1);}
          else {run_cov_ggl_shear_real_bin(OUTFILE,covparams.outdir,thetamin,Ntheta,l,m,1,k);}
        }
        k=k+1;
      }
    }
    sprintf(OUTFILE,"%s_lsss_-_cov_Ntheta%d_Ntomo%d",covparams.filename,Ntheta,tomo.shear_Nbin);
    for (l=0;l<tomo.ggl_Npowerspectra; l++){
      for (m=0;m<tomo.shear_Npowerspectra; m++){
        if(k==hit) {
          sprintf(filename,"%s%s_%d",covparams.outdir,OUTFILE,k);
          if (fopen(filename, "r") != NULL){exit(1);}
          else {run_cov_ggl_shear_real_bin(OUTFILE,covparams.outdir,thetamin,Ntheta,l,m,0,k);}
        }
        k=k+1;
      }
    }
  }
  if (strcmp(covparams.ll,"true")==0 && strcmp(covparams.ss,"true")==0)
  {
    sprintf(OUTFILE,"%s_llss_+_cov_Ntheta%d_Ntomo%d",covparams.filename,Ntheta,tomo.shear_Nbin);
    for (l=0;l<tomo.clustering_Npowerspectra; l++){
      for (m=0;m<tomo.shear_Npowerspectra; m++){
        if(k==hit) {
          sprintf(filename,"%s%s_%d",covparams.outdir,OUTFILE,k);
          if (fopen(filename, "r") != NULL){exit(1);}
          else {run_cov_clustering_shear_real_bin(OUTFILE,covparams.outdir,thetamin,Ntheta,l,m,1,k);}
        }
        k=k+1;
      }
    }
    sprintf(OUTFILE,"%s_llss_-_cov_Ntheta%d_Ntomo%d",covparams.filename,Ntheta,tomo.shear_Nbin);
    for (l=0;l<tomo.clustering_Npowerspectra; l++){
      for (m=0;m<tomo.shear_Npowerspectra; m++){
        if(k==hit) {
          sprintf(filename,"%s%s_%d",covparams.outdir,OUTFILE,k);
          if (fopen(filename, "r") != NULL){exit(1);}
          else {run_cov_clustering_shear_real_bin(OUTFILE,covparams.outdir,thetamin,Ntheta,l,m,0,k);}
        }
        k=k+1;
      }
    }
  }
  if (strcmp(covparams.ll,"true")==0 && strcmp(covparams.ls,"true")==0)
  {
    sprintf(OUTFILE,"%s_llls_cov_Ntheta%d_Ntomo%d",covparams.filename,Ntheta,tomo.shear_Nbin);
    for (l=0;l<tomo.clustering_Npowerspectra; l++){
      for (m=0;m<tomo.ggl_Npowerspectra; m++){
        if(k==hit) {
          sprintf(filename,"%s%s_%d",covparams.outdir,OUTFILE,k);
          if (fopen(filename, "r") != NULL){exit(1);}
          else {run_cov_clustering_ggl_real_bin(OUTFILE,covparams.outdir,thetamin,Ntheta,l,m,k);}
        }
        k=k+1;
      }
    }
  }

  if (hit==0)
  {
    sprintf(OUTFILE,"%s%s",covparams.outdir,covparams.filename);
    write_gglensing_zbins(OUTFILE);

    sprintf(OUTFILE,"%s%s.blocks",covparams.outdir,covparams.filename);
    F1 = fopen(OUTFILE,"w");
    fprintf(F1,"%d\n",k-1);
    fclose(F1);
  }

  printf("number of cov blocks for parallelization: %d\n",k-1);
  printf("-----------------\n");
  printf("PROGRAM EXECUTED\n");
  printf("-----------------\n");
  return 0;
}


#include <petsc.h>

typedef struct _msc_t {
  PetscInt nmasks;
  PetscInt* masks;
  PetscInt* mask_offsets;
  PetscInt* signs;
  PetscScalar* coeffs;
} msc_t;

typedef struct _shell_context {
  PetscInt nmasks;
  PetscInt* masks;
  PetscInt* mask_offsets;
  PetscInt* signs;
  PetscReal* real_coeffs;     // we store only the real or complex part -- whichever is nonzero
  void *left_subspace_data;
  void *right_subspace_data;
  PetscReal nrm;
} shell_context;


/*
 * Copyright (c) 1997-1999 Massachusetts Institute of Technology
 *
 * 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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *
 */

/* This file was automatically generated --- DO NOT EDIT */
/* Generated on Sun Nov  7 20:43:58 EST 1999 */

#include <fftw-int.h>
#include <fftw.h>

/* Generated by: ./genfft -magic-alignment-check -magic-twiddle-load-all -magic-variables 4 -magic-loopi -real2hc 16 */

/*
 * This function contains 58 FP additions, 12 FP multiplications,
 * (or, 54 additions, 8 multiplications, 4 fused multiply/add),
 * 30 stack variables, and 32 memory accesses
 */
static const fftw_real K707106781 = FFTW_KONST(+0.707106781186547524400844362104849039284835938);
static const fftw_real K923879532 = FFTW_KONST(+0.923879532511286756128183189396788286822416626);
static const fftw_real K382683432 = FFTW_KONST(+0.382683432365089771728459984030398866761344562);

/*
 * Generator Id's :
 * $Id: exprdag.ml,v 1.41 1999/05/26 15:44:14 fftw Exp $
 * $Id: fft.ml,v 1.43 1999/05/17 19:44:18 fftw Exp $
 * $Id: to_c.ml,v 1.25 1999/10/26 21:41:32 stevenj Exp $
 */

void fftw_real2hc_16(const fftw_real *input, fftw_real *real_output, fftw_real *imag_output, int istride, int real_ostride, int imag_ostride)
{
     fftw_real tmp3;
     fftw_real tmp6;
     fftw_real tmp7;
     fftw_real tmp35;
     fftw_real tmp18;
     fftw_real tmp33;
     fftw_real tmp40;
     fftw_real tmp48;
     fftw_real tmp56;
     fftw_real tmp10;
     fftw_real tmp13;
     fftw_real tmp14;
     fftw_real tmp36;
     fftw_real tmp17;
     fftw_real tmp26;
     fftw_real tmp41;
     fftw_real tmp51;
     fftw_real tmp57;
     fftw_real tmp16;
     fftw_real tmp15;
     fftw_real tmp43;
     fftw_real tmp44;
     ASSERT_ALIGNED_DOUBLE;
     {
	  fftw_real tmp1;
	  fftw_real tmp2;
	  fftw_real tmp4;
	  fftw_real tmp5;
	  ASSERT_ALIGNED_DOUBLE;
	  tmp1 = input[0];
	  tmp2 = input[8 * istride];
	  tmp3 = tmp1 + tmp2;
	  tmp4 = input[4 * istride];
	  tmp5 = input[12 * istride];
	  tmp6 = tmp4 + tmp5;
	  tmp7 = tmp3 + tmp6;
	  tmp35 = tmp1 - tmp2;
	  tmp18 = tmp4 - tmp5;
     }
     {
	  fftw_real tmp29;
	  fftw_real tmp46;
	  fftw_real tmp32;
	  fftw_real tmp47;
	  ASSERT_ALIGNED_DOUBLE;
	  {
	       fftw_real tmp27;
	       fftw_real tmp28;
	       fftw_real tmp30;
	       fftw_real tmp31;
	       ASSERT_ALIGNED_DOUBLE;
	       tmp27 = input[istride];
	       tmp28 = input[9 * istride];
	       tmp29 = tmp27 - tmp28;
	       tmp46 = tmp27 + tmp28;
	       tmp30 = input[5 * istride];
	       tmp31 = input[13 * istride];
	       tmp32 = tmp30 - tmp31;
	       tmp47 = tmp30 + tmp31;
	  }
	  tmp33 = (K382683432 * tmp29) + (K923879532 * tmp32);
	  tmp40 = (K923879532 * tmp29) - (K382683432 * tmp32);
	  tmp48 = tmp46 - tmp47;
	  tmp56 = tmp46 + tmp47;
     }
     {
	  fftw_real tmp8;
	  fftw_real tmp9;
	  fftw_real tmp11;
	  fftw_real tmp12;
	  ASSERT_ALIGNED_DOUBLE;
	  tmp8 = input[2 * istride];
	  tmp9 = input[10 * istride];
	  tmp10 = tmp8 + tmp9;
	  tmp16 = tmp8 - tmp9;
	  tmp11 = input[14 * istride];
	  tmp12 = input[6 * istride];
	  tmp13 = tmp11 + tmp12;
	  tmp15 = tmp11 - tmp12;
     }
     tmp14 = tmp10 + tmp13;
     tmp36 = K707106781 * (tmp16 + tmp15);
     tmp17 = K707106781 * (tmp15 - tmp16);
     {
	  fftw_real tmp22;
	  fftw_real tmp49;
	  fftw_real tmp25;
	  fftw_real tmp50;
	  ASSERT_ALIGNED_DOUBLE;
	  {
	       fftw_real tmp20;
	       fftw_real tmp21;
	       fftw_real tmp23;
	       fftw_real tmp24;
	       ASSERT_ALIGNED_DOUBLE;
	       tmp20 = input[15 * istride];
	       tmp21 = input[7 * istride];
	       tmp22 = tmp20 - tmp21;
	       tmp49 = tmp20 + tmp21;
	       tmp23 = input[3 * istride];
	       tmp24 = input[11 * istride];
	       tmp25 = tmp23 - tmp24;
	       tmp50 = tmp23 + tmp24;
	  }
	  tmp26 = (K382683432 * tmp22) - (K923879532 * tmp25);
	  tmp41 = (K923879532 * tmp22) + (K382683432 * tmp25);
	  tmp51 = tmp49 - tmp50;
	  tmp57 = tmp49 + tmp50;
     }
     {
	  fftw_real tmp55;
	  fftw_real tmp58;
	  fftw_real tmp53;
	  fftw_real tmp54;
	  ASSERT_ALIGNED_DOUBLE;
	  real_output[4 * real_ostride] = tmp7 - tmp14;
	  tmp55 = tmp7 + tmp14;
	  tmp58 = tmp56 + tmp57;
	  real_output[8 * real_ostride] = tmp55 - tmp58;
	  real_output[0] = tmp55 + tmp58;
	  imag_output[4 * imag_ostride] = tmp57 - tmp56;
	  tmp53 = tmp13 - tmp10;
	  tmp54 = K707106781 * (tmp51 - tmp48);
	  imag_output[2 * imag_ostride] = tmp53 + tmp54;
	  imag_output[6 * imag_ostride] = tmp54 - tmp53;
     }
     {
	  fftw_real tmp45;
	  fftw_real tmp52;
	  fftw_real tmp39;
	  fftw_real tmp42;
	  ASSERT_ALIGNED_DOUBLE;
	  tmp45 = tmp3 - tmp6;
	  tmp52 = K707106781 * (tmp48 + tmp51);
	  real_output[6 * real_ostride] = tmp45 - tmp52;
	  real_output[2 * real_ostride] = tmp45 + tmp52;
	  tmp39 = tmp35 + tmp36;
	  tmp42 = tmp40 + tmp41;
	  real_output[7 * real_ostride] = tmp39 - tmp42;
	  real_output[real_ostride] = tmp39 + tmp42;
     }
     tmp43 = tmp18 + tmp17;
     tmp44 = tmp41 - tmp40;
     imag_output[3 * imag_ostride] = tmp43 + tmp44;
     imag_output[5 * imag_ostride] = tmp44 - tmp43;
     {
	  fftw_real tmp19;
	  fftw_real tmp34;
	  fftw_real tmp37;
	  fftw_real tmp38;
	  ASSERT_ALIGNED_DOUBLE;
	  tmp19 = tmp17 - tmp18;
	  tmp34 = tmp26 - tmp33;
	  imag_output[imag_ostride] = tmp19 + tmp34;
	  imag_output[7 * imag_ostride] = tmp34 - tmp19;
	  tmp37 = tmp35 - tmp36;
	  tmp38 = tmp33 + tmp26;
	  real_output[5 * real_ostride] = tmp37 - tmp38;
	  real_output[3 * real_ostride] = tmp37 + tmp38;
     }
}

fftw_codelet_desc fftw_real2hc_16_desc =
{
     "fftw_real2hc_16",
     (void (*)()) fftw_real2hc_16,
     16,
     FFTW_FORWARD,
     FFTW_REAL2HC,
     354,
     0,
     (const int *) 0,
};


#ifndef gsl_h__
#define gsl_h__

#include <gsl/gsl_linalg.h>

namespace gsl {
    // FIXME clean this up with C++0x rvalues
    struct vector {
        gsl_vector *p;
        gsl_vector_view view;
        vector(int n=1) {
            p = gsl_vector_alloc(n);
            view = gsl_vector_subvector_with_stride(p,0,p->stride,p->size);
        }
        ~vector() {
            gsl_vector_free(p);
            p = 0;
        }
        int length() {
            return p->size;
        }
        int dim(int i) {
            if(i==0) return p->size;
            throw "oops";
        }
        void resize(int n) {
            gsl_vector_free(p);
            p = gsl_vector_alloc(n);
        }
        void operator=(double value) {
            gsl_vector_set_all(p,value);
        }
        double &operator()(int i) {
            CHECK(unsigned(i)<=unsigned(p->size));
            return p->data[i*p->stride];
        }
        operator gsl_vector_view *() {
            return &view;
        }
        operator gsl_vector *() {
            return p;
        }
        template <class T>
        void get(T &other) {
            resize(other.dim(0));
            for(int i=0;i<other.dim(0);i++)
                operator()(i) = other(i);
        }
        template <class T>
        void put(T &other) {
            other.resize(dim(0));
            for(int i=0;i<dim(0);i++)
                other(i) = operator()(i);
        }
    };

    struct matrix {
        gsl_matrix *p;
        gsl_matrix_view view;
        matrix(int n=1,int m=1) {
            p = gsl_matrix_alloc(n,m);
            view = gsl_matrix_view_array_with_tda(p->data,p->size1,p->size2,p->tda);
        }
        ~matrix() {
            gsl_matrix_free(p);
            p = 0;
        }
        int dim(int i) {
            if(i==0) return p->size1;
            if(i==1) return p->size2;
            throw "oops";
        }
        void resize(int n,int m) {
            gsl_matrix_free(p);
            p = gsl_matrix_alloc(n,m);
            view = gsl_matrix_view_array_with_tda(p->data,p->size1,p->size2,p->tda);
        }
        void operator=(double value) {
            gsl_matrix_set_all(p,value);
        }
        double &operator()(int i,int j) {
            CHECK(unsigned(i)<=unsigned(p->size1));
            CHECK(unsigned(j)<=unsigned(p->size2));
            return p->data[i*p->tda+j];
        }
        operator gsl_matrix_view *() {
            return &view;
        }
        operator gsl_matrix *() {
            return p;
        }
        template <class T>
        void get(T &other) {
            resize(other.dim(0),other.dim(1));
            for(int i=0;i<other.dim(0);i++)
                for(int j=0;j<other.dim(1);j++)
                    operator()(i,j) = other(i,j);
        }
        template <class T>
        void put(T &other) {
            other.resize(dim(0),dim(1));
            for(int i=0;i<dim(0);i++)
                for(int j=0;j<dim(1);j++)
                    other(i,j) = operator()(i,j);
        }
    };
};

#endif