/* cdf/binomial.c
 *
 * Copyright (C) 2004 Jason H. Stover.
 * Copyright (C) 2004 Giulio Bottazzi
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 3 of the License, or (at
 * your option) any later version.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 */

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

#include "error.h"

/* Computes the cumulative distribution function for a binomial
   random variable. For a binomial random variable X with n trials
   and success probability p,

           Pr( X <= k ) = Pr( Y >= p )

   where Y is a beta random variable with parameters k+1 and n-k.

   The binomial distribution has the form,

   prob(k) =  n!/(k!(n-k)!) *  p^k (1-p)^(n-k) for k = 0, 1, ..., n

   The cumulated distributions can be expressed in terms of normalized
   incomplete beta functions (see Abramowitz & Stegun eq. 26.5.26 and
   eq. 6.6.3).

   Reference:

   W. Feller, "An Introduction to Probability and Its
   Applications," volume 1. Wiley, 1968. Exercise 45, page 173,
   chapter 6.
 */

#include <config.h>
#include <math.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_cdf.h>

double
gsl_cdf_binomial_P (const unsigned int k, const double p, const unsigned int n)
{
  double P;
  double a;
  double b;

  if (p > 1.0 || p < 0.0)
    {
      CDF_ERROR ("p < 0 or p > 1", GSL_EDOM);
    }

  if (k >= n)
    {
      P = 1.0;
    }
  else
    {
      a = (double) k + 1.0;
      b = (double) n - k;
      P = gsl_cdf_beta_Q (p, a, b);
    }

  return P;
}

double
gsl_cdf_binomial_Q (const unsigned int k, const double p, const unsigned int n)
{
  double Q;
  double a;
  double b;

  if (p > 1.0 || p < 0.0)
    {
      CDF_ERROR ("p < 0 or p > 1", GSL_EDOM);
    }

  if (k >= n)
    {
      Q = 0.0;
    }
  else
    {
      a = (double) k + 1.0;
      b = (double) n - k;
      Q = gsl_cdf_beta_P (p, a, b);
    }

  return Q;
}


// --------------------------------------------------------
// 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;
}


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

#include <cblas.h>

#include "cnn.h"
#include "cnn_builtin_math.h"
#include "cnn_builtin_math_inline.h"
#include "cnn_config.h"
#include "cnn_init.h"
#include "cnn_macro.h"

#ifdef CNN_WITH_CUDA
#include <cuda_runtime.h>
#include "cnn_builtin_math_cu.h"
#endif

CNN_ACTIV_DEF((*cnn_activ_list[])) = {
    cnn_softmax,        //
    cnn_relu,           //
    cnn_swish,          //
    cnn_sigmoid,        //
    cnn_tanh,           //
    cnn_gaussian,       //
    cnn_bent_identity,  //
    cnn_softplus,       //
    cnn_softsign,       //
    cnn_sinc,           //
    cnn_sinusoid,       //
    cnn_identity        //
};

CNN_ACTIV_GRAD_DEF((*cnn_activ_grad_list[])) = {
    cnn_softmax_grad,        //
    cnn_relu_grad,           //
    cnn_swish_grad,          //
    cnn_sigmoid_grad,        //
    cnn_tanh_grad,           //
    cnn_gaussian_grad,       //
    cnn_bent_identity_grad,  //
    cnn_softplus_grad,       //
    cnn_softsign_grad,       //
    cnn_sinc_grad,           //
    cnn_sinusoid_grad,       //
    cnn_identity_grad        //
};

const char* cnn_activ_name[] = {
    "Softmax",             //
    "ReLU",                //
    "Swish",               //
    "Sigmoid",             //
    "Hyperbolic Tangent",  //
    "Gaussian",            //
    "Bent Identity",       //
    "SoftPlus",            //
    "SoftSign",            //
    "Sinc",                //
    "Sinusoid",            //
    "Identity"             //
};

CNN_ACTIV_DEF(cnn_softmax)
{
    float max, sum;

#ifdef CNN_WITH_CUDA
    // Find max value
    cnn_max_gpu(&max, src, len, buf);

    // Find shifted vector
    cnn_add_gpu(buf, src, len, -max);

    // Find exponential vector
    cnn_exp_gpu(buf, buf, len);

    // Find sum
    cnn_sum_gpu(&sum, buf, len, dst);

    // Find softmax
    cnn_div_gpu(dst, buf, len, sum);
#else
    int i;

    // Find max value
    max = src[0];
    for (i = 1; i < len; i++)
    {
        if (src[i] > max)
        {
            max = src[i];
        }
    }

    // Find exponential summation
    sum = 0;
    for (i = 0; i < len; i++)
    {
        dst[i] = src[i] - max;
        sum += exp(dst[i]);
    }

    // Find softmax output
    for (i = 0; i < len; i++)
    {
        dst[i] = exp(dst[i]) / sum;
    }
#endif
}

CNN_ACTIV_GRAD_DEF(cnn_softmax_grad)
{
#ifdef CNN_WITH_CUDA
    float alpha = 1.0;
    float beta = 0.0;

    // Find derivative matrix
    cnn_smax_grad_gpu(buf, cache, len);

    // Find layer gradient
    cnn_assert_cu(cublasSgemm(cnnInit.blasHandle, CUBLAS_OP_N, CUBLAS_OP_N,  //
                              len, 1, len,                                   //
                              &alpha,                                        //
                              buf, len,                                      //
                              gradIn, len,                                   //
                              &beta,                                         //
                              gradOut, len));

#else
    int i, j;

    // Find softmax gradient matrix
    for (i = 0; i < len; i++)
    {
        for (j = 0; j < len; j++)
        {
            buf[i * len + j] = cache[i] * ((float)(i == j) - cache[j]);
        }
    }

    // Find layer gradient
    cblas_sgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans,  //
                1, len, len,                                //
                1.0,                                        //
                gradIn, len,                                //
                buf, len,                                   //
                0.0,                                        //
                gradOut, len);
#endif
}

CNN_ACTIV_DEF(cnn_relu)
{
#ifdef CNN_WITH_CUDA
    cnn_relu_gpu(dst, src, len);
#else
#pragma omp parallel for
    for (int i = 0; i < len; i++)
    {
        __cnn_relu(dst + i, src + i);
    }
#endif
}

CNN_ACTIV_GRAD_DEF(cnn_relu_grad)
{
#ifdef CNN_WITH_CUDA
    cnn_relu_grad_gpu(gradOut, gradIn, src, len, cache);
#else
    // Find relu gradient
#pragma omp parallel for
    for (int i = 0; i < len; i++)
    {
        __cnn_relu_grad(gradOut + i, gradIn + i, src + i, NULL);
    }
#endif
}

CNN_ACTIV_DEF(cnn_swish)
{
#ifdef CNN_WITH_CUDA
    cnn_swish_gpu(dst, src, len);
#else
#pragma omp parallel for
    for (int i = 0; i < len; i++)
    {
        __cnn_swish(dst + i, src + i);
    }
#endif
}

CNN_ACTIV_GRAD_DEF(cnn_swish_grad)
{
#ifdef CNN_WITH_CUDA
    cnn_swish_grad_gpu(gradOut, gradIn, src, len, cache);
#else
    // Find swish gradient
#pragma omp parallel for
    for (int i = 0; i < len; i++)
    {
        __cnn_swish_grad(gradOut + i, gradIn + i, src + i, cache + i);
    }
#endif
}

CNN_ACTIV_DEF(cnn_sigmoid)
{
#ifdef CNN_WITH_CUDA
    cnn_sigmoid_gpu(dst, src, len);
#else
#pragma omp parallel for
    for (int i = 0; i < len; i++)
    {
        __cnn_sigmoid(dst + i, src + i);
    }
#endif
}

CNN_ACTIV_GRAD_DEF(cnn_sigmoid_grad)
{
#ifdef CNN_WITH_CUDA
    cnn_sigmoid_grad_gpu(gradOut, gradIn, src, len, cache);
#else
    // Find sigmoid gradient
#pragma omp parallel for
    for (int i = 0; i < len; i++)
    {
        __cnn_sigmoid_grad(gradOut + i, gradIn + i, NULL, cache + i);
    }
#endif
}

CNN_ACTIV_DEF(cnn_tanh)
{
#ifdef CNN_WITH_CUDA
    cnn_tanh_gpu(dst, src, len);
#else
#pragma omp parallel
    for (int i = 0; i < len; i++)
    {
        __cnn_tanh(dst + i, src + i);
    }
#endif
}

CNN_ACTIV_GRAD_DEF(cnn_tanh_grad)
{
#ifdef CNN_WITH_CUDA
    cnn_tanh_grad_gpu(gradOut, gradIn, src, len, cache);
#else
    // Find tanh gradient
#pragma omp parallel for
    for (int i = 0; i < len; i++)
    {
        __cnn_tanh_grad(gradOut + i, gradIn + i, NULL, cache + i);
    }
#endif
}

CNN_ACTIV_DEF(cnn_gaussian)
{
#ifdef CNN_WITH_CUDA
    cnn_gaussian_gpu(dst, src, len);
#else
#pragma omp parallel
    for (int i = 0; i < len; i++)
    {
        __cnn_gaussian(dst + i, src + i);
    }
#endif
}

CNN_ACTIV_GRAD_DEF(cnn_gaussian_grad)
{
#ifdef CNN_WITH_CUDA
    cnn_gaussian_grad_gpu(gradOut, gradIn, src, len, cache);
#else
    // Find gaussian gradient
#pragma omp parallel for
    for (int i = 0; i < len; i++)
    {
        __cnn_gaussian_grad(gradOut + i, gradIn + i, src + i, cache + i);
    }
#endif
}

CNN_ACTIV_DEF(cnn_bent_identity)
{
#ifdef CNN_WITH_CUDA
    cnn_bent_identity_gpu(dst, src, len);
#else
#pragma omp parallel for
    for (int i = 0; i < len; i++)
    {
        __cnn_bent_identity(dst + i, src + i);
    }
#endif
}

CNN_ACTIV_GRAD_DEF(cnn_bent_identity_grad)
{
#ifdef CNN_WITH_CUDA
    cnn_bent_identity_grad_gpu(gradOut, gradIn, src, len, cache);
#else
    // Find bent indentity gradient
#pragma omp parallel for
    for (int i = 0; i < len; i++)
    {
        __cnn_bent_identity_grad(gradOut + i, gradIn + i, src + i, NULL);
    }
#endif
}

CNN_ACTIV_DEF(cnn_softplus)
{
#ifdef CNN_WITH_CUDA
    cnn_softplus_gpu(dst, src, len);
#else
#pragma omp parallel for
    for (int i = 0; i < len; i++)
    {
        __cnn_softplus(dst + i, src + i);
    }
#endif
}

CNN_ACTIV_GRAD_DEF(cnn_softplus_grad)
{
#ifdef CNN_WITH_CUDA
    cnn_softplus_grad_gpu(gradOut, gradIn, src, len, cache);
#else
    // Find softplus gradient
#pragma omp parallel for
    for (int i = 0; i < len; i++)
    {
        __cnn_softplus_grad(gradOut + i, gradIn + i, src + i, NULL);
    }
#endif
}

CNN_ACTIV_DEF(cnn_softsign)
{
#ifdef CNN_WITH_CUDA
    cnn_softsign_gpu(dst, src, len);
#else
#pragma omp parallel for
    for (int i = 0; i < len; i++)
    {
        __cnn_softsign(dst + i, src + i);
    }
#endif
}

CNN_ACTIV_GRAD_DEF(cnn_softsign_grad)
{
#ifdef CNN_WITH_CUDA
    cnn_softsign_grad_gpu(gradOut, gradIn, src, len, cache);
#else
    // Find softsign gradient
#pragma omp parallel for
    for (int i = 0; i < len; i++)
    {
        __cnn_softsign_grad(gradOut + i, gradIn + i, src + i, NULL);
    }
#endif
}

CNN_ACTIV_DEF(cnn_sinc)
{
#ifdef CNN_WITH_CUDA
    cnn_sinc_gpu(dst, src, len);
#else
#pragma omp parallel for
    for (int i = 0; i < len; i++)
    {
        __cnn_sinc(dst + i, src + i);
    }
#endif
}

CNN_ACTIV_GRAD_DEF(cnn_sinc_grad)
{
#ifdef CNN_WITH_CUDA
    cnn_sinc_grad_gpu(gradOut, gradIn, src, len, cache);
#else
    // Find sinc gradient
#pragma omp parallel for
    for (int i = 0; i < len; i++)
    {
        __cnn_sinc_grad(gradOut + i, gradIn + i, src + i, NULL);
    }
#endif
}

CNN_ACTIV_DEF(cnn_sinusoid)
{
#ifdef CNN_WITH_CUDA
    cnn_sin_gpu(dst, src, len);
#else
#pragma omp parallel for
    for (int i = 0; i < len; i++)
    {
        __cnn_sinusoid(dst + i, src + i);
    }
#endif
}

CNN_ACTIV_GRAD_DEF(cnn_sinusoid_grad)
{
#ifdef CNN_WITH_CUDA
    cnn_sin_grad_gpu(gradOut, gradIn, src, len, cache);
#else
    // Find sinusoid gradient
#pragma omp parallel for shared(gradOut, gradIn, src)
    for (int i = 0; i < len; i++)
    {
        __cnn_sinusoid_grad(gradOut + i, gradIn + i, src + i, NULL);
    }
#endif
}

CNN_ACTIV_DEF(cnn_identity)
{
#ifdef CNN_WITH_CUDA
    cnn_identity_gpu(dst, src, len);
#else
#pragma omp parallel for
    for (int i = 0; i < len; i++)
    {
        __cnn_identity(dst + i, src + i);
    }
#endif
}

CNN_ACTIV_GRAD_DEF(cnn_identity_grad)
{
#ifdef CNN_WITH_CUDA
    cnn_identity_grad_gpu(gradOut, gradIn, src, len, cache);
#else
    // Find identity gradient
#pragma omp parallel for
    for (int i = 0; i < len; i++)
    {
        __cnn_identity_grad(gradOut + i, gradIn + i, NULL, NULL);
    }
#endif
}

int cnn_get_activ_id(const char* name)
{
    int i;
    int ret = CNN_PARSE_FAILED;

    if (name != NULL)
    {
        for (i = 0; i < CNN_ACTIV_AMOUNT; i++)
        {
            ret = strcmp(name, cnn_activ_name[i]);
            if (ret == 0)
            {
                ret = i;
                goto RET;
            }
        }
    }

RET:
    return ret;
}


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);
}


#include <gsl/gsl_matrix.h>
#include "kexpr.h"
#include "matrix.h"
#include "api.h"

static void ke_matrix_alloc(sml_t* sml) {
	int n1 = sml_pop_int(sml);
	int n2 = sml_pop_int(sml);
	gsl_matrix * m = gsl_matrix_alloc(n1,n2);
	sml_mem_inc(sml);
	sml_push_matrix(sml, m)
}

void ke_matrix_prop_get(sml_t* sml) {
	gsl_matrix * m = sml_pop_matrix(sml);
	int j = sml_pop_int(sml);
	int i = sml_pop_int(sml);
	double r = gsl_matrix_get(m, i, j);
	sml_push_real(sml, r);
}

void ke_matrix_get(sml_t* sml) {
	int j = sml_pop_int(sml);
	int i = sml_pop_int(sml);
	gsl_matrix * m = sml_pop_matrix(sml);
	double r = gsl_matrix_get(m,i,j);
	sml_push_real(sml, r);
}

void ke_matrix_prop_set(sml_t* sml) {
	double x = sml_pop_real(sml);
	gsl_matrix * m = sml_pop_matrix(sml);
	int j = sml_pop_int(sml);
	int i = sml_pop_int(sml);
	gsl_matrix_set(m, i, j, x);
}

static void ke_matrix_set(sml_t* sml) {
	double x = sml_pop_real(sml);
	int j = sml_pop_int(sml);
	int i = sml_pop_int(sml);
	gsl_matrix * m = sml_pop_matrix(sml);
	gsl_matrix_set(m,i, j, x);
}

static void ke_matrix_put_row(sml_t* sml) {
	int top = sml_get_top(sml);
	int n = sml_get_args(sml);
	gsl_matrix * m = sml_peek_matrix(sml,(top-n));
	int i = sml_peek_int(sml,(top-n+1));
	for (size_t j = 0; j < n - 2; ++j) {
		if (j == m->size2) break;
		double x = sml_peek_real(sml, (top - n + j + 2));
		gsl_matrix_set(m, i, j, x);
	}

	top = top - n;
	sml_set_top(sml, top);
}

static void ke_matrix_put_col(sml_t* sml) {
	int top = sml_get_top(sml);
	int n = sml_get_args(sml);
	gsl_matrix * m = sml_peek_matrix(sml, (top - n));
	int j = sml_peek_int(sml, (top - n + 1));
	for (size_t i = 0; i < n - 2; ++i) {
		if (i == m->size2) break;
		double x = sml_peek_real(sml, (top - n + i + 2));
		gsl_matrix_set(m, i, j, x);
	}
	top = top - n;
	sml_set_top(sml, top);
}

static void ke_matrix_free(sml_t* sml) {
	token_t * tokp = sml_pop_token(sml);
	void * m = sml_get_ptr(tokp);
	sml_free_ptr(sml, m);
	sml_set_ptr_null(sml,tokp);
}

static void ke_matrix_set_all(sml_t* sml) {
	double x = sml_pop_real(sml);
	gsl_matrix * m = sml_pop_matrix(sml);
    gsl_matrix_set_all(m,x);
}

static void ke_matrix_set_zero(sml_t* sml) {
	gsl_matrix * m = sml_pop_matrix(sml);
	gsl_matrix_set_zero(m);
}

static void ke_matrix_set_identity(sml_t* sml) {
	gsl_matrix * m = sml_pop_matrix(sml);
    gsl_matrix_set_identity(m);
}

static void ke_matrix_swap_rows(sml_t* sml) {
	int j = sml_pop_int(sml);
	int i = sml_pop_int(sml);
	gsl_matrix * m = sml_pop_matrix(sml);
	gsl_matrix_swap_rows(m, i, j);
}

static void ke_matrix_swap_columns(sml_t* sml) {
	int j = sml_pop_int(sml);
	int i = sml_pop_int(sml);
	gsl_matrix * m = sml_pop_matrix(sml);
	gsl_matrix_swap_columns(m,i,j);
}

static void ke_matrix_rowcol(sml_t* sml) {
	int j = sml_pop_int(sml);
	int i = sml_pop_int(sml);
	gsl_matrix * m = sml_pop_matrix(sml);
	gsl_matrix_swap_rowcol(m,i,j);
}

static void ke_matrix_transpose_memcpy(sml_t* sml) {
	gsl_matrix * src = sml_pop_matrix(sml);
	gsl_matrix * dest = sml_pop_matrix(sml);
    gsl_matrix_transpose_memcpy(dest, src);
}

static void ke_matrix_transpose(sml_t* sml) {
	gsl_matrix * m = sml_pop_matrix(sml);
	gsl_matrix_transpose(m);
}

static void ke_matrix_add(sml_t* sml) {
	gsl_matrix * b = sml_pop_matrix(sml);
	gsl_matrix * a = sml_pop_matrix(sml);
    gsl_matrix_add(a,b);
}

static void ke_matrix_sub(sml_t* sml) {
	gsl_matrix * b = sml_pop_matrix(sml);
	gsl_matrix * a = sml_pop_matrix(sml);
    gsl_matrix_sub(a,b);
}

static void ke_matrix_mul_elements(sml_t* sml) {
	gsl_matrix * b = sml_pop_matrix(sml);
	gsl_matrix * a = sml_pop_matrix(sml);
	gsl_matrix_mul_elements(a,b);
}

static void ke_matrix_div_elements(sml_t* sml) {
	gsl_matrix * b = sml_pop_matrix(sml);
	gsl_matrix * a = sml_pop_matrix(sml);
	gsl_matrix_div_elements(a,b);
}

static void ke_matrix_scale(sml_t* sml) {
	double x = sml_pop_real(sml);
	gsl_matrix * m = sml_pop_matrix(sml);
    gsl_matrix_scale(m,x);
}

static void ke_matrix_add_constant(sml_t* sml) {
	double x = sml_pop_real(sml);
	gsl_matrix * m = sml_pop_matrix(sml);
	gsl_matrix_add_constant(m, x);
}

static void ke_matrix_memcpy(sml_t* sml) {
	gsl_matrix * src = sml_pop_matrix(sml);
	gsl_matrix * dest = sml_pop_matrix(sml);
    gsl_matrix_memcpy(dest,src);
}

static void ke_matrix_swap(sml_t* sml) {
	gsl_matrix * m2 = sml_pop_matrix(sml);
	gsl_matrix * m1 = sml_pop_matrix(sml);
    gsl_matrix_swap(m1,m2);
}

static void ke_matrix_min(sml_t* sml) {
	gsl_matrix * m = sml_pop_matrix(sml);
	double r = gsl_matrix_min(m);
	sml_push_real(sml, r);
}

static void ke_matrix_max(sml_t* sml) {
	gsl_matrix * m = sml_pop_matrix(sml);
	double r = gsl_matrix_max(m);
	sml_push_real(sml, r);
}

static void ke_matrix_isnull(sml_t* sml) {
	gsl_matrix * m = sml_pop_matrix(sml);
	int i = gsl_matrix_isnull(m);
	sml_push_int(sml, i);
}

static void ke_matrix_ispos(sml_t* sml) {
	gsl_matrix * m = sml_pop_matrix(sml);
	int i = gsl_matrix_ispos(m);
	sml_push_int(sml, i);
}

static void ke_matrix_isneg(sml_t* sml) {
	gsl_matrix * m = sml_pop_matrix(sml);
	int i = gsl_matrix_isneg(m);
	sml_push_int(sml, i);
}

static void ke_matrix_isnonneg(sml_t* sml) {
	gsl_matrix * m = sml_pop_matrix(sml);
	int i = gsl_matrix_isnonneg(m);
	sml_push_int(sml, i);
}

static void ke_matrix_equal(sml_t* sml) {
	gsl_matrix * b = sml_pop_matrix(sml);
	gsl_matrix * a = sml_pop_matrix(sml);
	int i = gsl_matrix_equal(a,b);
	sml_push_int(sml, i);
}

static void ke_matrix_fscanf(sml_t* sml) {
	char * filename = sml_pop_str(sml);
	gsl_matrix * m = sml_pop_matrix(sml);
	FILE * f = fopen(filename, "r");
    gsl_matrix_fscanf(f, m);
    fclose(f);
}

static void ke_matrix_fprintf(sml_t* sml) {
	gsl_matrix * m = sml_pop_matrix(sml);
	char * filename = sml_pop_str(sml);
	FILE * f = fopen(filename, "w");
    gsl_matrix_fprintf(f, m,"%5g");
    fclose(f);
}

static void ke_matrix_fread(sml_t* sml) {
	gsl_matrix * m = sml_pop_matrix(sml);
	char * filename = sml_pop_str(sml);
	FILE * f = fopen(filename, "r");
    gsl_matrix_fread(f, m);
    fclose(f);
}

static void ke_matrix_fwrite(sml_t* sml) {
token_t **stack = sml->stack;
	gsl_matrix * m = sml_pop_matrix(sml);
	char * filename = sml_pop_str(sml);
	FILE * f = fopen(filename, "w");
    gsl_matrix_fwrite(f, m);
    fclose(f);
}

void ke_matrix_hash(sml_t * sml) {
    ke_hash_add(sml, (fncp)&ke_matrix_alloc, MATRIX);
    ke_hash_add(sml, (fncp)&ke_matrix_alloc, MATRIX_ALLOC);
    ke_hash_add(sml, (fncp)&ke_matrix_get, MATRIX_GET);
    ke_hash_add(sml, (fncp)&ke_matrix_set, MATRIX_SET);
	ke_hash_add(sml, (fncp)&ke_matrix_put_row, MATRIX_PUT_ROW);
	ke_hash_add(sml, (fncp)&ke_matrix_put_col, MATRIX_PUT_COL);
	ke_hash_add(sml, (fncp)&ke_matrix_free, MATRIX_FREE);
    ke_hash_add(sml, (fncp)&ke_matrix_set_all, MATRIX_SET_ALL);
    ke_hash_add(sml, (fncp)&ke_matrix_set_zero,MATRIX_SET_ZERO);
    ke_hash_add(sml, (fncp)&ke_matrix_set_identity,MATRIX_SET_IDENTITY);
    ke_hash_add(sml, (fncp)&ke_matrix_swap_rows,MATRIX_SWAP_ROWS);
    ke_hash_add(sml, (fncp)&ke_matrix_swap_columns,MATRIX_SWAP_COLUMNS);
    ke_hash_add(sml, (fncp)&ke_matrix_rowcol,MATRIX_SWAP_ROWCOL);
    ke_hash_add(sml, (fncp)&ke_matrix_transpose_memcpy,MATRIX_TRANSPOSE_MEMCPY);
    ke_hash_add(sml, (fncp)&ke_matrix_transpose,MATRIX_TRANSPOSE);
    ke_hash_add(sml, (fncp)&ke_matrix_add,MATRIX_ADD);
    ke_hash_add(sml, (fncp)&ke_matrix_sub,MATRIX_SUB);
    ke_hash_add(sml, (fncp)&ke_matrix_mul_elements,MATRIX_MUL);
    ke_hash_add(sml, (fncp)&ke_matrix_mul_elements,MATRIX_MUL_ELEMENTS);
    ke_hash_add(sml, (fncp)&ke_matrix_div_elements,MATRIX_DIV);
    ke_hash_add(sml, (fncp)&ke_matrix_div_elements,MATRIX_DIV_ELEMENTS);
    ke_hash_add(sml, (fncp)&ke_matrix_scale,MATRIX_SCALE);
    ke_hash_add(sml, (fncp)&ke_matrix_add_constant,MATRIX_ADD_CONSTANT);
    ke_hash_add(sml, (fncp)&ke_matrix_memcpy,MATRIX_MEMCPY);
    ke_hash_add(sml, (fncp)&ke_matrix_swap,MATRIX_SWAP);
    ke_hash_add(sml, (fncp)&ke_matrix_min,MATRIX_MIN);
    ke_hash_add(sml, (fncp)&ke_matrix_max,MATRIX_MAX);
    ke_hash_add(sml, (fncp)&ke_matrix_isnull,MATRIX_ISNULL);
    ke_hash_add(sml, (fncp)&ke_matrix_ispos,MATRIX_ISPOS);
    ke_hash_add(sml, (fncp)&ke_matrix_isneg,MATRIX_ISNEG);
    ke_hash_add(sml, (fncp)&ke_matrix_isnonneg,MATRIX_ISNONNEG);
    ke_hash_add(sml, (fncp)&ke_matrix_equal,MATRIX_EQUAL);
    ke_hash_add(sml, (fncp)&ke_matrix_fscanf,MATRIX_FSCANF);
    ke_hash_add(sml, (fncp)&ke_matrix_fscanf,MATRIX_SCAN);
    ke_hash_add(sml, (fncp)&ke_matrix_fprintf,MATRIX_FPRINTF);
    ke_hash_add(sml, (fncp)&ke_matrix_fprintf,MATRIX_PRINT);
    ke_hash_add(sml, (fncp)&ke_matrix_fread,MATRIX_FREAD);
    ke_hash_add(sml, (fncp)&ke_matrix_fread,MATRIX_READ);
    ke_hash_add(sml, (fncp)&ke_matrix_fwrite,MATRIX_FWRITE);
    ke_hash_add(sml, (fncp)&ke_matrix_fwrite,MATRIX_WRITE);
}

void ke_matrix_print(sml_t* sml, token_t *k) {
    printf("Matrix: %s\n", k->name);
    for(size_t i = 0; i < k->obj.matrix->size1; i++)
        for(size_t j = 0; j < k->obj.matrix->size2; j++)
            printf("%d,%d : v:%g\n", (int)i, (int)j, gsl_matrix_get(k->obj.matrix, i,j));
}

void ke_matrix_freemem(sml_t* sml, token_t *e) {
    if (e->obj.matrix && e->vtype == KEV_MAT) {
        gsl_matrix_free(e->obj.matrix); ke_dec_memory(sml);
        e->obj.matrix = NULL;
    }
}


/*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);
}


// -*- C++ -*-  Copyright (c) Microsoft Corporation; see license.txt
#ifndef MESH_PROCESSING_LIBHH_MY_LAPACK_H_
#define MESH_PROCESSING_LIBHH_MY_LAPACK_H_

#include "Hh.h"

#if defined(HH_USE_LAPACK_INTEGER)      // Google

#include <lapack.h>
using lapack_int = lapack::integer;

#elif !(defined(_WIN32) || defined(__CYGWIN__)) // unix

#if defined(__GNUC__)
#pragma GCC diagnostic ignored "-Wredundant-decls"
#endif
#include <lapacke.h>            // in either /usr/include/ or /usr/include/lapacke/

#else  // cygwin or WIN32

#if defined(__CYGWIN__)

// cygwin: c:/cygwin/usr/src/lapack-3.5.0.tgz
//  lapacke_config.h
// #ifndef lapack_int
// #if defined(LAPACK_ILP64)
// #define lapack_int              long
// #else
// #define lapack_int              int
// #endif
// #endif
//
//  lapacke.h:  "#define lapack_int int"
// #define LAPACK_sgelss LAPACK_GLOBAL(sgelss, SGELSS)
// void LAPACK_sgelss( lapack_int* m, lapack_int* n, lapack_int* nrhs, float* a,
//                     lapack_int* lda, float* b, lapack_int* ldb, float* s,
//                     float* rcond, lapack_int* rank, float* work,
//                     lapack_int* lwork, lapack_int *info );

//  c:/cygwin/usr/src/lapack-3.5.0.tgz!lapack-3.5.0/lapacke/example/example_DGELS_colmajor.c
// #include <lapacke.h>
// {
//    double A[5][3] = {1, 2, 3, 4, 5, 1, 3, 5, 2, 4, 1, 4, 2, 5, 3};
//    double b[5][2] = {-10, 12, 14, 16, 18, -3, 14, 12, 16, 16};
//    lapack_int m = 5, n = 3, lda = 5, ldb = 5, nrhs = 2;
//    lapack_int info = LAPACKE_dgels(LAPACK_COL_MAJOR, 'N', m, n, nrhs, *A, lda, *b, ldb);
// }

using lapack_int = int;

#else  // _WIN32

using lapack_int = long;        // was defined as "integer" in f2c.h

#endif

// Continue: cygwin or WIN32

// clapack routines in liblapack
extern "C" {

// http://www.netlib.org/lapack/explore-html/d0/db8/group__real_g_esolve.html#ga206e3084597d088b31dc054a69aec93f
// SGELSS solves overdetermined or underdetermined systems for GE matrices, using SVD.
// ~/src/lib_src/CLAPACK/SRC/sgelss.c
    lapack_int sgelss_(lapack_int* m, lapack_int* n, lapack_int* nrhs, float* a, lapack_int* lda,
                       float* b, lapack_int* ldb, float* s, float* rcond, lapack_int* irank,
                       float* work, lapack_int* lwork, lapack_int* info);

// same for double-precision
    lapack_int dgelss_(lapack_int* m, lapack_int* n, lapack_int* nrhs, double* a, lapack_int* lda,
                       double* b, lapack_int* ldb, double* s, double* rcond, lapack_int* irank,
                       double* work, lapack_int* lwork, lapack_int* info);

// http://www.netlib.org/lapack/explore-html/d0/d2a/sgelsx_8f.html
// SGELSX solves overdetermined or underdetermined systems for GE matrices, using QR.
// This routine is deprecated and has been replaced by routine SGELSY.
// ~/src/lib_src/CLAPACK/SRC/sgelsx.c
// lapack_int sgelsx_(lapack_int* m, lapack_int* n, lapack_int* nrhs, float* a, lapack_int* lda,
//                   float* b, lapack_int* ldb, lapack_int* jpvt, float* rcond, lapack_int* irank,
//                   float* work, lapack_int* info);

// http://www.netlib.org/lapack/explore-html/dc/db6/sgelsy_8f.html
    lapack_int sgelsy_(lapack_int* m, lapack_int* n, lapack_int* nrhs, float* a, lapack_int* lda,
                       float* b, lapack_int* ldb, lapack_int* jpvt, float* rcond, lapack_int* irank,
                       float* work, lapack_int* lwork, lapack_int *info);

// http://www.netlib.org/lapack/explore-html/d4/dca/group__real_g_esing.html
// subroutine SGESVD (JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO)
// SGESVD computes the singular value decomposition (SVD) for GE matrices
// ~/src/lib_src/CLAPACK/SRC/sgesvd.c
    lapack_int sgesvd_(char* jobu, char* jobvt, lapack_int* m, lapack_int* n, float* a, lapack_int* lda,
                       float* s, float* u, lapack_int* ldu, float* vt, lapack_int* ldvt,
                       float* work, lapack_int* lwork, lapack_int* info);

// http://www.netlib.org/lapack/explore-html/d8/ddc/group__real_g_ecomputational.html#ga7cb54fa1727bf0166523036f4948bc56
// subroutine SGEQRF (M, N, A, LDA, TAU, WORK, LWORK, INFO)
// SGEQRF computes a QR factorization of a real M-by-N matrix A:
// A = Q * R.
// ~/src/lib_src/CLAPACK/SRC/sgeqrf.c
    lapack_int sgeqrf_(lapack_int* m, lapack_int* n, float* a, lapack_int* lda, float* tau,
                       float* work, lapack_int* lwork, lapack_int* info);

}

#if defined(_MSC_VER)
#if defined(_WIN64) && !defined(HH_NO_MKL) // for now, only use MKL on x64
#if !defined(HH_MKL_NOT_DLL)
// 2014
HH_REFERENCE_LIB("mkl_intel_lp64_dll.lib");
HH_REFERENCE_LIB("mkl_intel_thread_dll.lib");
HH_REFERENCE_LIB("mkl_core_dll.lib");
HH_REFERENCE_LIB("libiomp5md.lib");
// e.g.: depends MeshSimplify.exe
//  -> mkl_intel_thread.dll -> libiomp5md.dll mkl_core.dll ("core" dispatches among several mkl_*.dll based on CPU)
#else  // !defined(HH_MKL_NOT_DLL)
// 2012
#if defined(_WIN64)
HH_REFERENCE_LIB("mkl_intel_lp64.lib");
#else
HH_REFERENCE_LIB("mkl_intel_c.lib");
#endif
HH_REFERENCE_LIB("mkl_intel_thread.lib");
HH_REFERENCE_LIB("mkl_core.lib");
HH_REFERENCE_LIB("libiomp5md.lib");
#endif  // !defined(HH_MKL_NOT_DLL)
#else   // defined(_WIN64) && !defined(HH_NO_MKL)
HH_REFERENCE_LIB("liblapack.lib");
HH_REFERENCE_LIB("libBLAS.lib");
#if 1
HH_REFERENCE_LIB("libf2c.lib"); // CLAPACK
#else
HH_REFERENCE_LIB("libF77.lib"); // liblapack
HH_REFERENCE_LIB("libI77.lib");
#endif
#endif  // defined(_WIN64) && !defined(HH_NO_MKL)
#endif  // defined(_MSC_VER)

#endif  // !(defined(_WIN32) || defined(__CYGWIN__))

#if 0
// from mkl_lapack.h:
// It shows that the MKL lapack functions have almost the same signatures (except for "const char*").
using MKL_INT = int;            // 32-bit unless MKL_ILP64
extern "C" {
    void SGESVD(const char* jobu, const char* jobvt, const MKL_INT* m,
                const MKL_INT* n, float* a, const MKL_INT* lda, float* s,
                float* u, const MKL_INT* ldu, float* vt, const MKL_INT* ldvt,
                float* work, const MKL_INT* lwork, MKL_INT* info);
    void SGESVD_(const char* jobu, const char* jobvt, const MKL_INT* m,
                 const MKL_INT* n, float* a, const MKL_INT* lda, float* s,
                 float* u, const MKL_INT* ldu, float* vt, const MKL_INT* ldvt,
                 float* work, const MKL_INT* lwork, MKL_INT* info);
    void sgesvd(const char* jobu, const char* jobvt, const MKL_INT* m,
                const MKL_INT* n, float* a, const MKL_INT* lda, float* s,
                float* u, const MKL_INT* ldu, float* vt, const MKL_INT* ldvt,
                float* work, const MKL_INT* lwork, MKL_INT* info);
    void sgesvd_(const char* jobu, const char* jobvt, const MKL_INT* m,
                 const MKL_INT* n, float* a, const MKL_INT* lda, float* s,
                 float* u, const MKL_INT* ldu, float* vt, const MKL_INT* ldvt,
                 float* work, const MKL_INT* lwork, MKL_INT* info);
}

// from /usr/include/lapacke.h:

lapack_int LAPACKE_sgelss( int matrix_order, lapack_int m, lapack_int n,
                           lapack_int nrhs, float* a, lapack_int lda, float* b,
                           lapack_int ldb, float* s, float rcond,
                           lapack_int* rank );

void LAPACK_sgelss( lapack_int* m, lapack_int* n, lapack_int* nrhs, float* a,
                    lapack_int* lda, float* b, lapack_int* ldb, float* s,
                    float* rcond, lapack_int* rank, float* work,
                    lapack_int* lwork, lapack_int *info );

#endif

#endif // MESH_PROCESSING_LIBHH_MY_LAPACK_H_


#ifndef __INTEGRAL_H__
#define __INTEGRAL_H__

#include "basis.h"
#include "gslextra.h"

#include <math.h>
#include <gsl/gsl_vector.h>
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_sf.h>

typedef struct gaussian_chain{
    double R[3];
    int a[3];

    double exponent;

    double coefficient;

    gaussian_chain * NEXT;

}gaussian_chain;

gaussian_chain * gaussian_chain_calloc();

void gaussian_chain_free(gaussian_chain * HEAD);

double gaussian_chain_get(gaussian_chain * HEAD,double x, double y, double z);
double orbital_get(orbital * orbital,double x, double y, double z);

double SIntegral(double ra[3], double rb[3], int ax, int ay, int az, int bx, int by, int bz, double alpha,double beta);

double gaussian_chain_SIntegral(gaussian_chain * a, gaussian_chain * b);
double gaussian_chain_full_SIntegral(gaussian_chain * a_HEAD, gaussian_chain * b_HEAD);
void single_electron_transform(gaussian_chain * HEAD, orbital * a);

double orbital_SIntegral(orbital * a,orbital * b);

void orbital_S_matrix(gsl_matrix * dest, orbital * HEAD, int length);

#endif


#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"