// --------------------------------------------------------
// Dragon
// Copyright(c) 2017 SeetaTech
// Written by Ting Pan
// --------------------------------------------------------

#ifndef DRAGON_UTILS_MATH_FUNCTIONS_H_
#define DRAGON_UTILS_MATH_FUNCTIONS_H_

#include <float.h>
#include <cstdint>
#include <climits>

#ifdef WITH_BLAS
extern "C" {
#include <cblas.h>
}
#else    // WITH_BLAS
typedef enum CBLAS_TRANSPOSE {CblasNoTrans=111, CblasTrans=112} CBLAS_TRANSPOSE;
#endif

#include "protos/dragon.pb.h"

namespace dragon {

namespace math {

/******************** Level-0 ********************/

template <typename T, class Context>
void Set(const int n, const T alpha, T* x);

template <typename T, class Context>
void RandomUniform(const int n, const float low, const float high, T *x);

template <typename T, class Context>
void RandomNormal(const int n, const float mu, const float sigma, T* x);

template <typename T, class Context>
void RandomTruncatedNormal(const int n,
                           const float mu,
                           const float sigma,
                           const float low,
                           const float high,
                           T* x);

template <typename T, class Context>
void RandomBernoulli(const int n, const float p, uint32_t* x);

/******************** Level-1 ********************/

template <typename T, class Context>
void Add(const int n, const T* a, const T* b, T* y);

template <typename T, class Context>
void Sub(const int n, const T* a, const T* b, T* y);

template <typename T, class Context>
void Mul(const int n, const T* a, const T* b, T* y);

template <typename T, class Context>
void Div(const int n, const T* a, const T* b, T* y);

template <typename T, class Context>
void Clip(const int n, const float low, const float high, T* x);

template <typename T, class Context>
void Exp(const int n, const T* x, T* y);

template <typename T, class Context>
void Log(const int n, const T* x, T* y);

template <typename T, class Context>
void Square(const int n, const T* x, T* y);

template <typename T, class Context>
void Sqrt(const int n, const T* x, T* y);

template <typename T, class Context>
void Pow(const int n, const float alpha, const T* x, T* y);

template <typename T, class Context>
void Inv(const int n, const float numerator, const T* x, T* y);

/******************** Level-2 ********************/

template <typename T, class Context>
void Scal(const int n, const float alpha, T* y);

template <typename T, class Context>
void Scale(const int n, const float alpha, const T* x, T* y);

template <typename T, class Context>
T StridedDot(const int n,
             const T* a,
             const int incx,
             const T* b,
             const int incy);

template <typename T, class Context>
float Dot(const int n, const T* a, const T* b);

template<typename T, class Context>
float ASum(const int n, const T *x);

template<typename T, class Context>
void AddScalar(const int n, const float alpha, T* y);

template<typename T, class Context>
void MulScalar(const int n, const float alpha, T* y);

template<typename T, class Context>
void Axpy(const int n, float alpha, const T* x, T *y);

template<typename T, class Context>
void Axpby(const int n, float alpha, const T* x, float beta, T *y);

/******************** Level-3 ********************/

template <typename T, class Context>
void Gemm(const CBLAS_TRANSPOSE transA,
          const CBLAS_TRANSPOSE transB,
          const int M,
          const int N,
          const int K,
          const float alpha,
          const T* A,
          const T* B,
          const float beta,
          T* C,
          TensorProto_DataType math_type = TensorProto_DataType_FLOAT);

template<typename T, class Context>
void Gemv(const CBLAS_TRANSPOSE transA,
          const int M,
          const int N,
          const float alpha,
          const T* A,
          const T* x,
          const float beta,
          T* y,
          TensorProto_DataType math_type = TensorProto_DataType_FLOAT);

}    // namespace math

}    // namespace dragon

#endif    // DRAGON_UTILS_MATH_FUNCTIONS_H_


/*
** overall concordance correlation coefficient (OCCC)
** Barnhart et al. (2002), Biometrics, 58, 1020-1027.
**
** G.Lohmann, July 2010
*/
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_vector.h>
#include <gsl/gsl_errno.h>

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

#define SQR(x) ((x) * (x))
#define ABS(x) ((x) > 0 ? (x) : -(x))

double Cov(double *arr1,double *arr2,int n)
{
  int i;
  double nx,sum,ave1,ave2;

  nx = (double)n;

  sum = 0;
  for (i=0; i<n; i++) sum += arr1[i];
  ave1 = sum/nx;

  sum = 0;
  for (i=0; i<n; i++) sum += arr2[i];
  ave2 = sum/nx;

  sum = 0;
  for (i=0; i<n; i++)
    sum += (arr1[i] - ave1)*(arr2[i] - ave2);

  return sum/(nx-1);
}

void AveVar(double *arr,int n,double *ave,double *var)
{
  int i;
  double u,sum1,sum2,nx,mean;

  nx = (double)n;
  sum1 = sum2 = 0;
  for (i=0; i<n; i++) {
    u = arr[i];
    sum1 += u;
    sum2 += u*u;
  }
  mean = sum1/nx;

  *ave = mean;
  *var = (sum2 - nx * mean * mean) / (nx - 1.0);
}

double VOCCC(gsl_matrix *data,int nvoxels,int verbose)
{
  int i,j,k;
  double sum1,sum2,sum3,mean,varx,u,v;
  static gsl_matrix *cov=NULL;
  static gsl_vector *ave=NULL,*var=NULL;

  int nsubjects = data->size1;

  if (ave == NULL) {
    ave = gsl_vector_calloc(nsubjects);
    var = gsl_vector_calloc(nsubjects);
    cov = gsl_matrix_calloc(nsubjects,nsubjects);
  }

  for (i=0; i<nsubjects; i++) {
    double *ptr1 = gsl_matrix_ptr(data,i,0);
    AveVar(ptr1,nvoxels,&mean,&varx);
    gsl_vector_set(ave,i,mean);
    gsl_vector_set(var,i,varx);

    for (j=0; j<nsubjects; j++) {
      double *ptr1 = gsl_matrix_ptr(data,i,0);
      double *ptr2 = gsl_matrix_ptr(data,j,0);
      u = Cov(ptr1,ptr2,nvoxels);
      gsl_matrix_set(cov,i,j,u);
    }
  }
  if (verbose > 0) {
    for (i=0; i<nsubjects; i++) {
      for (j=0; j<nsubjects; j++) {
	fprintf(stderr," %8.5f",gsl_matrix_get(cov,i,j));
      }
      fprintf(stderr,"\n");
    }
    fprintf(stderr,"\n");
    exit(0);
  }

  sum1 = 0;
  for (j=1; j<=nsubjects-1; j++) {
    for (k=j+1; k<=nsubjects; k++) {
      u = gsl_matrix_get(cov,j-1,k-1);
      sum1 += u;
    }
  }
  sum1 *= 2.0;

  sum2 = 0;
  for (j=0; j<nsubjects; j++) {
    sum2 += gsl_vector_get(var,j);
  }
  sum2 *= (double)(nsubjects-1);

  sum3 = 0;
  for (j=1; j<=nsubjects-1; j++) {
    for (k=j+1; k<=nsubjects; k++) {
      u = gsl_vector_get(ave,j-1);
      v = gsl_vector_get(ave,k-1);
      sum3 += (u-v)*(u-v);
    }
  }

  if (sum2 + sum3 < 1.0e-6) return 0;
  return sum1 / (sum2 + sum3);
}


#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include <gsl/gsl_sf_legendre.h>
#include "sphere.h"
#include "sphSolv.h"
#include <petsc.h>

#undef __FUNCT__
#define __FUNCT__ "CalcEnm"
PetscErrorCode CalcEnm(Vec chargeSph, Vec chargeMag, PetscInt n, PetscInt m, PetscReal *rval, PetscReal *ival)
{
  PetscErrorCode ierr;
  PetscInt numCharges;
  PetscScalar *chargeMagPtr, *chargeSphPtr;
  PetscFunctionBegin;

  ierr = VecGetSize(chargeMag, &numCharges);CHKERRQ(ierr);

  PetscInt absm = abs(m);
  PetscReal coef = 1;
  for(PetscInt i=n-absm+1; i <= n + absm; ++i)
    coef *= i;
  coef = 1./coef;

  *rval = 0;
  *ival = 0;

  PetscReal qk, rk, rkton, thetak, phik, lterm, rterm, iterm;

  ierr = VecGetArrayRead(chargeMag, &chargeMagPtr);CHKERRQ(ierr);
  ierr = VecGetArrayRead(chargeSph, &chargeSphPtr);CHKERRQ(ierr);
  for(PetscInt k=0; k<numCharges; ++k) {
    qk = chargeMagPtr[k];
    rk = chargeSphPtr[3*k+0];
    thetak = chargeSphPtr[3*k+1];
    phik = chargeSphPtr[3*k+2];

    rkton = 1;
    for(PetscInt i=0; i<n; ++i)
      rkton = rkton*rk;

    //seems like we don't have to worry about (-1)^m? if(m%2 ==1) lterm*=-1; not necessary
    lterm = gsl_sf_legendre_Plm(n, absm, cos(thetak));
    rterm = PetscCosReal(m*phik);
    iterm = -PetscSinReal(m*phik);

    //update val
    *rval += qk*coef*rkton*lterm*rterm;
    *ival += qk*coef*rkton*lterm*iterm;
  }
  ierr = VecRestoreArrayRead(chargeMag, &chargeMagPtr);CHKERRQ(ierr);
  ierr = VecRestoreArrayRead(chargeSph, &chargeSphPtr);CHKERRQ(ierr);
  PetscFunctionReturn(0);
}

void calcEnm(SPoint *positions, double *charges, int nCharges, int n, int m, double *rval, double *ival)
{
  int print = 0;
  if(n < 2) {
    printf("\n\nn = %d\nm = %d\n", n, m);
    print = 0;
  }

  int absm = abs(m);
  double coef = 1;
  //compute factorial coefficient
  for(int i = n - absm + 1; i <= n + absm; ++i)
    coef *= i;
  coef = 1./coef;

  *rval = 0;
  *ival = 0;

  double qk, rk, rkton, thetak, phik, lterm, rterm, iterm;
  //double *legvals = (double*) malloc(sizeof(double)*(2*n+1));
  //sum over charges
  for(int k=0; k<nCharges; ++k) {

    qk = charges[k];
    rk = positions[k].x1;
    thetak = positions[k].x2;
    phik = positions[k].x3;

    rkton = 1;
    for(int i=0; i<n; ++i)
      rkton = rkton*rk;

    //seems like we don't have to worry about (-1)^m? if(m%2 ==1) lterm*=-1; not necessary
    lterm = gsl_sf_legendre_Plm(n, absm, cos(thetak));//boost::math::legendre_p(n, absm, cos(thetak));

    rterm = cos(m*phik);
    iterm = -sin(m*phik);

    if(print) {
      printf("QK: %15.15f\n", qk);
      printf("rkton: %15.15f\n", rkton);
      printf("ltern: %15.15f\n", lterm);
    }

    //update val
    *rval += qk * coef * rkton * lterm * rterm;
    *ival += qk * coef * rkton * lterm * iterm;
  }

}

void calcBnmFromEnm(int n, int m, double Enmrval, double Enmival, SProblem *problem, double *Bnmrval, double *Bnmival) {
  double e1 = problem->e1;
  double e2 = problem->e2;
  double b  = problem->b;

  double val = 1.0;
  for(int i=0; i<2*n+1; ++i) {
    val /= b;
  }

  val /= e1;

  val *= (e1-e2)*(n+1);
  val /= (e1*n + e2*(n+1));
  //printf("VAL: %15.15f\n", val);
  *Bnmrval = val*Enmrval;
  *Bnmival = val*Enmival;

}

void calcCnmFromEnm(int n, int m, double Enmrval, double Enmival, SProblem *problem, double *Cnmrval, double *Cnmival) {
  double e1 = problem->e1;
  double e2 = problem->e2;

  double val;

  val = n*(e1-e2)/(n*e1+e2*(n+1));
  val = (1./e2)*(1-val);

  *Cnmrval = val * Enmrval;
  *Cnmival = val * Enmival;

}

#undef __FUNCT__
#define __FUNCT__ "CalcSphericalCoulombPotential"
PetscErrorCode CalcSphericalCoulombPotential(PetscReal b, PetscReal eps1, PetscReal eps2, PetscInt nCharges, Vec chargeXYZ, Vec chargeMag, PetscInt nSol, Vec solXYZ, PetscInt Nmax, Vec targetSol)
{
  PetscErrorCode ierr;
  PetscInt numSol;
  Vec chargeSph;
  Vec solSph;
  Vec coulCoefs;
  PetscScalar *vecPtr, *solSphPtr;
  PetscReal solRad, solTheta, solPhi;
  PetscReal lterm, rterm, iterm;
  PetscReal Enmrval, Enmival;
  PetscReal radpow = 1.0;
  PetscFunctionBegin;

  //get number of solution points
  ierr = VecGetSize(targetSol, &numSol);CHKERRQ(ierr);

  // create charge spherical vec and convert from xyz
  ierr = VecCreateSeq(PETSC_COMM_SELF, 3*nCharges, &chargeSph);CHKERRQ(ierr);
  ierr = CartesianToSpherical(chargeXYZ, chargeSph);CHKERRQ(ierr);
  //create solution spherical vec and convert from xyz
  ierr = VecCreateSeq(PETSC_COMM_SELF, 3*nSol, &solSph);CHKERRQ(ierr);
  ierr = CartesianToSpherical(solXYZ, solSph);CHKERRQ(ierr);

  //zero solutions vec
  ierr = VecSet(targetSol, 0.0);CHKERRQ(ierr);

  ierr = VecGetArrayRead(solSph, &solSphPtr);CHKERRQ(ierr);
  ierr = VecGetArray(targetSol, &vecPtr);CHKERRQ(ierr);

  for(PetscInt n=0; n<=Nmax; ++n) {
    for(PetscInt m=-n; m <= n; ++m) {

      ierr = CalcEnm(chargeSph, chargeMag, n, m, &Enmrval, &Enmival);CHKERRQ(ierr);
      for(PetscInt k=0; k<numSol; ++k) {
	solRad = solSphPtr[3*k+0];
	solTheta = solSphPtr[3*k+1];
	solPhi = solSphPtr[3*k+2];
	lterm = gsl_sf_legendre_Plm(n, abs(m), cos(solTheta));//boost::math::legendre_p(n, abs(m), cos(theta));//legvals[n+abs(m)];//boost::math::legendre_p(n, m, cos(theta));
	rterm = cos(m*solPhi);
	iterm = sin(m*solPhi);
	vecPtr[k] += ((Enmrval*rterm - Enmival*iterm)*lterm)/(eps1*pow(solRad,n+1));
      }
    }
  }

  ierr = VecRestoreArray(targetSol, &vecPtr);CHKERRQ(ierr);
  ierr = VecRestoreArrayRead(solSph, &solSphPtr);CHKERRQ(ierr);
  PetscFunctionReturn(0);
}

double calcCoulombSpherical(SProblem *problem, int maxDeg, SPoint *r) {
  double val = 0;
  double e1 = problem->e1;
  double rad = r->x1;
  double theta = r->x2;
  double phi = r->x3;
  double radpow = 1.0;
  double lterm;
  double Enmrterm, Enmiterm;
  double rterm, iterm;

  for(int n=0; n<=maxDeg; ++n) {
    radpow *= rad;
    for(int m=-n; m<=n; ++m) {
      calcEnm(problem->positions, problem->charges, problem->nCharges, n, m, &Enmrterm, &Enmiterm);
      //printf("Enm %d %d %15.15f\n", n, m, Enm);

      //printf("cos(theta): %15.15f\n", theta);
      lterm = gsl_sf_legendre_Plm(n, abs(m), cos(theta));//boost::math::legendre_p(n, abs(m), cos(theta));//legvals[n+abs(m)];//boost::math::legendre_p(n, m, cos(theta));

      rterm = cos(m*phi);
      iterm = sin(m*phi);

      val += ((Enmrterm*rterm - Enmiterm*iterm)*lterm)/(e1*radpow);
      //printf("lterm: %15.15f\n", lterm);
      //printf("cos(mphi) = %15.15f\n\n", cos(m*phi));
    }
    printf("n = %d\nval = %15.15f\n", n, val);
  }

  return 0.0;
}

double calcCoulombSphericalGrid(SProblem *problem, int maxDeg, SPoint *r, int nPoints, double *solution) {
  double e1 = problem->e1;

  double rad, theta, phi;
  double lterm;
  double Enmrval, Enmival;
  double Bnmrval, Bnmival;
  double Cnmrval, Cnmival;
  double rval, ival;

  for(int i=0; i<nPoints; ++i)
    solution[i] = 0.0;
  for(int n=0; n<=maxDeg; ++n) {
    for(int m=-n; m<=n; ++m) {

      calcEnm(problem->positions, problem->charges, problem->nCharges, n, m, &Enmrval, &Enmival);
      calcBnmFromEnm(n, m, Enmrval, Enmival, problem, &Bnmrval, &Bnmival);
      calcCnmFromEnm(n, m, Enmrval, Enmival, problem, &Cnmrval, &Cnmival);

      for(int k=0; k<nPoints; ++k) {

	rad   = r[k].x1;
	theta = r[k].x2;
	phi   = r[k].x3;

	lterm = gsl_sf_legendre_Plm(n, abs(m), cos(theta));//boost::math::legendre_p(n, abs(m), cos(theta));

	rval = cos(m*phi);
	ival = sin(m*phi);

	if(rad < problem->b) {

	  solution[k] += (Bnmrval*rval - Bnmival*ival)*lterm*pow(rad,n);

	}
	else if(rad >  problem->b) {

	  solution[k] += ((Cnmrval*rval - Cnmival*ival)*lterm)/pow(rad,n+1);

	}
	else {

	  printf("CALCULATING ON BOUNDARY\n");
	  solution[k] += ((Enmrval*rval - Enmival*ival)*lterm)/(e1*pow(rad,n+1));
	}
      }
    }
    printf("n = %d\nval = %15.15f\n", n, solution[0]);
  }

  return 0.0;
}


static char help[] =
"Coupled reaction-diffusion equations (Pearson 1993).  Option prefix -ptn_.\n"
"Demonstrates form  F(t,Y,dot Y) = G(t,Y)  where F() is IFunction and G() is\n"
"RHSFunction().  Implements IJacobian().  Defaults to ARKIMEX (= adaptive\n"
"Runge-Kutta implicit-explicit) TS type.\n\n";

// compare runs with
//    -dm_mat_type aij|baij|sbaij
//    -dm_mat_type sbaij -ksp_type cg -pc_type icc  # 20% speed up?

#include <petsc.h>

typedef struct {
  double u, v;
} Field;

typedef struct {
  double    L,     // domain side length
            Du,    // diffusion coefficient: u equation
            Dv,    //                        v equation
            phi,   // "dimensionless feed rate" (F in Pearson 1993)
            kappa; // "dimensionless rate constant" (k in Pearson 1993)
} PatternCtx;

extern PetscErrorCode InitialState(DM, Vec, double, PatternCtx*);
extern PetscErrorCode FormRHSFunctionLocal(DMDALocalInfo*, double, Field**,
                                           Field**, PatternCtx*);
extern PetscErrorCode FormIFunctionLocal(DMDALocalInfo*, double, Field**, Field**,
                                         Field **, PatternCtx*);
extern PetscErrorCode FormIJacobianLocal(DMDALocalInfo*, double, Field**, Field**,
                                         double, Mat, Mat, PatternCtx*);

int main(int argc,char **argv)
{
  PetscErrorCode ierr;
  PatternCtx     user;
  TS             ts;
  Vec            x;
  DM             da;
  DMDALocalInfo  info;
  double         noiselevel = -1.0;  // negative value means no initial noise

  PetscInitialize(&argc,&argv,(char*)0,help);

  // parameter values from pages 21-22 in Hundsdorfer & Verwer (2003)
  user.L      = 2.5;
  user.Du     = 8.0e-5;
  user.Dv     = 4.0e-5;
  user.phi    = 0.024;
  user.kappa  = 0.06;
  ierr = PetscOptionsBegin(PETSC_COMM_WORLD, "ptn_", "options for patterns", ""); CHKERRQ(ierr);
  ierr = PetscOptionsReal("-noisy_init",
           "initialize u,v with this much random noise (e.g. 0.2) on top of usual initial values",
           "pattern.c",noiselevel,&noiselevel,NULL);CHKERRQ(ierr);
  ierr = PetscOptionsReal("-L","square domain side length; recommend L >= 0.5",
           "pattern.c",user.L,&user.L,NULL);CHKERRQ(ierr);
  ierr = PetscOptionsReal("-Du","diffusion coefficient of first equation",
           "pattern.c",user.Du,&user.Du,NULL);CHKERRQ(ierr);
  ierr = PetscOptionsReal("-Dv","diffusion coefficient of second equation",
           "pattern.c",user.Dv,&user.Dv,NULL);CHKERRQ(ierr);
  ierr = PetscOptionsReal("-phi","dimensionless feed rate (=F in (Pearson, 1993))",
           "pattern.c",user.phi,&user.phi,NULL);CHKERRQ(ierr);
  ierr = PetscOptionsReal("-kappa","dimensionless rate constant (=k in (Pearson, 1993))",
           "pattern.c",user.kappa,&user.kappa,NULL);CHKERRQ(ierr);
  ierr = PetscOptionsEnd(); CHKERRQ(ierr);

  ierr = DMDACreate2d(PETSC_COMM_WORLD,
               DM_BOUNDARY_PERIODIC, DM_BOUNDARY_PERIODIC,
               DMDA_STENCIL_BOX,  // for 9-point stencil
               3,3,PETSC_DECIDE,PETSC_DECIDE,
               2, 1,              // degrees of freedom, stencil width
               NULL,NULL,&da); CHKERRQ(ierr);
  ierr = DMSetFromOptions(da); CHKERRQ(ierr);
  ierr = DMSetUp(da); CHKERRQ(ierr);
  ierr = DMDASetFieldName(da,0,"u"); CHKERRQ(ierr);
  ierr = DMDASetFieldName(da,1,"v"); CHKERRQ(ierr);
  ierr = DMDAGetLocalInfo(da,&info); CHKERRQ(ierr);
  if (info.mx != info.my) {
      SETERRQ(PETSC_COMM_WORLD,1,"pattern.c requires mx == my");
  }
  ierr = DMDASetUniformCoordinates(da, 0.0, user.L, 0.0, user.L, -1.0, -1.0); CHKERRQ(ierr);
  ierr = PetscPrintf(PETSC_COMM_WORLD,
           "running on %d x %d grid with square cells of side h = %.6f ...\n",
           info.mx,info.my,user.L/(double)(info.mx)); CHKERRQ(ierr);

//STARTTSSETUP
  ierr = TSCreate(PETSC_COMM_WORLD,&ts); CHKERRQ(ierr);
  ierr = TSSetProblemType(ts,TS_NONLINEAR); CHKERRQ(ierr);
  ierr = TSSetDM(ts,da); CHKERRQ(ierr);
  ierr = TSSetApplicationContext(ts,&user); CHKERRQ(ierr);
  ierr = DMDATSSetRHSFunctionLocal(da,INSERT_VALUES,
           (DMDATSRHSFunctionLocal)FormRHSFunctionLocal,&user); CHKERRQ(ierr);
  ierr = DMDATSSetIFunctionLocal(da,INSERT_VALUES,
           (DMDATSIFunctionLocal)FormIFunctionLocal,&user); CHKERRQ(ierr);
  ierr = DMDATSSetIJacobianLocal(da,
           (DMDATSIJacobianLocal)FormIJacobianLocal,&user); CHKERRQ(ierr);
  ierr = TSSetType(ts,TSARKIMEX); CHKERRQ(ierr);
  ierr = TSSetTime(ts,0.0); CHKERRQ(ierr);
  ierr = TSSetMaxTime(ts,200.0); CHKERRQ(ierr);
  ierr = TSSetTimeStep(ts,5.0); CHKERRQ(ierr);
  ierr = TSSetExactFinalTime(ts,TS_EXACTFINALTIME_MATCHSTEP); CHKERRQ(ierr);
  ierr = TSSetFromOptions(ts);CHKERRQ(ierr);
//ENDTSSETUP

  ierr = DMCreateGlobalVector(da,&x); CHKERRQ(ierr);
  ierr = InitialState(da,x,noiselevel,&user); CHKERRQ(ierr);
  ierr = TSSolve(ts,x); CHKERRQ(ierr);

  VecDestroy(&x);  TSDestroy(&ts);  DMDestroy(&da);
  return PetscFinalize();
}

// Formulas from page 22 of Hundsdorfer & Verwer (2003).  Interpretation here is
// to always generate 0.5 x 0.5 non-trivial patch in (0,L) x (0,L) domain.
PetscErrorCode InitialState(DM da, Vec Y, double noiselevel, PatternCtx* user) {
  PetscErrorCode ierr;
  DMDALocalInfo  info;
  int            i,j;
  double         sx,sy;
  const double   ledge = (user->L - 0.5) / 2.0, // nontrivial initial values on
                 redge = user->L - ledge;       //   ledge < x,y < redge
  DMDACoor2d     **aC;
  Field          **aY;

  ierr = VecSet(Y,0.0); CHKERRQ(ierr);
  if (noiselevel > 0.0) {
      // noise added to usual initial condition is uniform on [0,noiselevel],
      //     independently for each location and component
      ierr = VecSetRandom(Y,NULL); CHKERRQ(ierr);
      ierr = VecScale(Y,noiselevel); CHKERRQ(ierr);
  }
  ierr = DMDAGetLocalInfo(da,&info); CHKERRQ(ierr);
  ierr = DMDAGetCoordinateArray(da,&aC); CHKERRQ(ierr);
  ierr = DMDAVecGetArray(da,Y,&aY); CHKERRQ(ierr);
  for (j = info.ys; j < info.ys+info.ym; j++) {
    for (i = info.xs; i < info.xs+info.xm; i++) {
      if ((aC[j][i].x >= ledge) && (aC[j][i].x <= redge)
              && (aC[j][i].y >= ledge) && (aC[j][i].y <= redge)) {
          sx = sin(4.0 * PETSC_PI * aC[j][i].x);
          sy = sin(4.0 * PETSC_PI * aC[j][i].y);
          aY[j][i].v += 0.5 * sx * sx * sy * sy;
      }
      aY[j][i].u += 1.0 - 2.0 * aY[j][i].v;
    }
  }
  ierr = DMDAVecRestoreArray(da,Y,&aY); CHKERRQ(ierr);
  ierr = DMDARestoreCoordinateArray(da,&aC); CHKERRQ(ierr);
  return 0;
}

// in system form  F(t,Y,dot Y) = G(t,Y),  compute G():
//     G^u(t,u,v) = - u v^2 + phi (1 - u)
//     G^v(t,u,v) = + u v^2 - (phi + kappa) v
//STARTRHSFUNCTION
PetscErrorCode FormRHSFunctionLocal(DMDALocalInfo *info,
                   double t, Field **aY, Field **aG, PatternCtx *user) {
  int            i, j;
  double         uv2;

  for (j = info->ys; j < info->ys + info->ym; j++) {
      for (i = info->xs; i < info->xs + info->xm; i++) {
          uv2 = aY[j][i].u * aY[j][i].v * aY[j][i].v;
          aG[j][i].u = - uv2 + user->phi * (1.0 - aY[j][i].u);
          aG[j][i].v = + uv2 - (user->phi + user->kappa) * aY[j][i].v;
      }
  }
  return 0;
}
//ENDRHSFUNCTION

// in system form  F(t,Y,dot Y) = G(t,Y),  compute F():
//     F^u(t,u,v,u_t,v_t) = u_t - D_u Laplacian u
//     F^v(t,u,v,u_t,v_t) = v_t - D_v Laplacian v
//STARTIFUNCTION
PetscErrorCode FormIFunctionLocal(DMDALocalInfo *info,
                   double t, Field **aY, Field **aYdot, Field **aF,
                   PatternCtx *user) {
  int            i, j;
  const double   h = user->L / (double)(info->mx),
                 Cu = user->Du / (6.0 * h * h),
                 Cv = user->Dv / (6.0 * h * h);
  double         u, v, lapu, lapv;

  for (j = info->ys; j < info->ys + info->ym; j++) {
      for (i = info->xs; i < info->xs + info->xm; i++) {
          u = aY[j][i].u;
          v = aY[j][i].v;
          lapu =     aY[j+1][i-1].u + 4.0*aY[j+1][i].u +   aY[j+1][i+1].u
                 + 4.0*aY[j][i-1].u -    20.0*u        + 4.0*aY[j][i+1].u
                 +   aY[j-1][i-1].u + 4.0*aY[j-1][i].u +   aY[j-1][i+1].u;
          lapv =     aY[j+1][i-1].v + 4.0*aY[j+1][i].v +   aY[j+1][i+1].v
                 + 4.0*aY[j][i-1].v -    20.0*v        + 4.0*aY[j][i+1].v
                 +   aY[j-1][i-1].v + 4.0*aY[j-1][i].v +   aY[j-1][i+1].v;
          aF[j][i].u = aYdot[j][i].u - Cu * lapu;
          aF[j][i].v = aYdot[j][i].v - Cv * lapv;
      }
  }
  return 0;
}
//ENDIFUNCTION

// in system form  F(t,Y,dot Y) = G(t,Y),  compute combined/shifted
// Jacobian of F():
//     J = (shift) dF/d(dot Y) + dF/dY
//STARTIJACOBIAN
PetscErrorCode FormIJacobianLocal(DMDALocalInfo *info,
                   double t, Field **aY, Field **aYdot, double shift,
                   Mat J, Mat P, PatternCtx *user) {
    PetscErrorCode ierr;
    int            i, j, s, c;
    const double   h = user->L / (double)(info->mx),
                   Cu = user->Du / (6.0 * h * h),
                   Cv = user->Dv / (6.0 * h * h);
    double         val[9], CC;
    MatStencil     col[9], row;

    for (j = info->ys; j < info->ys + info->ym; j++) {
        row.j = j;
        for (i = info->xs; i < info->xs + info->xm; i++) {
            row.i = i;
            for (c = 0; c < 2; c++) { // u,v equations are c=0,1
                row.c = c;
                CC = (c == 0) ? Cu : Cv;
                for (s = 0; s < 9; s++)
                    col[s].c = c;
                col[0].i = i;   col[0].j = j;
                val[0] = shift + 20.0 * CC;
                col[1].i = i-1; col[1].j = j;    val[1] = - 4.0 * CC;
                col[2].i = i+1; col[2].j = j;    val[2] = - 4.0 * CC;
                col[3].i = i;   col[3].j = j-1;  val[3] = - 4.0 * CC;
                col[4].i = i;   col[4].j = j+1;  val[4] = - 4.0 * CC;
                col[5].i = i-1; col[5].j = j-1;  val[5] = - CC;
                col[6].i = i-1; col[6].j = j+1;  val[6] = - CC;
                col[7].i = i+1; col[7].j = j-1;  val[7] = - CC;
                col[8].i = i+1; col[8].j = j+1;  val[8] = - CC;
                ierr = MatSetValuesStencil(P,1,&row,9,col,val,INSERT_VALUES); CHKERRQ(ierr);
            }
        }
    }

    ierr = MatAssemblyBegin(P,MAT_FINAL_ASSEMBLY); CHKERRQ(ierr);
    ierr = MatAssemblyEnd(P,MAT_FINAL_ASSEMBLY); CHKERRQ(ierr);
    if (J != P) {
        ierr = MatAssemblyBegin(J,MAT_FINAL_ASSEMBLY); CHKERRQ(ierr);
        ierr = MatAssemblyEnd(J,MAT_FINAL_ASSEMBLY); CHKERRQ(ierr);
    }
    return 0;
}
//ENDIJACOBIAN


//
// Created by peixinho on 19/12/16.
//

#include <ml_matrix.h>
#include <cblas.h>
#include <ml_memory.h>

MlMatrix* ml_create_matrix(size_t nrow, size_t ncol) {
    MlMatrix* m = NULL;
    m = ml_alloc(MlMatrix);
    m->nrows = nrow;
    m->ncols = ncol;
    m->n = nrow*ncol;
    m->data = ml_alloc_array(m->n, float);
    return m;
}

void mlMultMatrixIp(MlMatrix* A, MlMatrix* B, MlMatrix* M) {
    double alpha = 1.0, beta = 0.0;

    cblas_sgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, A->nrows, B->ncols, \
        A->ncols, alpha, A->data, A->ncols, B->data, B->ncols, beta, \
        M->data, B->ncols);
}

MlMatrix* mlMultMatrix(MlMatrix* A, MlMatrix* B) {
    MlMatrix* M = ml_create_matrix(B->ncols, A->nrows);
    mlMultMatrixIp(A, B, M);
    return M;
}

float mlMeanMatrix(MlMatrix* m) {
    float mean = 0.0f;
    for (int i = 0; i < m->n; ++i) {
        mean += m->data[i] / m->n;
    }
    return mean;
}

MlMatrix* mlMatrixSumCol(MlMatrix* m) {
    MlMatrix* sum = ml_create_matrix(1, m->ncols);

    for (int i = 0; i < m->nrows; ++i) {
        for (int j = 0; j < m->ncols; ++j) {
            ml_mat_elem(sum, 0, j) += ml_mat_elem(m, i, j);
        }
    }

    return sum;
}

void ml_set_matrix(MlMatrix *m, float val) {
    for (int i = 0; i < m->n; ++i)
        m->data[i] = val;
}

void ml_free_matrix(MlMatrix *m) {
    ml_free(m->data);
    ml_free(m);
}

void ml_print_matrix(MlMatrix *m) {
    printf("[");
    for (int r = 0; r < m->nrows; ++r) {
        printf("[");
        for (int c = 0; c < m->ncols; ++c) {
            printf("%4.2f", ml_mat_elem(m, r, c));
            if(c < m->ncols-1)
                printf(", ");
        }
        printf("]");
        if(r<m->nrows-1)
            printf("\n");
    }
    printf("]\n");
}


static char help[] =
"Solves time-dependent heat equation in 2D using TS.  Option prefix -ht_.\n"
"Equation is  u_t = D_0 laplacian u + f.  Domain is (0,1) x (0,1).\n"
"Boundary conditions are non-homogeneous Neumann in x and periodic in y.\n"
"Energy is conserved (for these particular conditions/source) and an extra\n"
"'monitor' is demonstrated.  Discretization is by centered finite differences.\n"
"Converts the PDE into a system  X_t = G(t,X) (PETSc type 'nonlinear') by\n"
"method of lines.  Uses backward Euler time-stepping by default.\n";

#include <petsc.h>

typedef struct {
  PetscReal D0;    // conductivity
} HeatCtx;

static PetscReal f_source(PetscReal x, PetscReal y) {
    return 3.0 * PetscExpReal(-25.0 * (x-0.6) * (x-0.6))
               * PetscSinReal(2.0*PETSC_PI*y);
}

static PetscReal gamma_neumann(PetscReal y) {
    return PetscSinReal(6.0 * PETSC_PI * y);
}

extern PetscErrorCode Spacings(DMDALocalInfo*, PetscReal*, PetscReal*);
extern PetscErrorCode EnergyMonitor(TS, PetscInt, PetscReal, Vec, void*);
extern PetscErrorCode FormRHSFunctionLocal(DMDALocalInfo*, PetscReal, PetscReal**,
                                           PetscReal**, HeatCtx*);
extern PetscErrorCode FormRHSJacobianLocal(DMDALocalInfo*, PetscReal, PetscReal**,
                                           Mat, Mat, HeatCtx*);

int main(int argc,char **argv) {
  PetscErrorCode ierr;
  HeatCtx        user;
  TS             ts;
  Vec            u;
  DM             da;
  DMDALocalInfo  info;
  PetscReal      t0, tf;
  PetscBool      monitorenergy = PETSC_FALSE;

  ierr = PetscInitialize(&argc,&argv,NULL,help); if (ierr) return ierr;

  user.D0  = 1.0;
  ierr = PetscOptionsBegin(PETSC_COMM_WORLD, "ht_", "options for heat", ""); CHKERRQ(ierr);
  ierr = PetscOptionsReal("-D0","constant thermal diffusivity",
           "heat.c",user.D0,&user.D0,NULL);CHKERRQ(ierr);
  ierr = PetscOptionsBool("-monitor","also display total heat energy at each step",
           "heat.c",monitorenergy,&monitorenergy,NULL);CHKERRQ(ierr);
  ierr = PetscOptionsEnd(); CHKERRQ(ierr);

//STARTDMDASETUP
  ierr = DMDACreate2d(PETSC_COMM_WORLD,
      DM_BOUNDARY_NONE, DM_BOUNDARY_PERIODIC, DMDA_STENCIL_STAR,
      5,4,PETSC_DECIDE,PETSC_DECIDE,  // default to hx=hx=0.25 grid
      1,1,                            // degrees of freedom, stencil width
      NULL,NULL,&da); CHKERRQ(ierr);
  ierr = DMSetFromOptions(da); CHKERRQ(ierr);
  ierr = DMSetUp(da); CHKERRQ(ierr);
  ierr = DMCreateGlobalVector(da,&u); CHKERRQ(ierr);
//ENDDMDASETUP

//STARTTSSETUP
  ierr = TSCreate(PETSC_COMM_WORLD,&ts); CHKERRQ(ierr);
  ierr = TSSetProblemType(ts,TS_NONLINEAR); CHKERRQ(ierr);
  ierr = TSSetDM(ts,da); CHKERRQ(ierr);
  ierr = TSSetApplicationContext(ts,&user); CHKERRQ(ierr);
  ierr = DMDATSSetRHSFunctionLocal(da,INSERT_VALUES,
           (DMDATSRHSFunctionLocal)FormRHSFunctionLocal,&user); CHKERRQ(ierr);
  ierr = DMDATSSetRHSJacobianLocal(da,
           (DMDATSRHSJacobianLocal)FormRHSJacobianLocal,&user); CHKERRQ(ierr);
  if (monitorenergy) {
      ierr = TSMonitorSet(ts,EnergyMonitor,&user,NULL); CHKERRQ(ierr);
  }
  ierr = TSSetType(ts,TSBDF); CHKERRQ(ierr);
  ierr = TSSetTime(ts,0.0); CHKERRQ(ierr);
  ierr = TSSetMaxTime(ts,0.1); CHKERRQ(ierr);
  ierr = TSSetTimeStep(ts,0.001); CHKERRQ(ierr);
  ierr = TSSetExactFinalTime(ts,TS_EXACTFINALTIME_MATCHSTEP); CHKERRQ(ierr);
  ierr = TSSetFromOptions(ts);CHKERRQ(ierr);
//ENDTSSETUP

  // report on set up
  ierr = TSGetTime(ts,&t0); CHKERRQ(ierr);
  ierr = TSGetMaxTime(ts,&tf); CHKERRQ(ierr);
  ierr = DMDAGetLocalInfo(da,&info); CHKERRQ(ierr);
  ierr = PetscPrintf(PETSC_COMM_WORLD,
           "solving on %d x %d grid for t0=%g to tf=%g ...\n",
           info.mx,info.my,t0,tf); CHKERRQ(ierr);

  // solve
  ierr = VecSet(u,0.0); CHKERRQ(ierr);   // initial condition
  ierr = TSSolve(ts,u); CHKERRQ(ierr);

  VecDestroy(&u);  TSDestroy(&ts);  DMDestroy(&da);
  return PetscFinalize();
}

PetscErrorCode Spacings(DMDALocalInfo *info, PetscReal *hx, PetscReal *hy) {
    if (hx)  *hx = 1.0 / (PetscReal)(info->mx-1);
    if (hy)  *hy = 1.0 / (PetscReal)(info->my);   // periodic direction
    return 0;
}

//STARTMONITOR
PetscErrorCode EnergyMonitor(TS ts, PetscInt step, PetscReal time, Vec u,
                             void *ctx) {
    PetscErrorCode ierr;
    HeatCtx        *user = (HeatCtx*)ctx;
    PetscReal      lenergy = 0.0, energy, dt, hx, hy, **au;
    PetscInt       i,j;
    MPI_Comm       com;
    DM             da;
    DMDALocalInfo  info;

    ierr = TSGetDM(ts,&da); CHKERRQ(ierr);
    ierr = DMDAGetLocalInfo(da,&info); CHKERRQ(ierr);
    ierr = DMDAVecGetArrayRead(da,u,&au); CHKERRQ(ierr);
    for (j = info.ys; j < info.ys + info.ym; j++) {
        for (i = info.xs; i < info.xs + info.xm; i++) {
            if ((i == 0) || (i == info.mx-1))
                lenergy += 0.5 * au[j][i];
            else
                lenergy += au[j][i];
        }
    }
    ierr = DMDAVecRestoreArrayRead(da,u,&au); CHKERRQ(ierr);
    ierr = Spacings(&info,&hx,&hy); CHKERRQ(ierr);
    lenergy *= hx * hy;
    ierr = PetscObjectGetComm((PetscObject)(da),&com); CHKERRQ(ierr);
    ierr = MPI_Allreduce(&lenergy,&energy,1,MPIU_REAL,MPIU_SUM,com); CHKERRQ(ierr);
    ierr = TSGetTimeStep(ts,&dt); CHKERRQ(ierr);
    ierr = PetscPrintf(PETSC_COMM_WORLD,"  energy = %9.2e     nu = %8.4f\n",
                energy,user->D0*dt/(hx*hy)); CHKERRQ(ierr);
    return 0;
}
//ENDMONITOR

//STARTRHSFUNCTION
PetscErrorCode FormRHSFunctionLocal(DMDALocalInfo *info,
                                    PetscReal t, PetscReal **au,
                                    PetscReal **aG, HeatCtx *user) {
  PetscErrorCode ierr;
  PetscInt   i, j, mx = info->mx;
  PetscReal  hx, hy, x, y, ul, ur, uxx, uyy;

  ierr = Spacings(info,&hx,&hy); CHKERRQ(ierr);
  for (j = info->ys; j < info->ys + info->ym; j++) {
      y = hy * j;
      for (i = info->xs; i < info->xs + info->xm; i++) {
          x = hx * i;
          // apply Neumann b.c.s
          ul = (i == 0) ? au[j][i+1] + 2.0 * hx * gamma_neumann(y)
                        : au[j][i-1];
          ur = (i == mx-1) ? au[j][i-1] : au[j][i+1];
          uxx = (ul - 2.0 * au[j][i]+ ur) / (hx*hx);
          // DMDA is periodic in y
          uyy = (au[j-1][i] - 2.0 * au[j][i]+ au[j+1][i]) / (hy*hy);
          aG[j][i] = user->D0 * (uxx + uyy) + f_source(x,y);
      }
  }
  return 0;
}
//ENDRHSFUNCTION

//STARTRHSJACOBIAN
PetscErrorCode FormRHSJacobianLocal(DMDALocalInfo *info,
                                    PetscReal t, PetscReal **au,
                                    Mat J, Mat P, HeatCtx *user) {
    PetscErrorCode ierr;
    PetscInt         i, j, ncols;
    const PetscReal  D = user->D0;
    PetscReal        hx, hy, hx2, hy2, v[5];
    MatStencil       col[5],row;

    ierr = Spacings(info,&hx,&hy); CHKERRQ(ierr);
    hx2 = hx * hx;  hy2 = hy * hy;
    for (j = info->ys; j < info->ys+info->ym; j++) {
        row.j = j;  col[0].j = j;
        for (i = info->xs; i < info->xs+info->xm; i++) {
            // set up a standard 5-point stencil for the row
            row.i = i;
            col[0].i = i;
            v[0] = - 2.0 * D * (1.0 / hx2 + 1.0 / hy2);
            col[1].j = j-1;  col[1].i = i;    v[1] = D / hy2;
            col[2].j = j+1;  col[2].i = i;    v[2] = D / hy2;
            col[3].j = j;    col[3].i = i-1;  v[3] = D / hx2;
            col[4].j = j;    col[4].i = i+1;  v[4] = D / hx2;
            ncols = 5;
            // if at the boundary, edit the row back to 4 nonzeros
            if (i == 0) {
                ncols = 4;
                col[3].j = j;  col[3].i = i+1;  v[3] = 2.0 * D / hx2;
            } else if (i == info->mx-1) {
                ncols = 4;
                col[3].j = j;  col[3].i = i-1;  v[3] = 2.0 * D / hx2;
            }
            ierr = MatSetValuesStencil(P,1,&row,ncols,col,v,INSERT_VALUES); CHKERRQ(ierr);
        }
    }

    ierr = MatAssemblyBegin(P,MAT_FINAL_ASSEMBLY); CHKERRQ(ierr);
    ierr = MatAssemblyEnd(P,MAT_FINAL_ASSEMBLY); CHKERRQ(ierr);
    if (J != P) {
        ierr = MatAssemblyBegin(J,MAT_FINAL_ASSEMBLY); CHKERRQ(ierr);
        ierr = MatAssemblyEnd(J,MAT_FINAL_ASSEMBLY); CHKERRQ(ierr);
    }
    return 0;
}
//ENDRHSJACOBIAN


/* sys/pow_int.c
 *
 * Copyright (C) 1996, 1997, 1998, 1999, 2000 Gerard Jungman
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or (at
 * your option) any later version.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 */
#include <config.h>
#include <math.h>
#include <gsl/gsl_pow_int.h>

#ifndef HIDE_INLINE_STATIC
double gsl_pow_2(const double x) { return x*x;   }
double gsl_pow_3(const double x) { return x*x*x; }
double gsl_pow_4(const double x) { double x2 = x*x;   return x2*x2;    }
double gsl_pow_5(const double x) { double x2 = x*x;   return x2*x2*x;  }
double gsl_pow_6(const double x) { double x2 = x*x;   return x2*x2*x2; }
double gsl_pow_7(const double x) { double x3 = x*x*x; return x3*x3*x;  }
double gsl_pow_8(const double x) { double x2 = x*x;   double x4 = x2*x2; return x4*x4; }
double gsl_pow_9(const double x) { double x3 = x*x*x; return x3*x3*x3; }
#endif

double gsl_pow_int(double x, int n)
{
  double value = 1.0;

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

  /* repeated squaring method
   * returns 0.0^0 = 1.0, so continuous in x
   */
  do {
     if(n & 1) value *= x;  /* for n odd */
     n >>= 1;
     x *= x;
  } while (n);

  return value;
}


#include <stdlib.h>
#include <math.h>

#include <complex.h>
#include <fftw3.h>

#include <gsl/gsl_sf_result.h>
#include <gsl/gsl_sf_gamma.h>
#include "ccl.h"

/****************************************************************

This is the famous FFTLog.

First imlplemented by the living legend Andrew Hamilton:

http://casa.colorado.edu/~ajsh/FFTLog/

This version is a C version that was adapted from the C++ version found
in Copter JWG Carlson, another big loss for the cosmology community.

https://github.com/jwgcarlson/Copter

I've transformed this from C++ to C99 as the lowest common denominator
and provided bindings for C++ and python.

These are the C++ bindings

*****************************************************************/

#ifndef M_PI
#define M_PI 3.14159265358979323846
#endif
#ifndef M_LN2
#define M_LN2 0.69314718056
#endif
/* This code is FFTLog, which is described in arXiv:astro-ph/9905191 */

static double complex lngamma_fftlog(double complex z)
{
  gsl_sf_result lnr, phi;
  gsl_sf_lngamma_complex_e(creal(z), cimag(z), &lnr, &phi);
  return lnr.val + I*phi.val;
}

static double complex gamma_fftlog(double complex z)
{
  return cexp(lngamma_fftlog(z));
}

static double complex polar (double r, double phi)
{
  return (r*cos(phi) +I*(r*sin(phi)));
}

static void lngamma_4(double x, double y, double* lnr, double* arg)
{
  double complex w = lngamma_fftlog(x+y*I);
  if(lnr) *lnr = creal(w);
  if(arg) *arg = cimag(w);
}

static double goodkr(int N, double mu, double q, double L, double kr)
{
  double xp = (mu+1+q)/2;
  double xm = (mu+1-q)/2;
  double y = M_PI*N/(2*L);
  double lnr, argm, argp;
  lngamma_4(xp, y, &lnr, &argp);
  lngamma_4(xm, y, &lnr, &argm);
  double arg = log(2/kr) * N/L + (argp + argm)/M_PI;
  double iarg = round(arg);
  if(arg != iarg)
    kr *= exp((arg - iarg)*L/N);
  return kr;
}

/* Pre-compute the coefficients that appear in the FFTLog implementation of
 * the discrete Hankel transform.  The parameters N, mu, and q here are the
 * same as for the function fht().  The parameter L is defined (for whatever
 * reason) to be N times the logarithmic spacing of the input array, i.e.
 *   L = N * log(r[N-1]/r[0])/(N-1) */
static void compute_u_coefficients(int N, double mu, double q, double L, double kcrc, double complex *u)
{
  double y = M_PI/L;
  double k0r0 = kcrc * exp(-L);
  double t = -2*y*log(k0r0/2);

  if(q == 0) {
    double x = (mu+1)/2;
    double lnr, phi;
    for(int m = 0; m <= N/2; m++) {
      lngamma_4(x, m*y, &lnr, &phi);
      u[m] = polar(1.0,m*t + 2*phi);
    }
  }
  else {
    double xp = (mu+1+q)/2;
    double xm = (mu+1-q)/2;
    double lnrp, phip, lnrm, phim;
    for(int m = 0; m <= N/2; m++) {
      lngamma_4(xp, m*y, &lnrp, &phip);
      lngamma_4(xm,-m*y, &lnrm, &phim);
      u[m] = polar(exp(q*M_LN2 + lnrp - lnrm), m*t + phip - phim);
    }
  }

  for(int m = N/2+1; m < N; m++)
    u[m] = conj(u[N-m]);
  if((N % 2) == 0)
    u[N/2] = (creal(u[N/2]) + I*0.0);
}

/* Compute the discrete Hankel transform of the function a(r).  See the FFTLog
 * documentation (or the Fortran routine of the same name in the FFTLog
 * sources) for a description of exactly what this function computes.
 * If u is NULL, the transform coefficients will be computed anew and discarded
 * afterwards.  If you plan on performing many consecutive transforms, it is
 * more efficient to pre-compute the u coefficients. */
static void fht(int npk, int N,
		double *k, double **pk,
		double *r, double **xi,
		double dim, double mu, double q, double kcrc,
		int noring, double complex* u, int *status)
{
  fftw_plan forward_plan, reverse_plan;
  double L = log(k[N-1]/k[0]) * N/(N-1.);
  double complex* ulocal = NULL;
  if(u == NULL) {
    if(noring)
      kcrc = goodkr(N, mu, q, L, kcrc);

    ulocal = malloc (sizeof(complex double)*N);
    if(ulocal==NULL)
      *status=CCL_ERROR_MEMORY;

    if(*status == 0) {
      compute_u_coefficients(N, mu, q, L, kcrc, ulocal);
      u = ulocal;
    }
  }

  fftw_complex* a_tmp;
  fftw_complex* b_tmp;
  if(*status == 0) {
    a_tmp = fftw_alloc_complex(N);
    if(a_tmp==NULL)
      *status=CCL_ERROR_MEMORY;
  }
  if(*status == 0) {
    b_tmp = fftw_alloc_complex(N);
    if(b_tmp==NULL)
      *status=CCL_ERROR_MEMORY;
  }

  if(*status == 0) {
    /* Compute the convolution b = a*u using FFTs */
    forward_plan = fftw_plan_dft_1d(N,
                                    (fftw_complex*) a_tmp,
                                    (fftw_complex*) b_tmp,
                                    -1, FFTW_ESTIMATE);
    reverse_plan = fftw_plan_dft_1d(N,
                                    (fftw_complex*) b_tmp,
                                    (fftw_complex*) b_tmp,
                                    +1, FFTW_ESTIMATE);
  }

  if(*status == 0) {
    #pragma omp parallel default(none) \
                         shared(npk, N, k, pk, r, xi, \
                                dim, mu, q, kcrc, u, status, \
                                forward_plan, reverse_plan, \
                                L, ulocal)
    {
      int local_status = 0;

      double *prefac_pk=NULL;
      if(local_status == 0) {
        prefac_pk = malloc(N*sizeof(double));
        if(prefac_pk==NULL)
          local_status=CCL_ERROR_MEMORY;
      }

      double *prefac_xi=NULL;
      if(local_status == 0) {
        prefac_xi = malloc(N*sizeof(double));
        if(prefac_xi==NULL)
          local_status=CCL_ERROR_MEMORY;
      }

      fftw_complex* a=NULL;
      fftw_complex* b=NULL;
      if(local_status == 0) {
        a = fftw_alloc_complex(N);
        if(a==NULL)
        local_status=CCL_ERROR_MEMORY;
      }

      if(local_status == 0) {
        b = fftw_alloc_complex(N);
        if(b==NULL)
          local_status=CCL_ERROR_MEMORY;
      }

      if(local_status == 0) {
        for(int i = 0; i < N; i++)
          prefac_pk[i] = pow(k[i], dim/2-q);

        /* Compute k's corresponding to input r's */
        double k0r0 = kcrc * exp(-L);
        r[0] = k0r0/k[0];
        for(int n = 1; n < N; n++)
          r[n] = r[0] * exp(n*L/N);

        double one_over_2pi_dhalf = pow(2*M_PI,-dim/2);
        for(int i = 0; i < N; i++)
          prefac_xi[i] = one_over_2pi_dhalf * pow(r[i], -dim/2-q);

        #pragma omp for
        for(int j = 0; j < npk; j++) {
          for(int i = 0; i < N; i++)
            a[i] = prefac_pk[i] * pk[j][i];

          fftw_execute_dft(forward_plan,a,b);
          for(int m = 0; m < N; m++)
            b[m] *= u[m] / (double)(N);       // divide by N since FFTW doesn't normalize the inverse FFT
          fftw_execute_dft(reverse_plan,b,b);

          /* Reverse b array */
          double complex tmp;
          for(int n = 0; n < N/2; n++) {
            tmp = b[n];
            b[n] = b[N-n-1];
            b[N-n-1] = tmp;
          }

          for(int i = 0; i < N; i++)
            xi[j][i] = prefac_xi[i] * creal(b[i]);
        }
      }

      free(prefac_pk);
      free(prefac_xi);
      fftw_free(a);
      fftw_free(b);

      if (local_status) {
        #pragma omp atomic write
        *status = local_status;
      }
    } //end omp parallel
  }

  if(*status == 0) {
    fftw_destroy_plan(forward_plan);
    fftw_destroy_plan(reverse_plan);
  }

  free(ulocal);
  //TODO: free this up
  fftw_free(a_tmp);
  fftw_free(b_tmp);
}

void ccl_fftlog_ComputeXi2D(double mu, double epsilon,
			    int npk, int N, double *l,double **cl,
			    double *th, double **xi, int *status)
{
  fht(npk, N, l, cl, th, xi, 2., mu, epsilon, 1, 1, NULL, status);
}

void ccl_fftlog_ComputeXi3D(double l, double epsilon,
			    int npk, int N, double *k, double **pk,
			    double *r, double **xi, int *status)
{
  fht(npk, N, k, pk, r, xi, 3., l+0.5, epsilon, 1, 1, NULL, status);
}


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

int
main ()
{
  size_t i,j;

  gsl_matrix *m = gsl_matrix_alloc (10, 10);

  for (i = 0; i < 10; i++)
    for (j = 0; j < 10; j++)
      gsl_matrix_set (m, i, j, sin (i) + cos (j));

  for (j = 0; j < 10; j++)
    {
      gsl_vector_view column = gsl_matrix_column (m, j);
      double d;

      d = gsl_blas_dnrm2 (&column.vector);

      printf ("matrix column %d, norm = %g\n", j, d);
    }

  gsl_matrix_free (m);
}


/*This program is the first step in solving the Merlin-Salgado equation.
It produces a .dat file with the scale factor in terms of the conformal time and the cosmic time.
The .dat file columns are formatted in the next way:
cosmic_time   conformal_fime   scale_factor   cosmic_time_der_scale_factor*/

#include <stdlib.h>
#include <stdio.h>
#include <math.h>
#include <gsl/gsl_integration.h>
#include <gsl/gsl_errno.h>

#define NLINES 11
#define H0 0.1          //Hubble paramater
#define OMEGAMAT 0.3    //Omega matter
#define OMEGALAM 0.7    //Omega lambda

/*Structure with parameters needed for the function to integrate
hubble: The Hubble parameter
omega_m: Density parameter for matter (dark matter and baryonic)
omega_l: Density parameter for dark energy*/
struct Iparams
{
  double hubble;
  double omega_m;
  double omega_l;
};

/*This function multiplied by the differential of the scale factor is the differential of cosmic time*/
double integrando_cosmictime(double a, void *parameters)
{
  struct Iparams *p = (struct Iparams *) parameters; //Structure of parameters

  double h0 = p->hubble;
  double om = p->omega_m;
  double ol = p->omega_l;
  double f = (1/h0)/(sqrt(om*pow(a,-1) + ol*pow(a,2))); //Integrate to cosmic time

  return f;
}

/*This function multiplied by the differential of the scale factor is the differential of conformal time*/
double integrando_conformaltime(double a, void *parameters)
{
  struct Iparams *p = (struct Iparams *) parameters; //Structure of parameters

  double h0 = p->hubble;
  double om = p->omega_m;
  double ol = p->omega_l;
  double f = (1/h0)/(sqrt(om*a + ol*pow(a,4))); //Integrate to conformal time

  return f;
}

/*Derivative of the scale factor as a function of scale factor*/
double der_scale_factor(double a)
{
  double adot = H0*sqrt(OMEGAMAT*pow(a,-1)+OMEGALAM*pow(a,2));
  return adot;
}

int main (void)
{
  /*Variable for temporary saving derivative of scale factor in interations*/
  double adot;

  struct Iparams parameters; // Structure of parameters for functions to integrate
  /*Asign values to the structure of parameters*/
  parameters.hubble = H0;
  parameters.omega_m = OMEGAMAT;
  parameters.omega_l = OMEGALAM;

  /*File to be written with data*/
  FILE *pf;
  pf = fopen("scale_factor.dat","w");

  /*GSL object. Necessary object to separate enough space in memory for integration. 1 and 2 refer to cosmic and conformal time respectively*/
  gsl_integration_workspace *w1;
  gsl_integration_workspace *w2;

  /*result: Result of integration. error: Maximum relative error. 1 and 2 refer to cosmic and conformal time respectively*/
  double result1, result2, error1, error2, epsrel = 1.0e-11;
  size_t limit = 1000; //Maximum number of subintervals for integration
  /*a: Inferior integration limit. b: Superior integration limit*/
  double a = 0.0, b = 0.0;

  /*GSL object. Contain all information about the integrand.*/
  gsl_function Fcosmic, Fconformal;
  /*Defining Fcosmic*/
  Fcosmic.function = &integrando_cosmictime;
  Fcosmic.params = &parameters;
  /*Defining Fconformal*/
  Fconformal.function = &integrando_conformaltime;
  Fconformal.params = &parameters;

  /*Allocate space in memory*/
  w1 = gsl_integration_workspace_alloc(limit);
  w2 = gsl_integration_workspace_alloc(limit);

  for(b = 0.0001;b <= 1.0;b += 0.0001)
    {
      /*Numerical integration of functions*/
      gsl_integration_qags(&Fcosmic, a, b, 0, epsrel, limit, w1, &result1, &error1);
      gsl_integration_qags(&Fconformal, a, b, 0, epsrel, limit, w2, &result2, &error2);
      adot = der_scale_factor(b);
      fprintf(pf, "%.12f %.12f %.12f %.12f\n", result1, result2, b, adot);
    }

  /*Close streams and free space in memory*/
  fclose(pf);
  gsl_integration_workspace_free(w1);
  gsl_integration_workspace_free(w2);
}


/*
 obtainerr2_par.c
 written by Eunseok Lee

 function: solve a linear equation system and obtain the squared error

 v1: Feb 2, 2018
 */

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

double obtainerr2_par(int row_ini, int row_end, double *matA, int n_row, int n_col, int *col_ids, int n_col_ids, double *y) {

    int i, j, k, tmp;
    double err[n_row];
    double sum;

    gsl_matrix * A = gsl_matrix_alloc (n_row-1,n_col_ids);
    gsl_matrix * V = gsl_matrix_alloc (n_col_ids,n_col_ids);
    gsl_vector * S = gsl_vector_alloc (n_col_ids);
    gsl_vector * work = gsl_vector_alloc (n_col_ids);
//    gsl_matrix * U = gsl_matrix_alloc (n_row-1,n_col_ids);
    gsl_vector * b = gsl_vector_alloc (n_row-1);
    gsl_vector * x = gsl_vector_alloc (n_col_ids);

    for (i=0;i<n_row;i++)
        err[i] = 0.0;

    // need to copy y to b!
    for (i=row_ini;i<row_end;i++) {
        for (j=0;j<i;j++) {
            for (k=0; k<n_col_ids; k++) {
                tmp = *(col_ids+k);
                gsl_matrix_set (A, j, k, *(matA+j*n_col+tmp));
            }
            gsl_vector_set (b, j, y[j]);
        }
        for (j=i+1;j<n_row;j++) {
            for (k=0; k<n_col_ids; k++) {
                tmp = *(col_ids+k);
                gsl_matrix_set (A, j-1, k, *(matA+j*n_col+tmp));
            }
            gsl_vector_set (b, j-1, y[j]);
        }

        gsl_linalg_SV_decomp(A, V, S, work);    // on output, A is replaced by U!
        gsl_linalg_SV_solve (A, V, S, b, x);    // So, A should be used instead of U, here.

        sum = 0.0;
        for (k=0;k<n_col_ids;k++) {
            sum += *(matA+i*n_col+col_ids[k]) * gsl_vector_get(x,k);
        }
        err[i] = y[i] - sum;
    }

    sum = 0.0;
    for (i=row_ini;i<row_end;i++)
        sum += err[i]*err[i];

    gsl_matrix_free(A);
    gsl_matrix_free(V);
    gsl_vector_free(S);
    gsl_vector_free(work);
    gsl_vector_free(b);
    gsl_vector_free(x);

    return(sum);
}


#include <stdio.h>
#include <math.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_fft_complex.h>

#define REAL(z,i) ((z)[2*(i)])
#define IMAG(z,i) ((z)[2*(i)+1])

int
main (void)
{
  int i;
  const int n = 630;
  double data[2*n];

  gsl_fft_complex_wavetable * wavetable;
  gsl_fft_complex_workspace * workspace;

  for (i = 0; i < n; i++)
    {
      REAL(data,i) = 0.0;
      IMAG(data,i) = 0.0;
    }

  data[0] = 1.0;

  for (i = 1; i <= 10; i++)
    {
      REAL(data,i) = REAL(data,n-i) = 1.0;
    }

  for (i = 0; i < n; i++)
    {
      printf ("%d: %e %e\n", i, REAL(data,i),
                                IMAG(data,i));
    }
  printf ("\n");

  wavetable = gsl_fft_complex_wavetable_alloc (n);
  workspace = gsl_fft_complex_workspace_alloc (n);

  for (i = 0; i < (int) wavetable->nf; i++)
    {
       printf ("# factor %d: %zu\n", i,
               wavetable->factor[i]);
    }

  gsl_fft_complex_forward (data, 1, n,
                           wavetable, workspace);

  for (i = 0; i < n; i++)
    {
      printf ("%d: %e %e\n", i, REAL(data,i),
                                IMAG(data,i));
    }

  gsl_fft_complex_wavetable_free (wavetable);
  gsl_fft_complex_workspace_free (workspace);
  return 0;
}


//
//  symm.h
//  Linear Algebra Template Library
//
//  Created by Rodney James on 1/2/12.
//  Copyright (c) 2012 University of Colorado Denver. All rights reserved.
//

#ifndef _symm_h
#define _symm_h

/// @file symm.h Performs general symmetric matrix-matrix multiplication.

#include <cctype>
#include "latl.h"

namespace LATL
{
   /// @brief  Performs general real symmetric matrix-matrix multiplication.
   ///
   /// For real matrices B and C, symmetric matrix A, and real scalars alpha and beta,
   ///
   ///         C := alpha*A*B + beta*C  or   C := alpha*B*A + beta*C
   /// is computed.
   /// @return 0 if success.
   /// @return -i if the ith argument is invalid.
   /// @tparam real_t Floating point type.
   /// @param side Specifies whether the matrix A appears on the left or right side as follows:
   ///
   ///        if side = 'L' or 'l' then C := alpha*A*B + beta*C,
   ///        if side = 'R' or 'r' then C := alpha*B*A + beta*C.
   /// @param uplo Specifies whether the upper or lower triangular part of the symmetric matrix A
   /// is to be referenced:
   ///
   ///        if uplo = 'U' or 'u' then A is upper triangular,
   ///        if uplo = 'L' or 'l' then A is lower triangular.
   /// @param m Specifies the number of rows of the matrices B and C.  m>=0
   /// @param n Specifies the number of columns of the matrices B and C.  n>=0
   /// @param alpha Real scalar.
   /// @param A Pointer to real symmetric matrix A.  If side = 'L' or 'l', then A is m-by-m;
   /// if side = 'R' or 'r', then A is n-by-n.
   /// @param ldA Column length of the matrix A.  If side = 'L' or 'l', ldA>=m.  If side = 'R' or 'r', ldA>=n.
   /// @param B Pointer to real m-by-n matrix B.
   /// @param ldB Column length of the matrix B.  ldB>=m.
   /// @param beta Real scalar.
   /// @param C Pointer to real m-by-n matrix C.
   /// @param ldC Column length of the matrix C.  ldC>=m.
   /// @ingroup BLAS

   template <typename real_t>
   int SYMM(char side, char uplo, int_t m, int_t n, real_t alpha, real_t *A, int_t ldA, real_t *B, int_t ldB, real_t beta, real_t *C, int_t ldC)
   {
      using std::toupper;

      const real_t zero(0.0);
      const real_t one(1.0);
      int_t i,j,k;
      real_t *a,*b,*c,*at,*bt;
      real_t s,t;

      side=toupper(side);
      uplo=toupper(uplo);

      if((side!='L')&&(side!='R'))
         return -1;
      else if((uplo!='U')&&(uplo!='L'))
         return -2;
      else if(m<0)
         return -3;
      else if(n<0)
         return -4;
      else if(ldA<((side=='L')?m:n))
         return -7;
      else if(ldB<m)
         return -9;
      else if(ldC<m)
         return -12;
      else if((m==0)||(n==0)||((alpha==zero)&&(beta==one)))
         return 0;

      if(alpha==zero)
      {
         c=C;
         for(j=0;j<n;j++)
         {
            for(i=0;i<m;i++)
               c[i]*=beta;
            c+=ldC;
         }
      }
      else if(side=='L')
      {
         if(uplo=='U')
         {
            b=B;
            c=C;
            for(j=0;j<n;j++)
            {
               a=A;
               for(i=0;i<m;i++)
               {
                  t=alpha*b[i];
                  s=zero;
                  for(k=0;k<i;k++)
                  {
                     c[k]+=t*a[k];
                     s+=b[k]*a[k];
                  }
                  c[i]=beta*c[i]+t*a[i]+alpha*s;
                  a+=ldA;
               }
               b+=ldB;
               c+=ldC;
            }
         }
         else
         {
            b=B;
            c=C;
            for(j=0;j<n;j++)
            {
               a=A+m*ldA;
               for(i=m-1;i>=0;i--)
               {
                  a-=ldA;
                  t=alpha*b[i];
                  s=zero;
                  for(k=i+1;k<m;k++)
                  {
                     c[k]+=t*a[k];
                     s+=b[k]*a[k];
                  }
                  c[i]=beta*c[i]+t*a[i]+alpha*s;
               }
               b+=ldB;
               c+=ldC;
            }
         }
      }
      else
      {
         if(uplo=='U')
         {
            a=A;
            c=C;
            b=B;
            for(j=0;j<n;j++)
            {
               t=alpha*a[j];
               for(i=0;i<m;i++)
                  c[i]=c[i]*beta+t*b[i];
               bt=B;
               for(k=0;k<j;k++)
               {
                  t=alpha*a[k];
                  for(i=0;i<m;i++)
                     c[i]+=bt[i]*t;
                  bt+=ldB;
               }
               at=A+(j+1)*ldA;
               bt=B+(j+1)*ldB;
               for(k=j+1;k<n;k++)
               {
                  t=alpha*at[j];
                  for(i=0;i<m;i++)
                     c[i]+=t*bt[i];
                  at+=ldA;
                  bt+=ldB;
               }
               a+=ldA;
               b+=ldB;
               c+=ldC;
            }
         }
         else
         {
            a=A;
            c=C;
            b=B;
            for(j=0;j<n;j++)
            {
               t=alpha*a[j];
               for(i=0;i<m;i++)
                  c[i]=c[i]*beta+t*b[i];
               bt=B;
               at=A;
               for(k=0;k<j;k++)
               {
                  t=alpha*at[j];
                  for(i=0;i<m;i++)
                     c[i]+=bt[i]*t;
                  at+=ldA;
                  bt+=ldB;
               }
               bt=B+(j+1)*ldB;
               for(k=j+1;k<n;k++)
               {
                  t=alpha*at[k];
                  for(i=0;i<m;i++)
                     c[i]+=t*bt[i];
                  bt+=ldB;
               }
               a+=ldA;
               b+=ldB;
               c+=ldC;
            }
         }
      }
      return 0;
   }

   /// @brief  Performs general complex symmetric matrix-matrix multiplication.
   ///
   /// For complex matrices B and C, symmetric matrix A, and complex scalars alpha and beta,
   ///
   ///         C := alpha*A*B + beta*C  or   C := alpha*B*A + beta*C
   /// is computed.
   /// @return 0 if success.
   /// @return -i if the ith argument is invalid.
   /// @tparam real_t Floating point type.
   /// @param side Specifies whether the matrix A appears on the left or right side as follows:
   ///
   ///        if side = 'L' or 'l' then C := alpha*A*B + beta*C,
   ///        if side = 'R' or 'r' then C := alpha*B*A + beta*C.
   /// @param uplo Specifies whether the upper or lower triangular part of the symmetric matrix A
   /// is to be referenced:
   ///
   ///        if uplo = 'U' or 'u' then A is upper triangular,
   ///        if uplo = 'L' or 'l' then A is lower triangular.
   /// @param m Specifies the number of rows of the matrices B and C.  m>=0
   /// @param n Specifies the number of columns of the matrices B and C.  n>=0
   /// @param alpha Complex scalar.
   /// @param A Pointer to complex symmetric matrix A.  If side = 'L' or 'l', then A is m-by-m;
   /// if side = 'R' or 'r', then A is n-by-n.
   /// @param ldA Column length of the matrix A.  If side = 'L' or 'l', ldA>=m.  If side = 'R' or 'r', ldA>=n.
   /// @param B Pointer to complex m-by-n matrix B.
   /// @param ldB Column length of the matrix B.  ldB>=m.
   /// @param beta Complex scalar.
   /// @param C Pointer to complex m-by-n matrix C.
   /// @param ldC Column length of the matrix C.  ldC>=m.
   /// @ingroup BLAS

   template <typename real_t>
   int SYMM(char side, char uplo, int_t m, int_t n, complex<real_t> alpha, complex<real_t> *A, int_t ldA, complex<real_t> *B, int_t ldB, complex<real_t> beta, complex<real_t> *C, int_t ldC)
   {
      return SYMM< complex<real_t> >(side,uplo,m,n,alpha,A,ldA,B,ldB,beta,C,ldC);
   }

#ifdef __latl_cblas
#include <cblas.h>
   template <> int SYMM<float>(char side, char uplo, int_t m, int_t n, float alpha, float *A, int_t ldA, float *B, int_t ldB, float beta, float *C, int_t ldC)
   {
      using std::toupper;
      side=toupper(side);
      uplo=toupper(uplo);
      if((side!='L')&&(side!='R'))
         return -1;
      else if((uplo!='U')&&(uplo!='L'))
         return -2;
      else if(m<0)
         return -3;
      else if(n<0)
         return -4;
      else if(ldA<((side=='L')?m:n))
         return -7;
      else if(ldB<m)
         return -9;
      else if(ldC<m)
         return -12;

      const CBLAS_SIDE Side=(side=='L')?CblasLeft:CblasRight;
      const CBLAS_UPLO Uplo=(uplo=='U')?CblasUpper:CblasLower;

      cblas_ssymm(CblasColMajor,Side,Uplo,m,n,alpha,A,ldA,B,ldB,beta,C,ldC);

      return 0;

   }

   template <> int SYMM<double>(char side, char uplo, int_t m, int_t n, double alpha, double *A, int_t ldA, double *B, int_t ldB, double beta, double *C, int_t ldC)
   {
      using std::toupper;
      side=toupper(side);
      uplo=toupper(uplo);
      if((side!='L')&&(side!='R'))
         return -1;
      else if((uplo!='U')&&(uplo!='L'))
         return -2;
      else if(m<0)
         return -3;
      else if(n<0)
         return -4;
      else if(ldA<((side=='L')?m:n))
         return -7;
      else if(ldB<m)
         return -9;
      else if(ldC<m)
         return -12;

      const CBLAS_SIDE Side=(side=='L')?CblasLeft:CblasRight;
      const CBLAS_UPLO Uplo=(uplo=='U')?CblasUpper:CblasLower;

      cblas_dsymm(CblasColMajor,Side,Uplo,m,n,alpha,A,ldA,B,ldB,beta,C,ldC);

      return 0;

   }
   template <> int SYMM<float>(char side, char uplo, int_t m, int_t n, complex<float> alpha, complex<float> *A, int_t ldA, complex<float> *B, int_t ldB, complex<float> beta, complex<float> *C, int_t ldC)
   {
      using std::toupper;
      side=toupper(side);
      uplo=toupper(uplo);
      if((side!='L')&&(side!='R'))
         return -1;
      else if((uplo!='U')&&(uplo!='L'))
         return -2;
      else if(m<0)
         return -3;
      else if(n<0)
         return -4;
      else if(ldA<((side=='L')?m:n))
         return -7;
      else if(ldB<m)
         return -9;
      else if(ldC<m)
         return -12;

      const CBLAS_SIDE Side=(side=='L')?CblasLeft:CblasRight;
      const CBLAS_UPLO Uplo=(uplo=='U')?CblasUpper:CblasLower;

      cblas_csymm(CblasColMajor,Side,Uplo,m,n,&alpha,A,ldA,B,ldB,&beta,C,ldC);

      return 0;

   }
   template <> int SYMM<double>(char side, char uplo, int_t m, int_t n, complex<double> alpha, complex<double> *A, int_t ldA, complex<double> *B, int_t ldB, complex<double> beta, complex<double> *C, int_t ldC)
   {
      using std::toupper;
      side=toupper(side);
      uplo=toupper(uplo);
      if((side!='L')&&(side!='R'))
         return -1;
      else if((uplo!='U')&&(uplo!='L'))
         return -2;
      else if(m<0)
         return -3;
      else if(n<0)
         return -4;
      else if(ldA<((side=='L')?m:n))
         return -7;
      else if(ldB<m)
         return -9;
      else if(ldC<m)
         return -12;

      const CBLAS_SIDE Side=(side=='L')?CblasLeft:CblasRight;
      const CBLAS_UPLO Uplo=(uplo=='U')?CblasUpper:CblasLower;

      cblas_zsymm(CblasColMajor,Side,Uplo,m,n,&alpha,A,ldA,B,ldB,&beta,C,ldC);

      return 0;

   }
#endif
}
#endif


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

static double fun(double x)
{
  return x + cos(x*x);
}

int main (void)
{
  const double a = 1.0;
  const double b = 10.0;
  const int steps = 10;
  double xi, yi, x[100], y[100], dx;
  FILE *input, *output;
  int i;

  input = fopen("wartosci.txt", "w");
  output = fopen("gsl_interp_steffen.txt", "w");

  dx = (b-a) / (double) steps;

  for (i = 0; i <= steps; ++i) {
	  x[i] = a + (double)i * dx + 0.5 * sin((double)i * dx);
      y[i] = fun(x[i]);
      fprintf (input,"%g %g\n", x[i], y[i]);
  }

  {
    gsl_interp_accel *acc
      = gsl_interp_accel_alloc ();

    gsl_spline *spline
      = gsl_spline_alloc (gsl_interp_steffen, steps + 1);

    gsl_spline_init (spline, x, y, steps + 1);

    for (xi = a; xi <= b; xi += 0.01) {
        yi = gsl_spline_eval (spline, xi, acc);
        fprintf (output,"%g %g\n", xi, yi);
	}

    gsl_spline_free (spline);
    gsl_interp_accel_free(acc);
  }
  return 0;
}

//Porownanie roznych interpolacji
//Opisanie komend, screeny

//https://stackoverflow.com/questions/10792015/gnuplot-plotting-multiple-line-graphs
//https://stackoverflow.com/questions/40296851/gnuplot-log-plot-y-axis
//http://lowrank.net/gnuplot/plot3d2-e.html
//http://gnuplot-surprising.blogspot.com/2012/05/how-to-pick-out-maximum-and-minimum.html
//http://gnuplot.sourceforge.net/docs_4.2/node237.html
//http://gnuplot.sourceforge.net/demo/stats.html

// stats "dane2.dat" u 3 nooutput
// set label 1 "Maximun" at STATS_pos_max, STATS_max offset 1,-0.5
// set label 2 "Minimun" at STATS_pos_min, STATS_min offset 1,0.5
// splot "dane2.dat" w p pt 3 lc rgb"#ff0000" notitle, \
//      STATS_min w l lc rgb"#00ffff" notitle, \
//      STATS_max w l lc rgb"#00ffff" notitle

stats "dane2.dat" u 1:3 nooutput
a = STATS_pos_max_y
stats "dane2.dat" u 2:3 nooutput
b = STATS_pos_max_y
stats "dane2.dat" u 3 nooutput
c = STATS_max
set arrow 1 from -5, -2.1, c+5 to a,b,c fill
splot "dane2.dat" w p pt 3 lc rgb"#ff0000" notitle, \
     STATS_min w l lc rgb"#00ffff" notitle, \
     STATS_max w l lc rgb"#00ffff" notitle

n=100
max=3.
min=-3.
width=(max-min)/n
hist(x,width)=width*floor(x/width)+width/2.0
set xrange [min:max]
set yrange[-5:5]
set offset graph 0.05,0.05,0.05,0.0
set xtics min,(max-min)/5,max
set boxwidth width*0.82
set tics out nomirror
set xlabel "x"
set ylabel "Frequency"
plot 2*cos(x*sin(x)) smooth freq w boxes lc rgb"blue", \
    sin (x**5) lt rgb"#00ff00", \
    3*sin(x) lt rgb"red", \
    "fun1.txt" with yerrorbars lt rgb"red"


static const char help[] =
"Solves elasto-plastic torsion problem in 2D using SNESVI.  Option prefix -el_.\n"
"Equation is  - grad^2 u = f(x,y)  where  f(x,y) = 2 C.  Zero Dirichlet\n"
"boundary conditions.  Domain Omega = (0,1)x(0,1).  Constraint is upper bound\n"
"   u(x,y) <= dist((x,y), bdry Omega) = psi(x,y).\n"
"At locations where the constraint is active, the material experiences plastic\n"
"failure.  Where inactive, the equation represents the elasticity.  As with\n"
"related codes ../obstacle.c and dam.c the code reuses the residual and\n"
"Jacobian evaluation code from ch6/.\n"
"Reference: R. Kornhuber (1994) 'Monotone multigrid methods for elliptic\n"
"variational inequalities I', Numerische Mathematik, 69(2), 167-184.\n\n";

#include <petsc.h>
#include "../../ch6/poissonfunctions.h"

// z = psi(x,y) = dist((x,y), bdry Omega)  is the upper obstacle
double psi(double x, double y) {
    if (y <= x)
        if (y <= 1.0 - x)
            return y;
        else
            return 1.0 - x;
    else
        if (y <= 1.0 - x)
            return x;
        else
            return 1.0 - y;
}

double zero(double x, double y, double z, void *ctx) {
    return 0.0;
}

static double C = 2.5;
double f_fcn(double x, double y, double z, void *ctx) {
    return 2.0 * C;
}

extern PetscErrorCode FormBounds(SNES, Vec, Vec);

int main(int argc,char **argv) {
  PetscErrorCode ierr;
  DM             da, da_after;
  SNES           snes;
  Vec            u_initial, u;
  PoissonCtx     user;
  SNESConvergedReason reason;
  int            snesits;
  double         lflops,flops;
  DMDALocalInfo  info;

  PetscInitialize(&argc,&argv,NULL,help);

  ierr = PetscOptionsBegin(PETSC_COMM_WORLD,"el_",
                           "elasto-plastic torsion solver options",""); CHKERRQ(ierr);
  ierr = PetscOptionsReal("-C","f(x,y)=2C is source term",
                          "elasto.c",C,&C,NULL); CHKERRQ(ierr);
  ierr = PetscOptionsEnd(); CHKERRQ(ierr);

  ierr = DMDACreate2d(PETSC_COMM_WORLD,
      DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, DMDA_STENCIL_STAR,
      3,3,                       // override with -da_grid_x,_y
      PETSC_DECIDE,PETSC_DECIDE, // num of procs in each dim
      1,1,NULL,NULL,             // dof = 1 and stencil width = 1
      &da);CHKERRQ(ierr);
  ierr = DMSetFromOptions(da); CHKERRQ(ierr);
  ierr = DMSetUp(da); CHKERRQ(ierr);
  ierr = DMDASetUniformCoordinates(da,0.0,1.0,0.0,1.0,-1.0,-1.0);CHKERRQ(ierr);

  user.cx = 1.0;
  user.cy = 1.0;
  user.cz = 1.0;
  user.g_bdry = &zero;
  user.f_rhs = &f_fcn;
  user.addctx = NULL;
  ierr = DMSetApplicationContext(da,&user);CHKERRQ(ierr);

  ierr = SNESCreate(PETSC_COMM_WORLD,&snes);CHKERRQ(ierr);
  ierr = SNESSetDM(snes,da);CHKERRQ(ierr);
  ierr = SNESSetApplicationContext(snes,&user);CHKERRQ(ierr);

  ierr = SNESSetType(snes,SNESVINEWTONRSLS);CHKERRQ(ierr);
  ierr = SNESVISetComputeVariableBounds(snes,&FormBounds);CHKERRQ(ierr);

  // reuse residual and jacobian from ch6/
  ierr = DMDASNESSetFunctionLocal(da,INSERT_VALUES,
             (DMDASNESFunction)Poisson2DFunctionLocal,&user); CHKERRQ(ierr);
  ierr = DMDASNESSetJacobianLocal(da,
             (DMDASNESJacobian)Poisson2DJacobianLocal,&user); CHKERRQ(ierr);
  ierr = SNESSetFromOptions(snes);CHKERRQ(ierr);

  // initial iterate is zero
  ierr = DMCreateGlobalVector(da,&u_initial);CHKERRQ(ierr);
  ierr = VecSet(u_initial,0.0); CHKERRQ(ierr);

  /* solve; then get solution and DM after solution*/
  ierr = SNESSolve(snes,NULL,u_initial);CHKERRQ(ierr);
  ierr = VecDestroy(&u_initial); CHKERRQ(ierr);
  ierr = DMDestroy(&da); CHKERRQ(ierr);
  ierr = SNESGetDM(snes,&da_after); CHKERRQ(ierr);
  ierr = SNESGetSolution(snes,&u); CHKERRQ(ierr); /* do not destroy u */

  /* performance measures */
  ierr = SNESGetConvergedReason(snes,&reason); CHKERRQ(ierr);
  if (reason <= 0) {
      ierr = PetscPrintf(PETSC_COMM_WORLD,
          "WARNING: SNES not converged ... use -snes_converged_reason to check\n"); CHKERRQ(ierr);
  }
  ierr = SNESGetIterationNumber(snes,&snesits); CHKERRQ(ierr);
  ierr = PetscGetFlops(&lflops); CHKERRQ(ierr);
  ierr = MPI_Allreduce(&lflops,&flops,1,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD); CHKERRQ(ierr);
  ierr = DMDAGetLocalInfo(da_after,&info); CHKERRQ(ierr);
  ierr = PetscPrintf(PETSC_COMM_WORLD,
      "done on %4d x %4d grid; total flops = %.3e; SNES iterations %d\n",
      info.mx,info.my,flops,snesits); CHKERRQ(ierr);

  SNESDestroy(&snes);
  return PetscFinalize();
}

// for call-back: tell SNESVI we want  -infty < u <= psi
PetscErrorCode FormBounds(SNES snes, Vec Xl, Vec Xu) {
  PetscErrorCode ierr;
  DM            da;
  DMDALocalInfo info;
  int           i, j;
  double        **aXu, dx, dy, x, y;
  ierr = VecSet(Xu,PETSC_NINFINITY);CHKERRQ(ierr);
  ierr = SNESGetDM(snes,&da);CHKERRQ(ierr);
  ierr = DMDAGetLocalInfo(da,&info); CHKERRQ(ierr);
  dx = 1.0 / (PetscReal)(info.mx-1);
  dy = 1.0 / (PetscReal)(info.my-1);
  ierr = DMDAVecGetArray(da, Xu, &aXu);CHKERRQ(ierr);
  for (j=info.ys; j<info.ys+info.ym; j++) {
    y = j * dy;
    for (i=info.xs; i<info.xs+info.xm; i++) {
      x = i * dx;
      aXu[j][i] = psi(x,y);
    }
  }
  ierr = DMDAVecRestoreArray(da, Xu, &aXu);CHKERRQ(ierr);
  return 0;
}


//
//  syr2k.h
//  Linear Algebra Template Library
//
//  Created by Rodney James on 1/4/12.
//  Copyright (c) 2012 University of Colorado Denver. All rights reserved.
//

#ifndef _syr2k_h
#define _syr2k_h

/// @file syr2k.h Performs multiplication of two matrices resulting in a symmetric matrix.

#include <cctype>
#include "latl.h"

namespace LATL
{
   /// @brief Performs multiplcation of real matrices resulting in a symmetric matrix.
   ///
   /// For real matrices A and B, real symmetric matrix C, and real scalars alpha and beta
   ///
   ///        C := alpha*A*B'+alpha*B*A'+beta*C
   /// or
   ///
   ///        C := alpha*A'*B+alpha*B'*A+beta*C
   /// is computed.
   /// @return 0 if success.
   /// @return -i if the ith argument is invalid.
   /// @tparam real_t Floating point type.
   /// @param uplo Specifies whether the upper or lower triangular part of the symmetric matrix C
   /// is to be referenced:
   ///
   ///        if uplo = 'U' or 'u' then C is upper triangular,
   ///        if uplo = 'L' or 'l' then C is lower triangular.
   /// @param trans Specifies the operation to be perfomed as follows:
   ///
   ///        if trans = 'N' or 'n' then C := alpha*A*B'+alpha*B*A'+beta*C
   ///        if trans = 'T' or 't' then C := alpha*A'*B+alpha*B'*A+beta*C
   ///        if trans = 'C' or 'c' then C := alpha*A'*B+alpha*B'*A+beta*C
   /// @param n Specifies the order of the complex Hermitian matrix C.  n>=0
   /// @param k Specifies the other dimension of the complex matrices A and B.
   ///
   ///        if trans = 'N' or 'n' then A and B are n-by-k
   ///        if trans = 'T' or 't' then A and B are k-by-n
   ///        if trans = 'C' or 'c' then A and B are k-by-n
   /// @param alpha Real scalar.
   /// @param A Pointer to real matrix.
   /// @param ldA Column length of the matrix A. If trans = 'N' or 'n' ldA>=n, otherwise ldA>=k.
   /// @param B Pointer to real matrix.
   /// @param ldB Column length of the matrix B. If trans = 'N' or 'n' ldB>=n, otherwise ldB>=k.
   /// @param beta Real scalar.
   /// @param C Pointer to real symmetric n-by-n matrix C.
   /// Only the upper or lower triangular part of C is referenced, depending on the value of uplo above.
   /// @param ldC Column length of the matrix C.  ldC>=n
   /// @ingroup BLAS

   template <typename real_t>
   int SYR2K(char uplo, char trans, int_t n, int_t k, real_t alpha, real_t *A, int_t ldA, real_t *B, int_t ldB, real_t beta, real_t *C, int_t ldC)
   {
      using std::toupper;

      const real_t zero(0.0);
      const real_t one(1.0);
      int_t i,j,l;
      real_t *a,*b,*c,*at,*bt;
      real_t s,t;

      uplo=toupper(uplo);
      trans=toupper(trans);

      if((uplo!='U')&&(uplo!='L'))
         return -1;
      else if((trans!='N')&&(trans!='T')&&(trans!='C'))
         return -2;
      else if(n<0)
         return -3;
      else if(k<0)
         return -4;
      else if(ldA<((trans=='N')?n:k))
         return -7;
      else if(ldB<((trans=='N')?n:k))
         return -9;
      else if(ldC<n)
         return -12;
      else if((n==0)||(((alpha==zero)||(k==0))&&(beta==one)))
         return 0;

      if(alpha==zero)
      {
         if(uplo=='U')
         {
            c=C;
            for(j=0;j<n;j++)
            {
               for(i=0;i<=j;i++)
                  c[i]*=beta;
               c+=ldC;
            }

         }
         else
         {
            c=C;
            for(j=0;j<n;j++)
            {
               for(i=j;i<n;i++)
                  c[i]*=beta;
               c+=ldC;
            }
         }
      }
      else if(trans=='N')
      {
         if(uplo=='U')
         {
            c=C;
            for(j=0;j<n;j++)
            {
               for(i=0;i<=j;i++)
                  c[i]*=beta;
               a=A;
               b=B;
               for(l=0;l<k;l++)
               {
                  s=alpha*b[j];
                  t=alpha*a[j];
                  for(i=0;i<=j;i++)
                     c[i]+=s*a[i]+t*b[i];
                  a+=ldA;
                  b+=ldB;
               }
               c+=ldC;
            }
         }
         else
         {
            c=C;
            for(j=0;j<n;j++)
            {
               for(i=j;i<n;i++)
                  c[i]*=beta;
               a=A;
               b=B;
               for(l=0;l<k;l++)
               {
                  s=alpha*b[j];
                  t=alpha*a[j];
                  for(i=j;i<n;i++)
                     c[i]+=s*a[i]+t*b[i];
                  a+=ldA;
                  b+=ldB;
               }
               c+=ldC;
            }
         }
      }
      else
      {
         if(uplo=='U')
         {
            c=C;
            at=A;
            bt=B;
            for(j=0;j<n;j++)
            {
               a=A;
               b=B;
               for(i=0;i<=j;i++)
               {
                  s=zero;
                  t=zero;
                  for(l=0;l<k;l++)
                  {
                     s+=b[l]*at[l];
                     t+=a[l]*bt[l];
                  }
                  c[i]=alpha*t+alpha*s+beta*c[i];
                  a+=ldA;
                  b+=ldB;
               }
               at+=ldA;
               bt+=ldB;
               c+=ldC;
            }
         }
         else
         {
            c=C;
            at=A;
            bt=B;
            for(j=0;j<n;j++)
            {
               a=A+j*ldA;
               b=B+j*ldB;
               for(i=j;i<n;i++)
               {
                  s=zero;
                  t=zero;
                  for(l=0;l<k;l++)
                  {
                     s+=b[l]*at[l];
                     t+=a[l]*bt[l];
                  }
                  c[i]=alpha*t+alpha*s+beta*c[i];
                  a+=ldA;
                  b+=ldB;
               }
               at+=ldA;
               bt+=ldB;
               c+=ldC;
            }
         }
      }
      return 0;
   }

   /// @brief Performs multiplcation of complex matrices resulting in a symmetric matrix.
   ///
   /// For complex matrices A and B, complex Hermitian matrix C, and complex scalars alpha and beta
   ///
   ///        C := alpha*A*B.'+alpha*B*A.'+beta*C
   /// or
   ///
   ///        C := alpha*A.'*B+alpha*B.'*A+beta*C
   /// is computed.
   /// @return 0 if success.
   /// @return -i if the ith argument is invalid.
   /// @tparam real_t Floating point type.
   /// @param uplo Specifies whether the upper or lower triangular part of the symmetric matrix C
   /// is to be referenced:
   ///
   ///        if uplo = 'U' or 'u' then C is upper triangular,
   ///        if uplo = 'L' or 'l' then C is lower triangular.
   /// @param trans Specifies the operation to be perfomed as follows:
   ///
   ///        if trans = 'N' or 'n' then C := alpha*A*B.'+alpha*B*A.'+beta*C
   ///        if trans = 'T' or 'T' then C := alpha*A.'*B+alpha*B.'*A+beta*C
   /// @param n Specifies the order of the complex symmetric matrix C.  n>=0
   /// @param k Specifies the other dimension of the complex matrices A and B.
   ///
   ///        if trans = 'N' or 'n' then A and B are n-by-k
   ///        if trans = 'T' or 't' then A and B are k-by-n
   /// @param alpha Complex scalar.
   /// @param A Pointer to complex matrix.
   /// @param ldA Column length of the matrix A. If trans = 'N' or 'n' ldA>=n, otherwise ldA>=k.
   /// @param B Pointer to complex matrix.
   /// @param ldB Column length of the matrix B. If trans = 'N' or 'n' ldB>=n, otherwise ldB>=k.
   /// @param beta Complex scalar.
   /// @param C Pointer to complex symmetric n-by-n matrix C.
   /// Only the upper or lower triangular part of C is referenced, depending on the value of uplo above.
   /// @param ldC Column length of the matrix C.  ldC>=n
   /// @ingroup BLAS

   template <typename real_t>
   int SYR2K(char uplo, char trans, int_t n, int_t k, complex<real_t> alpha, complex<real_t> *A, int_t ldA, complex<real_t> *B, int_t ldB, complex<real_t> beta, complex<real_t> *C, int_t ldC)
   {
      using std::toupper;

      const complex<real_t> zero(0.0,0.0);
      const complex<real_t> one(1.0,0.0);
      int_t i,j,l;
      complex<real_t> *a,*b,*c,*at,*bt;
      complex<real_t> s,t;

      uplo=toupper(uplo);
      trans=toupper(trans);

      if((uplo!='U')&&(uplo!='L'))
         return -1;
      else if((trans!='N')&&(trans!='T'))
         return -2;
      else if(n<0)
         return -3;
      else if(k<0)
         return -4;
      else if(ldA<((trans=='N')?n:k))
         return -7;
      else if(ldB<((trans=='N')?n:k))
         return -9;
      else if(ldC<n)
         return -12;
      else if((n==0)||(((alpha==zero)||(k==0))&&(beta==one)))
         return 0;

      if(alpha==zero)
      {
         if(uplo=='U')
         {
            c=C;
            for(j=0;j<n;j++)
            {
               for(i=0;i<=j;i++)
                  c[i]*=beta;
               c+=ldC;
            }

         }
         else
         {
            c=C;
            for(j=0;j<n;j++)
            {
               for(i=j;i<n;i++)
                  c[i]*=beta;
               c+=ldC;
            }
         }
      }
      else if(trans=='N')
      {
         if(uplo=='U')
         {
            c=C;
            for(j=0;j<n;j++)
            {
               for(i=0;i<=j;i++)
                  c[i]*=beta;
               a=A;
               b=B;
               for(l=0;l<k;l++)
               {
                  s=alpha*b[j];
                  t=alpha*a[j];
                  for(i=0;i<=j;i++)
                     c[i]+=s*a[i]+t*b[i];
                  a+=ldA;
                  b+=ldB;
               }
               c+=ldC;
            }
         }
         else
         {
            c=C;
            for(j=0;j<n;j++)
            {
               for(i=j;i<n;i++)
                  c[i]*=beta;
               a=A;
               b=B;
               for(l=0;l<k;l++)
               {
                  s=alpha*b[j];
                  t=alpha*a[j];
                  for(i=j;i<n;i++)
                     c[i]+=s*a[i]+t*b[i];
                  a+=ldA;
                  b+=ldB;
               }
               c+=ldC;
            }
         }
      }
      else
      {
         if(uplo=='U')
         {
            c=C;
            at=A;
            bt=B;
            for(j=0;j<n;j++)
            {
               a=A;
               b=B;
               for(i=0;i<=j;i++)
               {
                  s=zero;
                  t=zero;
                  for(l=0;l<k;l++)
                  {
                     s+=b[l]*at[l];
                     t+=a[l]*bt[l];
                  }
                  c[i]=alpha*t+alpha*s+beta*c[i];
                  a+=ldA;
                  b+=ldB;
               }
               at+=ldA;
               bt+=ldB;
               c+=ldC;
            }
         }
         else
         {
            c=C;
            at=A;
            bt=B;
            for(j=0;j<n;j++)
            {
               a=A+j*ldA;
               b=B+j*ldB;
               for(i=j;i<n;i++)
               {
                  s=zero;
                  t=zero;
                  for(l=0;l<k;l++)
                  {
                     s+=b[l]*at[l];
                     t+=a[l]*bt[l];
                  }
                  c[i]=alpha*t+alpha*s+beta*c[i];
                  a+=ldA;
                  b+=ldB;
               }
               at+=ldA;
               bt+=ldB;
               c+=ldC;
            }
         }
      }
      return 0;
   }

#ifdef __latl_cblas
#include <cblas.h>

   template <> int SYR2K<float>(char uplo, char trans, int_t n, int_t k, float alpha, float *A, int_t ldA, float *B, int_t ldB, float beta, float *C, int_t ldC)
   {
      using std::toupper;
      uplo=toupper(uplo);
      trans=toupper(trans);
      if((uplo!='U')&&(uplo!='L'))
         return -1;
      else if((trans!='N')&&(trans!='T')&&(trans!='C'))
         return -2;
      else if(n<0)
         return -3;
      else if(k<0)
         return -4;
      else if(ldA<((trans=='N')?n:k))
         return -7;
      else if(ldB<((trans=='N')?n:k))
         return -9;
      else if(ldC<n)
         return -12;

      const CBLAS_UPLO Uplo=(uplo=='U')?CblasUpper:CblasLower;
      const CBLAS_TRANSPOSE Trans=(trans=='N')?CblasNoTrans:((trans=='T')?CblasTrans:CblasConjTrans);

      cblas_ssyr2k(CblasColMajor,Uplo,Trans,n,k,alpha,A,ldA,B,ldB,beta,C,ldC);

      return 0;
   }

   template <> int SYR2K<double>(char uplo, char trans, int_t n, int_t k, double alpha, double *A, int_t ldA, double *B, int_t ldB, double beta, double *C, int_t ldC)
   {
      using std::toupper;
      uplo=toupper(uplo);
      trans=toupper(trans);
      if((uplo!='U')&&(uplo!='L'))
         return -1;
      else if((trans!='N')&&(trans!='T')&&(trans!='C'))
         return -2;
      else if(n<0)
         return -3;
      else if(k<0)
         return -4;
      else if(ldA<((trans=='N')?n:k))
         return -7;
      else if(ldB<((trans=='N')?n:k))
         return -9;
      else if(ldC<n)
         return -12;

      const CBLAS_UPLO Uplo=(uplo=='U')?CblasUpper:CblasLower;
      const CBLAS_TRANSPOSE Trans=(trans=='N')?CblasNoTrans:((trans=='T')?CblasTrans:CblasConjTrans);

      cblas_dsyr2k(CblasColMajor,Uplo,Trans,n,k,alpha,A,ldA,B,ldB,beta,C,ldC);

      return 0;
   }

   template <> int SYR2K<float>(char uplo, char trans, int_t n, int_t k, complex<float> alpha, complex<float> *A, int_t ldA, complex<float> *B, int_t ldB, complex<float> beta, complex<float> *C, int_t ldC)
   {
      using std::toupper;
      uplo=toupper(uplo);
      trans=toupper(trans);
      if((uplo!='U')&&(uplo!='L'))
         return -1;
      else if((trans!='N')&&(trans!='T'))
         return -2;
      else if(n<0)
         return -3;
      else if(k<0)
         return -4;
      else if(ldA<((trans=='N')?n:k))
         return -7;
      else if(ldB<((trans=='N')?n:k))
         return -9;
      else if(ldC<n)
         return -12;

      const CBLAS_UPLO Uplo=(uplo=='U')?CblasUpper:CblasLower;
      const CBLAS_TRANSPOSE Trans=(trans=='N')?CblasNoTrans:((trans=='T')?CblasTrans:CblasConjTrans);

      cblas_csyr2k(CblasColMajor,Uplo,Trans,n,k,&alpha,A,ldA,B,ldB,&beta,C,ldC);

      return 0;
   }

   template <> int SYR2K<double>(char uplo, char trans, int_t n, int_t k, complex<double> alpha, complex<double> *A, int_t ldA, complex<double> *B, int_t ldB, complex<double> beta, complex<double> *C, int_t ldC)
   {
      using std::toupper;
      uplo=toupper(uplo);
      trans=toupper(trans);
      if((uplo!='U')&&(uplo!='L'))
         return -1;
      else if((trans!='N')&&(trans!='T'))
         return -2;
      else if(n<0)
         return -3;
      else if(k<0)
         return -4;
      else if(ldA<((trans=='N')?n:k))
         return -7;
      else if(ldB<((trans=='N')?n:k))
         return -9;
      else if(ldC<n)
         return -12;

      const CBLAS_UPLO Uplo=(uplo=='U')?CblasUpper:CblasLower;
      const CBLAS_TRANSPOSE Trans=(trans=='N')?CblasNoTrans:((trans=='T')?CblasTrans:CblasConjTrans);

      cblas_zsyr2k(CblasColMajor,Uplo,Trans,n,k,&alpha,A,ldA,B,ldB,&beta,C,ldC);

      return 0;
   }

#endif
}

#endif


/*
    This code is written by <albanese@fbk.it>.
    (C) 2008 mlpy Developers.

    See DWT in the GSL Library.

    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, see <http://www.gnu.org/licenses/>.
*/

#include <Python.h>
#include <numpy/arrayobject.h>
#include <stdlib.h>
#include <stdio.h>
#include <math.h>
#include <string.h>
#include <gsl/gsl_wavelet.h>
#include <gsl/gsl_math.h>

static PyObject *dwt_dwt(PyObject *self, PyObject *args, PyObject *keywds)
{
  PyObject *x = NULL; PyObject *xcopy = NULL;

  char wf;
  int k, n;
  double *_xcopy;
  PyObject *centered = Py_False;
  gsl_wavelet *w;
  gsl_wavelet_workspace *work;

  /* Parse Tuple*/
  static char *kwlist[] = {"x", "wf", "k", "centered", NULL};
  if (!PyArg_ParseTupleAndKeywords(args, keywds, "Oci|O", kwlist,
				   &x, &wf, &k, &centered))
    return NULL;

  /* Build xcopy */
  xcopy = PyArray_FROM_OTF(x, NPY_DOUBLE, NPY_OUT_ARRAY | NPY_ENSURECOPY);
  if (xcopy == NULL) return NULL;

  n = (int) PyArray_DIM(xcopy, 0);
  _xcopy = (double *) PyArray_DATA(xcopy);

  switch (wf)
    {
    case 'd':
      if (centered == Py_True)
	w = gsl_wavelet_alloc (gsl_wavelet_daubechies_centered, k);
      else
	w = gsl_wavelet_alloc (gsl_wavelet_daubechies, k);
      break;

    case 'h':
      if (centered == Py_True)
	w = gsl_wavelet_alloc (gsl_wavelet_haar_centered, k);
      else
	w = gsl_wavelet_alloc (gsl_wavelet_haar, k);
      break;

    case 'b':
      if (centered == Py_True)
	w = gsl_wavelet_alloc (gsl_wavelet_bspline_centered, k);
      else
	w = gsl_wavelet_alloc (gsl_wavelet_bspline, k);
      break;

    default:
      PyErr_SetString(PyExc_ValueError, "wavelet family is not valid");
      return NULL;
    }

  work = gsl_wavelet_workspace_alloc (n);

  gsl_wavelet_transform_forward (w, _xcopy, 1, n, work);

  gsl_wavelet_free (w);
  gsl_wavelet_workspace_free (work);

  return Py_BuildValue("N", xcopy);
}

static PyObject *dwt_idwt(PyObject *self, PyObject *args, PyObject *keywds)
{
  PyObject *x = NULL; PyObject *xcopy = NULL;

  char wf;
  int k, n;
  double *_xcopy;
  PyObject *centered = Py_False;
  gsl_wavelet *w;
  gsl_wavelet_workspace *work;

  /* Parse Tuple*/
  static char *kwlist[] = {"X", "wf", "k", "centered", NULL};
  if (!PyArg_ParseTupleAndKeywords(args, keywds, "Oci|O", kwlist,
				   &x, &wf, &k, &centered))
    return NULL;

  /* Build xcopy */
  xcopy = PyArray_FROM_OTF(x, NPY_DOUBLE, NPY_OUT_ARRAY | NPY_ENSURECOPY);
  if (xcopy == NULL) return NULL;

  n = (int) PyArray_DIM(xcopy, 0);
  _xcopy = (double *) PyArray_DATA(xcopy);

  switch (wf)
    {
    case 'd':
      if (centered == Py_True)
	w = gsl_wavelet_alloc (gsl_wavelet_daubechies_centered, k);
      else
	w = gsl_wavelet_alloc (gsl_wavelet_daubechies, k);
      break;

    case 'h':
      if (centered == Py_True)
	w = gsl_wavelet_alloc (gsl_wavelet_haar_centered, k);
      else
	w = gsl_wavelet_alloc (gsl_wavelet_haar, k);
      break;

    case 'b':
      if (centered == Py_True)
	w = gsl_wavelet_alloc (gsl_wavelet_bspline_centered, k);
      else
	w = gsl_wavelet_alloc (gsl_wavelet_bspline, k);
      break;

    default:
      PyErr_SetString(PyExc_ValueError, "wavelet family is not valid");
      return NULL;
    }

  work = gsl_wavelet_workspace_alloc (n);

  gsl_wavelet_transform_inverse (w, _xcopy, 1, n, work);

  gsl_wavelet_free (w);
  gsl_wavelet_workspace_free (work);

  return Py_BuildValue("N", xcopy);
}

/* Doc strings: */
static char module_doc[]  = "Discrete Wavelet Transform Module from GSL";

static char dwt_dwt_doc[] =
  "Discrete Wavelet Tranform\n\n"
  ":Parameters:\n"
  "   x : 1d array_like object (the length is restricted to powers of two)\n"
  "      data\n"
  "   wf : string ('d': daubechies, 'h': haar, 'b': bspline)\n"
  "      wavelet family\n"
  "   k : integer\n"
  "      member of the wavelet family\n\n"
  "         * daubechies : k = 4, 6, ..., 20 with k even\n"
  "         * haar : the only valid choice of k is k = 2\n"
  "         * bspline : k = 103, 105, 202, 204, 206, 208, 301, 303, 305 307, 309\n"
  "   centered : bool\n"
  "      align the coefficients of the various sub-bands on edges.\n"
  "      Thus the resulting visualization of the coefficients of the\n"
  "      wavelet transform in the phase plane is easier to understand.\n\n"
  ":Returns:\n"
  "  X : 1d numpy array\n"
  "    discrete wavelet transformed data\n\n"
  "Example\n\n"
  ">>> import numpy as np\n"
  ">>> import mlpy.wavelet as wave\n"
  ">>> x = np.array([1,2,3,4,3,2,1,0])\n"
  ">>> wave.dwt(x=x, wf='d', k=6)\n"
  "array([ 5.65685425,  3.41458985,  0.29185347, -0.29185347, -0.28310081,\n"
  "       -0.07045258,  0.28310081,  0.07045258])\n";

static char dwt_idwt_doc[] =
  "Inverse Discrete Wavelet Tranform\n\n"
  ":Parameters:\n"
  "   X : 1d array_like object\n"
  "      discrete wavelet transformed data\n"
  "   wf : string ('d': daubechies, 'h': haar, 'b': bspline)\n"
  "      wavelet type\n"
  "   k : integer\n"
  "      member of the wavelet family\n\n"
  "         * daubechies : k = 4, 6, ..., 20 with k even\n"
  "         * haar : the only valid choice of k is k = 2\n"
  "         * bspline : k = 103, 105, 202, 204, 206, 208, 301, 303, 305 307, 309\n\n"
  "   centered : bool\n"
  "      if the coefficients are aligned\n\n"
  ":Returns:\n"
  "   x : 1d numpy array\n"
  "      data\n\n"
  "Example:\n\n"
  ">>> import numpy as np\n"
  ">>> import mlpy.wavelet as wave\n"
  ">>> X = np.array([ 5.65685425,  3.41458985,  0.29185347, -0.29185347, -0.28310081,\n"
  "...               -0.07045258,  0.28310081,  0.07045258])\n"
  ">>> wave.idwt(X=X, wf='d', k=6)\n"
  "array([  1.00000000e+00,   2.00000000e+00,   3.00000000e+00,\n"
  "         4.00000000e+00,   3.00000000e+00,   2.00000000e+00,\n"
  "         1.00000000e+00,  -3.53954610e-09])\n";

/* Method table */
static PyMethodDef dwt_methods[] = {
  {"dwt",
   (PyCFunction)dwt_dwt,
   METH_VARARGS | METH_KEYWORDS,
   dwt_dwt_doc},
  {"idwt",
   (PyCFunction)dwt_idwt,
   METH_VARARGS | METH_KEYWORDS,
   dwt_idwt_doc},
  {NULL, NULL, 0, NULL}
};

#if PY_MAJOR_VERSION >= 3

static struct PyModuleDef moduledef = {
  PyModuleDef_HEAD_INIT,
  "_dwt",
  module_doc,
  -1,
  dwt_methods,
  NULL, NULL, NULL, NULL
};

PyObject *PyInit__dwt(void)
{
  PyObject *m;
  m = PyModule_Create(&moduledef);
  if (!m) {
    return NULL;
  }

  import_array();

  return m;
}

#else

PyMODINIT_FUNC init_dwt(void)
{
  PyObject *m;

  m = Py_InitModule3("_dwt", dwt_methods, module_doc);
  if (m == NULL) {
    return;
  }

  import_array();
}

#endif