*       Home work #1
*       Question (1)
*       Suppose a,b,c are the following function of x:
*       a=x^3-8x^2+4 , b=tanx + sin2x , c=e^(7x+5)
*       write a program which reads x and prints x,a,b,c.

        Print*, ' Enter the value of x'
        read (*,*)x
        a=x*x*x-8*x*x+4
        b=tan(x) + sin(2*x)
        c=exp(7*x+5)

        print*, x,a,b,c

        Stop
        End


subroutine simplex(start, n, EPSILON, scale, iprint,fun)
  use params
  implicit none

  external fun

    integer, intent (in) :: n, iprint
  double precision, intent (inout), dimension(0:n-1) :: start
  double precision, intent (in) :: EPSILON, scale
  double precision :: fun
! Define Constants
  integer, parameter :: MAX_IT = 1000
  double precision, parameter :: ALPHA_S=1.0
  double precision, parameter :: BETA_S=0.5
  double precision, parameter :: GAMMA_S=2.0

! ======================================================================
! Variable Definitions
!
! Integer vs = vertex with the smallest value
! Integer vh = vertex with next smallest value
! Integer vg = vertex with largest value
! Integer i,j,m,row
! Integer k = track the number of function evaluations
! Integer itr = track the number of iterations
! double precision v = holds vertices of simplex
! double precision pn,qn = values used to create initial simplex
! double precision f = value of function at each vertex
! double precision fr = value of function at reflection point
! double precision fe = value of function at expansion point
! double precision fc = value of function at contraction point
! double precision vr = reflection - coordinates
! double precision ve = expansion - coordinates
! double precision vc = contraction - coordinates
! double precision vm = centroid - coordinates
! double precision min
! double precision fsum,favg,s,cent
! double precision vtmp = temporary array passed to finddelta
! ======================================================================

  Integer :: vs,vh,vg
  Integer :: i,j,k,itr,m,row
  double precision, dimension(:,:), allocatable :: v
  double precision, dimension(:), allocatable  :: f
  double precision, dimension(:), allocatable :: vr
  double precision, dimension(:), allocatable :: ve
  double precision, dimension(:), allocatable :: vc
  double precision, dimension(:), allocatable :: vtmp
  double precision, dimension(:), allocatable :: vm
  double precision :: pn,qn
  double precision :: fr,fe,fc
  double precision :: min,fsum,favg,cent,s

  allocate (v(0:n,0:n-1))
  allocate (f(0:n))
  allocate (vr(0:n-1))
  allocate (ve(0:n-1))
  allocate (vc(0:n-1))
  allocate (vm(0:n-1))
  allocate (vtmp(0:n-1))

! create the initial simplex
! assume one of the vertices is 0.0

  pn = scale*(sqrt(n+1.)-1.+n)/(n*sqrt(2.))
  qn = scale*(sqrt(n+1.)-1.)/(n*sqrt(2.))

  DO i=0,n-1
    v(0,i) = start(i)
  END DO

  DO i=1,n
    DO j=0,n-1
      IF (i-1 == j) THEN
        v(i,j) = pn + start(j)
      ELSE
        v(i,j) = qn + start(j)
      END IF
    END DO
  END DO

! find the initial function values

  DO j=0,n
! put coordinates into single dimension array
! to pass it to finddelta
    DO m=0,n-1
      vtmp(m) = v(j,m)
    END DO
    f(j) = fun(vtmp)
  END DO

! Print out the initial simplex
! Print out the initial function values

  IF (iprint == 0) THEN
    Write(*,*) "Initial Values"
    Write(*,300) ((v(i,j),j=0,n-1),f(i),i=0,n)
  END IF

  k = n+1

! begin main loop of the minimization

DO itr=1,MAX_IT
! find the index of the largest value
  vg = 0
  DO j=0,n
    IF (f(j) .GT. f(vg)) THEN
      vg = j
    END IF
  END DO

! find the index of the smallest value
  vs = 0
  DO j=0,n
    If (f(j) .LT. f(vs)) Then
      vs = j
    END IF
  END DO

! find the index of the second largest value
  vh = vs
  Do j=0,n
    If ((f(j) .GT. f(vh)) .AND. (f(j) .LT. f(vg))) Then
      vh = j
    END IF
  END DO

! calculate the centroid
  DO j=0,n-1
  cent = 0.0
    DO m=0,n
      If (m .NE. vg) Then
        cent = cent + v(m,j)
      END IF
    END DO
    vm(j) = cent/n
  END DO

! reflect vg to new vertex vr
  DO j=0,n-1
    vr(j) = (1+ALPHA_S)*vm(j) - ALPHA_S*v(vg,j)
  END DO
  fr = fun(vr)
  k = k+1

  If ((fr .LE. f(vh)) .AND. (fr .GT. f(vs))) Then
    DO j=0,n-1
      v(vg,j) = vr(j)
    END DO
    f(vg) = fr
  END IF

! investigate a step further in this direction
  If (fr .LE. f(vs)) Then
    DO j=0,n-1
      ve(j) = GAMMA_S*vr(j) + (1-GAMMA_S)*vm(j)
    END DO
    fe = fun(ve)
    k = k+1

! by making fe < fr as opposed to fe < f(vs), Rosenbrocks function
! takes 62 iterations as opposed to 64.

    If (fe .LT. fr) Then
      DO j=0,n-1
        v(vg,j) = ve(j)
      END DO
      f(vg) = fe
    Else
      DO j=0,n-1
        v(vg,j) = vr(j)
      END DO
      f(vg) = fr
    END IF
  END IF

! check to see if a contraction is necessary
  If (fr .GT. f(vh)) Then
    DO j=0,n-1
      vc(j) = BETA_S*v(vg,j) + (1-BETA_S)*vm(j)
    END DO
    fc = fun(vc)
    k = k+1
    If (fc .LT. f(vg)) Then
      DO j=0,n-1
        v(vg,j) = vc(j)
      END DO
    f(vg) = fc

! at this point the contraction is not successful,
! we must halve the distance from vs to all the
! vertices of the simplex and then continue.
! 10/31/97 - modified C program to account for
! all vertices.

  Else
    DO row=0,n
      If (row .NE. vs) Then
        DO j=0,n-1
          v(row,j) = v(vs,j)+(v(row,j)-v(vs,j))/2.0
        END DO
      END IF
    END DO
    DO m=0,n-1
      vtmp(m) = v(vg,m)
    END DO
    f(vg) = fun(vtmp)
    k = k+1

    DO m=0,n-1
      vtmp(m) = v(vh,m)
    END DO
    f(vh) = fun(vtmp)
    k = k+1
    END IF
  END IF

! print out the value at each iteration
  IF (iprint == 0) THEN
    Write(*,*) "Iteration ",itr
    Write(*,300) ((v(i,j),j=0,n-1),f(i),i=0,n)
  END IF

! test for convergence
  fsum = 0.0
  DO j=0,n
    fsum = fsum + f(j)
  END DO
  favg = fsum/(n+1.)
  s = 0.0
  DO j=0,n
    s = s + ((f(j)-favg)**2.)/n
  END DO
  s = sqrt(s)
  If (s .LT. EPSILON) Then
    EXIT ! Nelder Mead has converged - exit main loop
  END IF
END DO
! end main loop of the minimization
! find the index of the smallest value

  vs = 0
  DO j=0,n
    If (f(j) .LT. f(vs)) Then
      vs = j
    END IF
  END DO

!  print out the minimum

  DO m=0,n-1
    vtmp(m) = v(vs,m)
  END DO
  start=vtmp
  min = fun(vtmp)
  k = k+1

250  FORMAT(A29,F7.4)
300  FORMAT(F11.6,F11.6,F11.6)

  return
  end subroutine simplex


program density_matrix
! executed as ```gfortran density.f90 -o density_matrix definitions.o -llapack```

use definitions
implicit none

interface
    function rand_wf(NN)
    implicit none
    integer :: NN
    double complex, dimension(1:NN) :: rand_wf
    end function
end interface

double complex, allocatable :: wvfn(:), density(:,:), red_dens(:,:), matsie(:,:), wvfn_2(:), two_qubit(:,:)
logical :: separable
integer :: ii, jj, hilbert_dim, DD, NN, ok
complex*16, allocatable :: org_hermitian(:,:), work(:), eigenvectors(:,:)
real*8,allocatable :: eigenvalues(:), rwork(:)

write(*,*) "What's the dimension D of the Hilbert space?"
read(*,*) DD
write(*,*) "How many subsystems compose the system?"
read(*,*) NN
write(*,*) "Is the system separable?"
read(*,*) separable

! Describe a separable and a non-separable state
if (separable) then
    write(*,*) "Building representation of separable state"
    hilbert_dim = DD*NN
    allocate(wvfn(1:hilbert_dim))
    do ii = 1, NN
        wvfn((ii-1)*DD+1:ii*DD) = rand_wf(DD)
    end do
else
    write(*,*) "Building representation of non-separable state"
    hilbert_dim = DD**NN
    allocate(wvfn(1:hilbert_dim))
    wvfn = rand_wf(hilbert_dim)
end if

! Build the density matrix for an N = 2 pure system
hilbert_dim = DD**2
allocate(wvfn_2(1:hilbert_dim))
allocate(density(1:hilbert_dim,1:hilbert_dim))
! Generate the pure system
wvfn_2 = rand_wf(hilbert_dim)
! Build the density matrix (outer product of wavefunction)
do jj = 1, hilbert_dim
    do ii = 1, hilbert_dim
        density(ii,jj) = wvfn_2(ii)*conjg(wvfn_2(jj))
    end do
end do

! get reduced matrix for a generic N = 2 density matrix
! Theorem: Any positive trace-1 matrix is a density matrix
density = rand_positive(hilbert_dim)
density = density/mat_trace(density)
allocate(red_dens(1:DD,1:DD))
allocate(matsie(1:DD,1:DD))
do jj = 1, DD
    do ii = 1, DD
        matsie = density((ii-1)*DD+1:ii*DD,(jj-1)*DD+1:jj*DD)
        red_dens(ii,jj) = mat_trace(matsie)
    end do
end do

! apply to a two-qubit system
allocate(two_qubit(1:2**2,1:2**2))
two_qubit = rand_positive(2**2)
two_qubit = two_qubit/mat_trace(two_qubit)

! Obtain eigenvalues
allocate(org_hermitian(1:2**2,1:2**2))
allocate(eigenvalues(1:2**2))
allocate(work(1:max(5000,2*2**2-1)))
allocate(rwork(1:3*2**2-2))

! copy the hermitian matrix to avoid modifying it
eigenvectors = two_qubit

! Obtain an optimal lwork
call zheev('N','U',2**2,eigenvectors,2**2,eigenvalues,work,-1,rwork,ok)
! the first element of work is the optimal lwork
call zheev('N','U',2**2,eigenvectors,2**2,eigenvalues,work,min(5000,int(work(1))),rwork,ok)

if (ok.ne.0) stop "Unsuccessful eigenvalue calculation for two-qubit system"

write(*,*) "Eigenvalues of the two-qubit density matrix"
do ii = 1, 2**2
    write(*,*) eigenvalues(ii)
end do

end program density_matrix

function rand_wf(NN)
implicit none
integer :: NN, ii
double complex, dimension(1:NN) :: rand_wf
real*8, dimension(1:NN) :: r_wf, i_wf

    call random_number(r_wf)
    call random_number(i_wf)

    r_wf = 2*r_wf - 1
    i_wf = 2*i_wf - 1

    do ii = 1, NN
        rand_wf(ii) = complex(r_wf(ii),i_wf(ii))
    end do

    ! Normalized state
    rand_wf = rand_wf/dot_product(rand_wf,rand_wf)

end function rand_wf


!
! 20/03/2019
! Author: Henrique Miranda
! Create a linear system of equations to fit a quadratic function in 3D
! the function has the general form:
!
!  f = a +
!      ax*x + ay*y + az*z +
!      axy*x*y + axz*x*z + ayz*y*z +
!      ax2*x*x + ayy*y*y + azz*z*z     (1)
!
! Use this as an interpolating function inside the tetrahedron
! and apply the hybrid tetrahedron method described in
!
! A.H. MacDonald, S.H. Vosko, and P.T. Coleridge,
! Journal of Physics C: Solid State Physics 12, 2991 (1979).
!
module m_defs
 integer, parameter :: dp=8
 real(dp), parameter :: zero = 0.0_dp, half = 0.5_dp, one = 1.0_dp, two=2.0_dp
 real(dp), parameter :: tol8  = 0.00000001_dp
 real(dp), parameter :: tol14 = 0.000000000000001_dp
 real(dp), parameter :: pi=3.141592653589793238462643383279502884197_dp
 real(dp), parameter :: two_pi = two*pi
end module m_defs

module m_quadratic
 use m_defs
 implicit none
 integer,parameter  :: lwork=200
 real(dp),parameter :: rcond=tol8
 real(dp) :: work(lwork)

 contains
 real(dp) function f(kpt,parm)
   ! Compute the quadratic function on kpt
   real(dp),intent(in) :: kpt(3)
   real(dp),intent(in) :: parm(10)
   real(dp) :: x,y,z
   x = kpt(1);y = kpt(2);z = kpt(3)
   !f = parm(1) + &
   !    parm(2)*x   + parm(3)*y   + parm(4)*z + &
   !    parm(5)*x*y + parm(6)*x*z + parm(7)*y*z + &
   !    parm(8)*x*x + parm(9)*y*y + parm(10)*z*z
   f = parm(1)+x*(parm(2)+y*parm(5)+z*parm(6)+x*parm(8))+&
               y*(parm(3)+z*parm(7)          +y*parm(9))+&
               z*(parm(4)                    +z*parm(10))
 end function f

 function df(kpt,parm)
   ! Compute the derivative of the quadratic function with respect to kx,ky,kz
   real(dp),intent(in) :: kpt(3)
   real(dp),intent(in) :: parm(10)
   real(dp) :: df(3)
   real(dp) :: x,y,z
   x = kpt(1);y = kpt(2);z = kpt(3)
   df(1) = parm(2) + &
           parm(5)*y + parm(6)*z + &
           2.0_dp*parm(8)*x
   df(2) = parm(3) + &
           parm(5)*x + parm(7)*z + &
           2.0_dp*parm(9)*y
   df(3) = parm(4) + &
           parm(6)*x + parm(7)*y + &
           2.0_dp*parm(10)*z
 end function df

 subroutine fit4(kpts,eigs,parm,info)
  ! Fit a linear function using the values of the function evaluated in 4 points
  ! This is done solving a linear system of equations of the form Ax=b
  real(dp),intent(in)  :: kpts(3,10)
  real(dp),intent(in)  :: eigs(4)
  real(dp),intent(out) :: parm(10)
  integer,intent(out)  :: info

  integer :: ii,irank
  real(dp) :: x,y,z
  real(dp) :: sgval(4)
  real(dp) :: a(4,4), b(4)

  ! Fill in the a matrix A
  do ii=1,4
    x=kpts(1,ii);y=kpts(2,ii);z=kpts(3,ii)
    a(ii,:) = [1.0_dp,x,y,z]
  end do

  ! Fill in the vector b
  b = eigs

  !solve a system of linear equations
  call dgelss(4,4,1,a,4,b,4,sgval,rcond,irank,work,lwork,info)
  parm(:4) = b(:)
  parm(5:) = zero
 end subroutine fit4

 subroutine fit10(kpts,eigs,parm,info)
  ! Fit a quadratic function using the values fo the function evaluated in 10 points
  ! This is done solving a linear system of equations of the form Ax=b
  real(dp),intent(in) :: kpts(3,10)
  real(dp),intent(in) :: eigs(10)
  real(dp),intent(out) :: parm(10)
  integer,intent(out) :: info

  integer :: ii,irank
  real(dp) :: x,y,z
  real(dp) :: sgval(10)
  real(dp) :: a(10,10), b(10)

  ! Fill in the a matrix A
  do ii=1,10
    x=kpts(1,ii);y=kpts(2,ii);z=kpts(3,ii)
    a(ii,:) = [1.0_dp,x,y,z,x*y,x*z,y*z,x*x,y*y,z*z]
  end do

  ! Fill in the vector b
  b = eigs

  !solve a system of linear equations
  call dgelss(10,10,1,a,10,b,10,sgval,rcond,irank,work,lwork,info)
  parm = b
 end subroutine fit10

 subroutine fit10_affine(eigs,parm)
  ! Fit a quadratic function using the values fo the function evaluated in 10 points
  ! This is done by inverting A of a linear system of equations of the form Ax=b
  ! A affine transformation of coordinates (x,y,z)->(a,b,c) is used following
  ! CMES: Computer Modeling in Engineering & Sciences, Vol. 94, No. 4, pp. 279-300, 2013
  ! (x1,y1,z1) -> (0,0,0)
  ! (x2,y2,z2) -> (1,0,0)
  ! (x3,y3,z3) -> (0,1,0)
  ! (x4,y4,z4) -> (0,0,1)
  !
  ! In this coordinates, the 10 vertices of the tetrahedra are:
  ! (  0,   0,   0)
  ! (  1,   0,   0)
  ! (  0,   1,   0)
  ! (  0,   0,   1)
  ! (1/2,   0,   0)
  ! (  0, 1/2,   0)
  ! (  0,   0  1/2)
  ! (1/2, 1/2,   0)
  ! (  0, 1/2, 1/2)
  ! (1/2,   0, 1/2)
  !
  ! We want to describe a quadratic function (1)
  ! whose coefficients sym are:
  ! (a,  ax,  ay,  az, axy, axz, ayz, ax2, ayy, azz)
  !
  ! A parm = eigs
  ! The matrix A is d f /d sym
  ! [1,   0,   0,   0,   0,   0,   0,   0,   0,   0]
  ! [1,   1,   0,   0,   0,   0,   0,   1,   0,   0]
  ! [1,   0,   1,   0,   0,   0,   0,   0,   1,   0]
  ! [1,   0,   0,   1,   0,   0,   0,   0,   0,   1]
  ! [1, 1/2,   0,   0,   0,   0,   0, 1/4,   0,   0]
  ! [1,   0, 1/2,   0,   0,   0,   0,   0, 1/4,   0]
  ! [1,   0,   0, 1/2,   0,   0,   0,   0,   0, 1/4]
  ! [1, 1/2, 1/2,   0, 1/4,   0,   0, 1/4, 1/4,   0]
  ! [1,   0, 1/2, 1/2,   0,   0, 1/4,   0, 1/4, 1/4]
  ! [1, 1/2,   0, 1/2,   0, 1/4,   0, 1/4,   0, 1/4]
  !
  real(dp),intent(in) :: eigs(10)
  real(dp),intent(out) :: parm(10)

  !real(dp) :: inva(10,10)

  ! Fill in the inverse of the A matrix
  !inva(:,1)  = [1,-3,-3,-3, 4, 4, 4, 2, 2, 2]
  !inva(:,2)  = [0,-1, 0, 0, 0, 0, 0, 2, 0, 0]
  !inva(:,3)  = [0, 0,-1, 0, 0, 0, 0, 0, 2, 0]
  !inva(:,4)  = [0, 0, 0,-1, 0, 0, 0, 0, 0, 2]
  !inva(:,5)  = [0, 4, 0, 0,-4,-4, 0,-4, 0, 0]
  !inva(:,6)  = [0, 0, 4, 0,-4, 0,-4, 0,-4, 0]
  !inva(:,7)  = [0, 0, 0, 4, 0,-4,-4, 0, 0,-4]
  !inva(:,8)  = [0, 0, 0, 0, 4, 0, 0, 0, 0, 0]
  !inva(:,9)  = [0, 0, 0, 0, 0, 0, 4, 0, 0, 0]
  !inva(:,10) = [0, 0, 0, 0, 0, 4, 0, 0, 0, 0]
  !call dgemv('N',10,10,one,inva,10,eigs,1,zero,parm,1)

  parm( 1) =  eigs(1)
  parm( 2) = -3.0_dp*eigs(1)-eigs(2)+4.0_dp*eigs(5)
  parm( 3) = -3.0_dp*eigs(1)-eigs(3)+4.0_dp*eigs(6)
  parm( 4) = -3.0_dp*eigs(1)-eigs(4)+4.0_dp*eigs(7)
  parm( 5) = +4.0_dp*(eigs(1)-eigs(5)-eigs(6)+eigs(8))
  parm( 6) = +4.0_dp*(eigs(1)-eigs(5)-eigs(7)+eigs(10))
  parm( 7) = +4.0_dp*(eigs(1)-eigs(6)-eigs(7)+eigs(9))
  parm( 8) = +2.0_dp*(eigs(1)+eigs(2)-2.0_dp*eigs(5))
  parm( 9) = +2.0_dp*(eigs(1)+eigs(3)-2.0_dp*eigs(6))
  parm(10) = +2.0_dp*(eigs(1)+eigs(4)-2.0_dp*eigs(7))

 end subroutine fit10_affine

 subroutine fit4d(kpts,eigs,vels,parm,info)
  ! Fit a quadratic function using the values and derivatives of the function evaluated in 4 points
  ! This is done solving a linear system of equations of the form Ax=b
  real(dp),intent(in) :: kpts(3,4)
  real(dp),intent(in) :: eigs(4)
  real(dp),intent(in) :: vels(3,4)
  real(dp),intent(out) :: parm(10)
  integer,intent(out) :: info

  integer :: ii
  integer :: irank
  real(dp) :: x,y,z
  real(dp) :: sgval(10)
  real(dp) :: a(16,10),b(16)

  ! Fill in the a matrix for eigenvalues
  do ii=1,4
    x=kpts(1,ii);y=kpts(2,ii);z=kpts(3,ii)
    a(ii,:) = [1.0_dp,x,y,z,x*y,x*z,y*z,x*x,y*y,z*z]
  end do

  ! Fill in the matrix for velocities (explicit just because)
  x=kpts(1,1);y=kpts(2,1);z=kpts(3,1)
  a(5,:)  = [0.0_dp,1.0_dp,0.0_dp,0.0_dp,y,z,0.0_dp,2.0_dp*x,0.0_dp,0.0_dp] !dx
  a(6,:)  = [0.0_dp,0.0_dp,1.0_dp,0.0_dp,x,0.0_dp,z,0.0_dp,2.0_dp*y,0.0_dp] !dy
  a(7,:)  = [0.0_dp,0.0_dp,0.0_dp,1.0_dp,0.0_dp,x,y,0.0_dp,0.0_dp,2.0_dp*z] !dz
  x=kpts(1,2);y=kpts(2,2);z=kpts(3,2)
  a(8,:)  = [0.0_dp,1.0_dp,0.0_dp,0.0_dp,y,z,0.0_dp,2.0_dp*x,0.0_dp,0.0_dp] !dx
  a(9,:)  = [0.0_dp,0.0_dp,1.0_dp,0.0_dp,x,0.0_dp,z,0.0_dp,2.0_dp*y,0.0_dp] !dy
  a(10,:) = [0.0_dp,0.0_dp,0.0_dp,1.0_dp,0.0_dp,x,y,0.0_dp,0.0_dp,2.0_dp*z] !dz
  x=kpts(1,3);y=kpts(2,3);z=kpts(3,3)
  a(11,:) = [0.0_dp,1.0_dp,0.0_dp,0.0_dp,y,z,0.0_dp,2.0_dp*x,0.0_dp,0.0_dp] !dx
  a(12,:) = [0.0_dp,0.0_dp,1.0_dp,0.0_dp,x,0.0_dp,z,0.0_dp,2.0_dp*y,0.0_dp] !dy
  a(13,:) = [0.0_dp,0.0_dp,0.0_dp,1.0_dp,0.0_dp,x,y,0.0_dp,0.0_dp,2.0_dp*z] !dz
  x=kpts(1,4);y=kpts(2,4);z=kpts(3,4)
  a(14,:) = [0.0_dp,1.0_dp,0.0_dp,0.0_dp,y,z,0.0_dp,2.0_dp*x,0.0_dp,0.0_dp] !dx
  a(15,:) = [0.0_dp,0.0_dp,1.0_dp,0.0_dp,x,0.0_dp,z,0.0_dp,2.0_dp*y,0.0_dp] !dy
  a(16,:) = [0.0_dp,0.0_dp,0.0_dp,1.0_dp,0.0_dp,x,y,0.0_dp,0.0_dp,2.0_dp*z] !dz

  ! Fill in the vector b
  b(:4)    = eigs
  b(5:7)   = vels(:,1)
  b(8:10)  = vels(:,2)
  b(11:13) = vels(:,3)
  b(14:16) = vels(:,4)

  !solve a system of linear equations
  call dgelss(16,10,1,a,16,b,16,sgval,rcond,irank,work,lwork,info)
  parm = b(:10)
 end subroutine fit4d

end module m_quadratic

module m_tetralite

  use m_defs
  implicit none
  integer :: tetra_6lshifts(3,4,6)

  private :: f
  contains
  subroutine tetralite_init()
    tetra_6lshifts(:,1,1) = [0,0,0]
    tetra_6lshifts(:,2,1) = [1,0,0]
    tetra_6lshifts(:,3,1) = [0,1,0]
    tetra_6lshifts(:,4,1) = [1,0,1]
    tetra_6lshifts(:,1,2) = [1,0,0]
    tetra_6lshifts(:,2,2) = [1,1,0]
    tetra_6lshifts(:,3,2) = [0,1,0]
    tetra_6lshifts(:,4,2) = [1,0,1]
    tetra_6lshifts(:,1,3) = [0,1,0]
    tetra_6lshifts(:,2,3) = [1,1,0]
    tetra_6lshifts(:,3,3) = [1,0,1]
    tetra_6lshifts(:,4,3) = [1,1,1]
    tetra_6lshifts(:,1,4) = [0,0,0]
    tetra_6lshifts(:,2,4) = [0,1,0]
    tetra_6lshifts(:,3,4) = [0,0,1]
    tetra_6lshifts(:,4,4) = [1,0,1]
    tetra_6lshifts(:,1,5) = [0,0,1]
    tetra_6lshifts(:,2,5) = [1,0,1]
    tetra_6lshifts(:,3,5) = [0,1,0]
    tetra_6lshifts(:,4,5) = [0,1,1]
    tetra_6lshifts(:,1,6) = [0,1,0]
    tetra_6lshifts(:,2,6) = [1,0,1]
    tetra_6lshifts(:,3,6) = [0,1,1]
    tetra_6lshifts(:,4,6) = [1,1,1]
  end subroutine

  pure function grid(divs,gp) result(ik)
    integer,intent(in) :: divs(3),gp(3)
    integer :: ik
    integer :: ix,iy,iz
    ix=gp(1); iy=gp(2); iz=gp(3)
    ix = mod(ix-1,divs(1))+1
    iy = mod(iy-1,divs(2))+1
    iz = mod(iz-1,divs(3))+1
    ik = (ix-1)*divs(2)*divs(3)+(iy-1)*divs(3)+iz
  end function

  pure function gridp(divs,gp) result(ik)
    integer,intent(in) :: divs(3),gp(3)
    integer :: ik
    integer :: ix,iy,iz
    ix=gp(1); iy=gp(2); iz=gp(3)
    ik = (ix-1)*divs(2)*divs(3)+(iy-1)*divs(3)+iz
  end function

  pure function inv_grid(divs,ik) result(gp)
    integer,intent(in) :: divs(3),ik
    integer :: gp(3)
    integer :: ix,iy,iz,lda,ldb
    lda = divs(2)*divs(3)
    ldb = divs(3)
    ix=(ik-1)/lda
    iy=(ik-ix*lda-1)/ldb
    iz=(ik-ix*lda-iy*ldb-1)
    gp = [ix+1,iy+1,iz+1]
  end function

  pure function grid_kpoint(divs,gp) result(kpt)
    ! Get the kpoint coordinates from gridpoint
    integer,intent(in) :: divs(3),gp(3)
    real(dp) :: kpt(3)
    kpt = one*(gp-1)/divs-half
  end function

  pure real(dp) function f(n,m,w,eig)
    integer,intent(in) :: n,m
    real(dp),intent(in) :: w,eig(4)
    f = ((w - eig(m)) / (eig(n) - eig(m)))
  end function

  pure real(dp) function g1(w,eig)
    real(dp),intent(in) :: w,eig(4)
    g1 = (3.0_dp *&
          f(2, 1, w, eig) *&
          f(3, 1, w, eig) /&
          (eig(4) - eig(1)))
  end function

  pure real(dp) function g2(w,eig)
    real(dp),intent(in) :: w,eig(4)
    g2 = (3.0_dp /&
          (eig(4) - eig(1)) *&
          (f(2, 3, w, eig) *&
           f(3, 1, w, eig) +&
           f(3, 2, w, eig) *&
           f(2, 4, w, eig)))
  end function

  pure real(dp) function g3(w,eig)
    real(dp),intent(in) :: w,eig(4)
    g3 = (3.0_dp *&
            f(2, 4, w, eig) *&
            f(3, 4, w, eig) /&
            (eig(4) - eig(1)))
  end function

  pure real(dp) function I10(w,eig)
    real(dp),intent(in) :: w,eig(4)
    I10 = (f(1, 2, w, eig) +&
           f(1, 3, w, eig) +&
           f(1, 4, w, eig))
  end function

  pure real(dp) function I11(w,eig)
    real(dp),intent(in) :: w,eig(4)
    I11 = f(2, 1, w, eig)
  end function

  pure real(dp) function I12(w,eig)
    real(dp),intent(in) :: w,eig(4)
    I12 = f(3, 1, w, eig)
  end function

  pure real(dp) function I13(w,eig)
    real(dp),intent(in) :: w,eig(4)
    I13 = f(4, 1, w, eig)
  end function

  pure real(dp) function I20(w,eig)
    real(dp),intent(in) :: w,eig(4)
    I20 = (f(1, 4, w, eig) +&
           f(1, 3, w, eig) *&
           f(3, 1, w, eig) *&
           f(2, 3, w, eig) /&
          (f(2, 3, w, eig) *&
           f(3, 1, w, eig) +&
           f(3, 2, w, eig) *&
           f(2, 4, w, eig)))
  end function

  pure real(dp) function I21(w,eig)
    real(dp),intent(in) :: w,eig(4)
    I21 = (f(2, 3, w, eig) +&
           f(2, 4, w, eig) *&
           f(2, 4, w, eig) *&
           f(3, 2, w, eig) /&
          (f(2, 3, w, eig) *&
           f(3, 1, w, eig) +&
           f(3, 2, w, eig) *&
           f(2, 4, w, eig)))
  end function

  pure real(dp) function I22(w,eig)
    real(dp),intent(in) :: w,eig(4)
    I22 = (f(3, 2, w, eig) +&
           f(3, 1, w, eig) *&
           f(3, 1, w, eig) *&
           f(2, 3, w, eig) /&
          (f(2, 3, w, eig) *&
           f(3, 1, w, eig) +&
           f(3, 2, w, eig) *&
           f(2, 4, w, eig)))
  end function

  pure real(dp) function I23(w,eig)
    real(dp),intent(in) :: w,eig(4)
    I23 = (f(4, 1, w, eig) +&
           f(4, 2, w, eig) *&
           f(2, 4, w, eig) *&
           f(3, 2, w, eig) /&
          (f(2, 3, w, eig) *&
           f(3, 1, w, eig) +&
           f(3, 2, w, eig) *&
           f(2, 4, w, eig)))
  end function

  pure real(dp) function I30(w,eig)
    real(dp),intent(in) :: w,eig(4)
    I30 = f(1, 4, w, eig)
  end function

  pure real(dp) function I31(w,eig)
    real(dp),intent(in) :: w,eig(4)
    I31 = f(2, 4, w, eig)
  end function

  pure real(dp) function I32(w,eig)
    real(dp),intent(in) :: w,eig(4)
    I32 = f(3, 4, w, eig)
  end function

  pure real(dp) function I33(w,eig)
    real(dp),intent(in) :: w,eig(4)
    I33 = (f(4, 1, w, eig) +&
           f(4, 2, w, eig) +&
           f(4, 3, w, eig))
  end function

  subroutine tetralite_delta(eig,wvals,nw,alpha,integral)
    ! function to evaluate delta
    ! theare are the expressions from
    ! A.H. MacDonald, S.H. Vosko, and P.T. Coleridge,
    ! Journal of Physics C: Solid State Physics 12, 2991 (1979).
    ! as implemented in spglib implemented by Atsushi Togo translated into fortran
    integer,intent(in) :: nw
    real(dp),intent(in) :: eig(4),alpha(4)
    real(dp),intent(in) :: wvals(nw)
    real(dp),intent(out) :: integral(nw)
    integer :: iw
    real(dp) :: w,g

    do iw=1,nw
      w = wvals(iw)

      ! w < e1 nothing to do
      if (w < eig(1)) cycle

      ! e1 < w < e2
      if (w < eig(2)) then
        g = g1(w,eig)/3.0_dp
        integral(iw) = integral(iw)+g*I10(w,eig)*alpha(1)
        integral(iw) = integral(iw)+g*I11(w,eig)*alpha(2)
        integral(iw) = integral(iw)+g*I12(w,eig)*alpha(3)
        integral(iw) = integral(iw)+g*I13(w,eig)*alpha(4)
        cycle
      endif

      ! e2 < eps < e3
      if (w < eig(3)) then
        g = g2(w,eig)/3.0_dp
        integral(iw) = integral(iw)+g*I20(w,eig)*alpha(1)
        integral(iw) = integral(iw)+g*I21(w,eig)*alpha(2)
        integral(iw) = integral(iw)+g*I22(w,eig)*alpha(3)
        integral(iw) = integral(iw)+g*I23(w,eig)*alpha(4)
        cycle
      endif

      ! e3 < eps
      if (w < eig(4)) then
        g = g3(w,eig)/3.0_dp
        integral(iw) = integral(iw)+g*I30(w,eig)*alpha(1)
        integral(iw) = integral(iw)+g*I31(w,eig)*alpha(2)
        integral(iw) = integral(iw)+g*I32(w,eig)*alpha(3)
        integral(iw) = integral(iw)+g*I33(w,eig)*alpha(4)
        cycle
      endif

      ! e4 < eps
      if (eig(4) < w) exit

    end do

  end subroutine tetralite_delta

  pure subroutine sort_4tetra(list,perm)

   integer,  intent(inout) :: perm(4)
   real(dp), intent(inout) :: list(4)

   integer :: ia,ib,ic,id
   integer :: ilow1,ilow2,ihigh1,ihigh2
   integer :: ilowest,ihighest
   integer :: imiddle1,imiddle2
   real(dp) :: va,vb,vc,vd
   real(dp) :: vlow1,vlow2,vhigh1,vhigh2
   real(dp) :: vlowest,vhighest
   real(dp) :: vmiddle1,vmiddle2

   va = list(1); ia = perm(1)
   vb = list(2); ib = perm(2)
   vc = list(3); ic = perm(3)
   vd = list(4); id = perm(4)

   if (va < vb) then
       vlow1 = va; vhigh1 = vb
       ilow1 = ia; ihigh1 = ib
   else
       vlow1 = vb; vhigh1 = va
       ilow1 = ib; ihigh1 = ia
   endif

   if (vc < vd) then
       vlow2 = vc; vhigh2 = vd
       ilow2 = ic; ihigh2 = id
   else
       vlow2 = vd; vhigh2 = vc
       ilow2 = id; ihigh2 = ic
   endif

   if (vlow1 < vlow2) then
       vlowest  = vlow1; vmiddle1 = vlow2
       ilowest  = ilow1; imiddle1 = ilow2
   else
       vlowest  = vlow2; vmiddle1 = vlow1
       ilowest  = ilow2; imiddle1 = ilow1
   endif

   if (vhigh1 > vhigh2) then
       vhighest = vhigh1; vmiddle2 = vhigh2
       ihighest = ihigh1; imiddle2 = ihigh2
   else
       vhighest = vhigh2; vmiddle2 = vhigh1
       ihighest = ihigh2; imiddle2 = ihigh1
   endif

   if (vmiddle1 < vmiddle2) then
       list = [vlowest,vmiddle1,vmiddle2,vhighest]
       perm = [ilowest,imiddle1,imiddle2,ihighest]
   else
       list = [vlowest,vmiddle2,vmiddle1,vhighest]
       perm = [ilowest,imiddle2,imiddle1,ihighest]
   endif

  end subroutine sort_4tetra

end module

module m_dividetetra
  ! This is to implement an quadratic hybrid tetrahedra integration method as deribed in:
  ! A.H. MacDonald, S.H. Vosko, and P.T. Coleridge,
  ! Journal of Physics C: Solid State Physics 12, 2991 (1979).
  use m_quadratic
  use m_tetralite
  implicit none
  integer :: ieigs(2,10)
  integer :: tetra8(4,8)
  integer :: tetra_6qshifts(3,10,6)

  contains
  subroutine dividetetra_init()
    ! Initialization routine
    integer :: itetra

    ! Indexes of the middlepoints w.r.t initial tetrahedron
    ieigs(:,1) = [1,2] !5
    ieigs(:,2) = [1,3] !6
    ieigs(:,3) = [1,4] !7
    ieigs(:,4) = [2,3] !8
    ieigs(:,5) = [3,4] !9
    ieigs(:,6) = [2,4] !10

    ! 8 tetrahedra from the paper
    tetra8(:,1) = [1,5, 6, 7]
    tetra8(:,2) = [2,5, 8,10]
    tetra8(:,3) = [3,8, 9, 6]
    tetra8(:,4) = [4,9, 7,10]

    tetra8(:,5) = [7,8,10, 9]
    tetra8(:,6) = [7,8,10, 5]
    tetra8(:,7) = [7,8, 6, 9]
    tetra8(:,8) = [7,8, 6, 5]

    ! Now I generate shifts for quadratic tetrahedron
    ! this is done by scaling the original shifts by 2
    ! and computing the 10 midpoints for each of the 6 tetrahedra
    do itetra=1,6
      ! the first 4 shifts are just a copy
      tetra_6qshifts(:,:4,itetra) = 2*tetra_6lshifts(:,:,itetra)
      ! the additional 6 are the midpoints
      tetra_6qshifts(:,5:,itetra) = nint(get_6midkpts(two*tetra_6lshifts(:,:,itetra)))
    end do

  end subroutine dividetetra_init

  function get_6midkpts(kpts) result(mid)
    real(dp),intent(in) :: kpts(3,4)
    real(dp) :: mid(3,6)
    integer :: ii,ik1,ik2
    ! get the 6 midpoints
    do ii=1,6
     ik1 = ieigs(1,ii)
     ik2 = ieigs(2,ii)
     mid(:,ii) = half*(kpts(:,ik1)+kpts(:,ik2))
    end do
  end function

  function get_values(kpts,n,parm) result(val)
    ! Get the values of the quadratic function on a list of kpoints
    integer,intent(in) :: n
    real(dp),intent(in) :: kpts(3,n)
    real(dp),intent(in) :: parm(10)
    real(dp) :: val(n)
    integer :: ii
    ! evaluate a functions on a list of points
    do ii=1,n
      val(ii) = f(kpts(:,ii),parm)
    end do
  end function

  subroutine get_8tetra(eig10,mat10,wvals,nw,integral)
    ! sum the contribution of 8 tetrahedra generated by dividing one tetrahedron
    integer,intent(in) :: nw
    real(dp),intent(in) :: eig10(10), mat10(10)
    real(dp),intent(in) :: wvals(nw)
    real(dp),intent(out) :: integral(nw)

    integer :: itetra
    integer :: ind(4)
    real(dp) :: eig4(4),mat4(4)

    ! Evaluate and add the contribution of 8 tetrahedra
    integral = 0.0_dp
    do itetra=1,8
      eig4(:) = eig10(tetra8(:,itetra))
      mat4(:) = mat10(tetra8(:,itetra))
      ind = [1,2,3,4]
      call sort_4tetra(eig4,ind)
      call tetralite_delta(eig4,wvals,nw,mat4(ind),integral)
    end do
  end subroutine

  recursive subroutine hybridtetra(kpt4,eig4,mat4,parm_eig,parm_mat,wvals,nw,integral,n,depth)
    ! subdivide tetrahedra n times and evaluate contibutions
    ! number of frequencies, desired depth
    integer,intent(in) :: nw,n
    ! quadratic coeficients for interpolation
    real(dp),intent(in) :: parm_eig(10),parm_mat(10)
    real(dp),intent(in) :: kpt4(3,4),eig4(4),mat4(4)
    real(dp),intent(in) :: wvals(nw)
    real(dp),intent(inout) :: integral(nw)
    integer,optional,intent(in) :: depth
    integer  :: itetra,idepth
    integer  :: ind(4)
    real(dp) :: eig(4),mat(4)
    real(dp) :: mid10(3,10),eig10(10),mat10(10)

    ! how deep are we?
    idepth = 1; if (present(depth)) idepth = depth
    if (idepth==1) integral = 0.0_dp

    ! if in the desired depth sum the contribution of this tetrahedron
    if (idepth==n) then
      eig = eig4
      mat = 1.0_dp/8.0_dp**(idepth-1)
      call sort_4tetra(eig,ind)
      call tetralite_delta(eig,wvals,nw,mat,integral)
    ! otherwise go deeper for each tetrahedron
    else
      ! copy 4 vertices data
      mid10(:,:4) = kpt4
      eig10(:4)   = eig4
      mat10(:4)   = mat4
      ! get the additional 6 middle points
      mid10(:,5:) = get_6midkpts(kpt4)
      eig10(5:)   = get_values(mid10(:,5:),6,parm_eig)
      mat10(5:)   = get_values(mid10(:,5:),6,parm_mat)
      ! Loop over the 8 sub tetrahedra
      do itetra=1,8
        ! get coordinates of k-points of this tetrahedron
        ind(:) = tetra8(:,itetra)
        ! subdivide and evaluate again
        call hybridtetra(mid10(:,ind),eig10(ind),mat10(ind),parm_eig,parm_mat,wvals,nw,integral,n,idepth+1)
      end do
    end if
  end subroutine
end module

program fit
  use m_quadratic
  use m_dividetetra
  use m_tetralite
  implicit none

  integer :: ii,info
  real(dp) :: kpts(3,10), eigs(10), vels(3,10)
  real(dp) :: parm_mat(10), parm_eig(10)

  ! Define a function to parametrize eigenvalues
  parm_eig = [ 1.0_dp,&
               1.0_dp, 1.0_dp, 2.0_dp,&
               2.0_dp, 1.2_dp, 2.0_dp,&
               1.0_dp, 8.0_dp, 1.0_dp]

  parm_mat = [ 1.0_dp,&
               0.0_dp, 0.0_dp, 0.0_dp,&
               0.0_dp, 0.0_dp, 0.0_dp,&
               0.0_dp, 0.0_dp, 0.0_dp]

  ! Generate 10 random points
  call random_number(kpts)

  ! Test fitting a quadratic function using 10 points or 4 points + derivatives
  fit_stuff : block
    ! Set eigenvalues and velocities
    do ii=1,10
      eigs(ii)   = f(kpts(:,ii),parm_eig)
      vels(:,ii) = df(kpts(:,ii),parm_eig)
    end do
    write(*,'(10f8.3)') (parm_eig(ii),ii=1,10)

    ! Fit using 10 points
    call fit10(kpts,eigs,parm_eig,info)
    write(*,'(10f8.3)') (parm_eig(ii),ii=1,10)

    ! Fit using 4 points and derivatives
    call fit4d(kpts,eigs,vels,parm_eig,info)
    write(*,'(10f8.3)') (parm_eig(ii),ii=1,10)
  end block fit_stuff

  ! now its a bit of tetrahedron stuff
  ! subdivide a tetrahedron in 8 and get the value of the integral inside it
  tetradivide_stuff : block
    integer :: nw
    real(dp) :: mid6(3,6)
    real(dp) :: eig4(4), mat4(4)
    real(dp) :: eig10(10), mat10(10)
    real(dp),allocatable :: wvals(:)
    real(dp),allocatable :: integral(:)

    ! Initialize
    parm_eig = parm_eig
    call tetralite_init()
    call dividetetra_init()

    nw = 10
    allocate(wvals(nw))
    allocate(integral(nw))
    wvals = [(ii,ii=1,nw)]

    ! 4 of the points come from the mother
    eig10(:4) = eigs(:4)
    ! Get the additional 6 middle points and their eigenvalues
    mid6 = get_6midkpts(kpts)
    eig10(5:) = get_values(mid6,6,parm_eig)
    ! Here I set the matrix elements to constants.
    ! Could interpolate them as well (linearly or quadratically)
    mat10 = 1.0_dp
    call get_8tetra(eig10,mat10,wvals,nw,integral)

    ! now test the hybrid tetrahedron routine
    eig4 = get_values(kpts,4,parm_eig)
    mat4 = get_values(kpts,4,parm_mat)
    call  hybridtetra(kpts(:,:4),eig4,mat4,parm_eig,parm_mat,wvals,nw,integral,1)
    deallocate(wvals)
    deallocate(integral)

  end block tetradivide_stuff

  tetralite_stuff: block
    integer :: ix,iy,iz
    integer :: ik,nk,nw
    integer :: itetra,isummit,idepth
    integer :: jtetra,jsummit,idx10
    integer :: band
    integer :: divs(3),ind(4),gp(3)
    character(len=100) :: fname
    real(dp) :: emin,emax,step
    real(dp) :: start_time, stop_time
    real(dp) :: kpt(3),kpt4(3,4),eig4(4),mat4(4),vel4(3,4)
    real(dp) :: kpt10(3,10),eig10(10),mat10(10)
    real(dp) :: parm_eig(10)
    real(dp),allocatable :: eig(:),vel(:,:)
    real(dp),allocatable :: wvals(:)
    real(dp),allocatable :: dweight(:,:)
    real(dp),allocatable :: integral(:), integral_tmp(:)

    ! choose TB band or parabola
    band = 1

    ! choose how many times to apply recursion
    idepth = 1
    divs = [2,2,2]
    divs = [4,4,4]
    divs = [6,6,6]
    divs = [8,8,8]
    divs = [10,10,10]
    !divs = [20,20,20]
    !divs = [30,30,30]
    !divs = [40,40,40]
    !divs = [50,50,50]
    divs = [100,100,100]
    nw = 500

    write(*,*) divs
    write(*,*) idepth

    nk = divs(1)*divs(2)*divs(3)
    allocate(eig(nk))
    allocate(vel(3,nk))
    allocate(wvals(nw))
    allocate(dweight(4,nw))
    allocate(integral(nw))
    allocate(integral_tmp(nw))

    ! Evaluate function on each kpoint
    ! We want to precompute the values of the function in the BZ and then use then to compute DOS
    ! Note that we assume that the functions are periodic, if this is not the case
    ! then the precomputed velocities will not be correct.
    ! this is the case for the parabola_band
    ! For testing purposes we can recompute the velocities for the quadratic tetrahedra bellow
    do ix=1,divs(1)
      do iy=1,divs(2)
        do iz=1,divs(3)
          kpt = grid_kpoint(divs,[ix,iy,iz])
          ik = grid(divs,[ix,iy,iz])
          select case(band)
          case(1)
           call tb_band(kpt,eig(ik),vel(:,ik))
          case(2)
           call parabola_band(kpt,eig(ik),vel(:,ik))
          end select
        end do
      end do
    end do
    ! For the moment I set the matrix elements to zero
    mat4  = one
    mat10 = one

    ! Determine DOS energy range
    emin = minval(eig)-0.2_dp
    emax = maxval(eig)+0.2_dp
    step = (emax-emin)/(nw-1)
    wvals = [(emin+ii*step,ii=0,nw-1)]

    ! Compute DOS with linear tetrahedron
    call cpu_time(start_time)
    integral = zero
    mat4 = one/nk
    do ix=1,divs(1)
      do iy=1,divs(2)
        do iz=1,divs(3)
          ! generate 6 tetrahedra for this point
          do itetra=1,6
            do isummit=1,4
              gp = [ix,iy,iz]+tetra_6lshifts(:,isummit,itetra)
              ! Get eigenvalues and velocities
              ik = grid(divs,gp)
              eig4(isummit)   = eig(ik)
              vel4(:,isummit) = vel(:,ik)
              ! Compute eigenvalues and velocities
              !kpt = grid_kpoint(divs,gp)
              !call tb_band(kpt,eig4(isummit),vel4(:,isummit))
              !call parabola_band(kpt,eig4(isummit),vel4(:,isummit))
            end do
            call sort_4tetra(eig4,ind)
            call tetralite_delta(eig4,wvals,nw,mat4,integral)
          end do
        end do
      end do
    end do
    call cpu_time(stop_time)
    write(*,'(a30,f12.6,a)') 'linear dos took:',(stop_time-start_time), ' [s]'
    write(fname,'(a,i0,a)') 'dosl',divs(1),'.dat'
    call write_file(fname,nw,wvals,integral)

    ! Compute DOS with quadratic tetrahedron (fitting only scalars)
    call cpu_time(start_time)
    integral = zero
    mat4=one
    ! loop over points
    do ix=1,divs(1),2
      do iy=1,divs(2),2
        do iz=1,divs(3),2
          ! generate 6 tetrahedra for this point
          do itetra=1,6
            ! each tetrahdra has 10 points
            do isummit=1,10
              gp = [ix,iy,iz]+tetra_6qshifts(:,isummit,itetra)
              ! Get eigenvalues
              ik = grid(divs,gp)
              eig10(isummit)   = eig(ik)
              kpt10(:,isummit) = grid_kpoint(divs,gp)
            end do
            ! fit energies
            call fit10(kpt10,eig10,parm_eig,info)
            ! now apply hibrid tetrahedron to each of the 8 tetrahedra
            do jtetra=1,8
              do jsummit=1,4
                idx10 = tetra8(jsummit,jtetra)
                eig4(jsummit)   = eig10(idx10)
                kpt4(:,jsummit) = kpt10(:,idx10)
              end do
              ! get hybrid weights
              call hybridtetra(kpt4,eig4,mat4,parm_eig,parm_mat,wvals,nw,integral_tmp,idepth)
              integral = integral + integral_tmp/nk
            end do
          end do
        end do
      end do
    end do
    call cpu_time(stop_time)
    write(*,'(a30,f12.6,a)') 'quadratic scalar dos took:',(stop_time-start_time), ' [s]'
    write(fname,'(a,i0,a,i0,a)') 'dosqs',divs(1),'d',idepth,'.dat'
    call write_file(fname,nw,wvals,integral)

    ! Compute DOS with quadratic tetrahedron (fitting only scalars and using affine transformation)
    call cpu_time(start_time)
    integral = zero
    ! loop over points
    kpt10(:,1)  = [0.0_dp,0.0_dp,0.0_dp]
    kpt10(:,2)  = [1.0_dp,0.0_dp,0.0_dp]
    kpt10(:,3)  = [0.0_dp,1.0_dp,0.0_dp]
    kpt10(:,4)  = [0.0_dp,0.0_dp,1.0_dp]
    kpt10(:,5:) = get_6midkpts(kpt10(:,:4))
    do ix=1,divs(1),2
      do iy=1,divs(2),2
        do iz=1,divs(3),2
          ! generate 6 tetrahedra for this point
          do itetra=1,6
            ! each tetrahdra has 10 points
            do isummit=1,10
              gp = [ix,iy,iz]+tetra_6qshifts(:,isummit,itetra)
              ! Get eigenvalues
              ik = grid(divs,gp)
              eig10(isummit) = eig(ik)
            end do
            ! fit energies
            call fit10_affine(eig10,parm_eig)
            ! now apply hibrid tetrahedron to each of the 8 tetrahedra
            do jtetra=1,8
              do jsummit=1,4
                idx10 = tetra8(jsummit,jtetra)
                eig4(jsummit) = eig10(idx10)
                kpt4(:,jsummit) = kpt10(:,idx10)
              end do
              ! get hybrid weights
              call hybridtetra(kpt4,eig4,mat4,parm_eig,parm_mat,wvals,nw,integral_tmp,idepth)
              integral = integral + integral_tmp/nk
            end do
          end do
        end do
      end do
    end do
    call cpu_time(stop_time)
    write(*,'(a30,f12.6,a)') 'quadratic affine dos took:',(stop_time-start_time), ' [s]'
    write(fname,'(a,i0,a,i0,a)') 'dosqsa',divs(1),'d',idepth,'.dat'
    call write_file(fname,nw,wvals,integral)

    ! Compute DOS with quadratic tetrahedron (fitting the velocities)
    call cpu_time(start_time)
    integral = zero
    ! loop over points
    do ix=1,divs(1)
      do iy=1,divs(2)
        do iz=1,divs(3)
          ! generate 6 tetrahedra for this point
          do itetra=1,6
            do isummit=1,4
              gp = [ix,iy,iz]+tetra_6lshifts(:,isummit,itetra)
              ! Get eigenvalues and velocities
              ik = grid(divs,gp)
              eig4(isummit)   = eig(ik)
              vel4(:,isummit) = vel(:,ik)
              kpt4(:,isummit) = grid_kpoint(divs,gp)
              ! Activate this for the parabola band
              ! Compute eigenvalues and velocities
              !kpt4(:,isummit) = grid_kpoint(divs,gp)
              !call tb_band(kpt4(:,isummit),eig4(isummit),vel4(:,isummit))
              !call parabola_band(kpt4(:,isummit),eig4(isummit),vel4(:,isummit))
            end do
            ! fit energies
            call fit4d(kpt4,eig4,vel4,parm_eig,info)
            ! get hybrid weights
            call hybridtetra(kpt4,eig4,mat4,parm_eig,parm_mat,wvals,nw,integral_tmp,idepth)
            integral = integral + integral_tmp/nk
          end do
        end do
      end do
    end do
    call cpu_time(stop_time)
    write(*,'(a30,f12.6,a)') 'quadratic velocity dos took:',(stop_time-start_time), ' [s]'
    write(fname,'(a,i0,a,i0,a)') 'dosq',divs(1),'d',idepth,'.dat'
    call write_file(fname,nw,wvals,integral)

    deallocate(eig)
    deallocate(vel)
    deallocate(wvals)
    deallocate(dweight)
    deallocate(integral)
    deallocate(integral_tmp)

  end block tetralite_stuff

  contains
  pure subroutine parabola_band(kpt,eig,vel)
    ! Simple parabola
    real(dp),intent(in) :: kpt(3)
    real(dp),intent(out) :: eig, vel(3)
    real(dp) :: x,y,z
    x = kpt(1)*two_pi
    y = kpt(2)*two_pi
    z = kpt(3)*two_pi
    eig = x*x+y*y+z*z
    vel(1) = 2*two_pi*x
    vel(2) = 2*two_pi*y
    vel(3) = 2*two_pi*z
  end subroutine

  pure subroutine tb_band(kpt,eig,vel)
    ! TB band
    real(dp),intent(in) :: kpt(3)
    real(dp),intent(out) :: eig, vel(3)
    real(dp) :: x,y,z
    x = kpt(1)*two_pi
    y = kpt(2)*two_pi
    z = kpt(3)*two_pi
    eig = -(cos(x)*cos(y) + cos(x)*cos(z) + cos(y)*cos(z))
    vel(1) = two_pi*(cos(y)*sin(x) + cos(z)*sin(x))
    vel(2) = two_pi*(cos(x)*sin(y) + cos(z)*sin(y))
    vel(3) = two_pi*(cos(x)*sin(z) + cos(y)*sin(z))
  end subroutine

  subroutine write_file(fname,nw,wvals,integral)
    integer :: iw,nw
    real(dp) :: wvals(nw), integral(nw)
    character(len=100) :: fname
    open(unit=1,file=fname)
    do iw=1,nw
      write(1,*) wvals(iw), integral(iw)
    end do
    close(1)
  end subroutine
end program fit


program array_op_2d
implicit none

integer :: a(2, 2, 1), b(2, 2, 1), c(2, 2, 1)
integer :: i, j, k

do i = 1, 2
    do j = 1, 2
        do k = 1, 1
            a(i, j, k) = i*i
            b(i, j, k) = j*j
        end do
    end do
end do

i = 0

print *, a(1, 1, 1), a(1, 2, 1), a(2, 1, 1), a(2, 2, 1)

print *, b(1, 1, 1), b(1, 2, 1), b(2, 1, 1), b(2, 2, 1)

c = a + b
print *, c(1, 1, 1), c(1, 2, 1), c(2, 1, 1), c(2, 2, 1)

c = a - b
print *, c(1, 1, 1), c(1, 2, 1), c(2, 1, 1), c(2, 2, 1)

c = a*b
print *, c(1, 1, 1), c(1, 2, 1), c(2, 1, 1), c(2, 2, 1)

c = b/a
print *, c(1, 1, 1), c(1, 2, 1), c(2, 1, 1), c(2, 2, 1)

end program


PROGRAM funxy
!
!  Purpose:
!    This program solves the function f(x,y) for a user-specified x and y,
!    where f(x,y) is defined as:
!                 _
!                |
!                |   X + Y             X >= 0 and Y >= 0
!                |   X + Y**2          X >= 0 and Y < 0
!       F(X,Y) = |   X**2 + Y          X < 0  and Y >= 0
!                |   X**2 + Y**2       X < 0  and Y < 0
!                |_
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/06/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare variable types, definitions, & units
REAL :: x                ! First independent variable
REAL :: y                ! Second independent variable
REAL :: fun              ! Resulting function

! Prompt the user for the values x and y
WRITE (*,*) 'Enter the coefficients x and y: '
READ  (*,*) x, y

! Write the coefficients of x and y.
WRITE (*,*) 'The coefficients x and y are: ', x, y

!  Calculate the function f(x,y) based upon the signs of x and y.
IF ( ( x >= 0. ) .AND. ( y >= 0. ) ) THEN
   fun = x + y
ELSE IF ( ( x >= 0. ) .AND. ( y < 0. ) ) THEN
   fun = x + y**2
ELSE IF ( ( x < 0. ) .AND. ( y >= 0. ) ) THEN
   fun = x**2 + y
ELSE
   fun = x**2 + y**2
END IF

! Write the value of the function.
WRITE (*,*) 'The value of the function is: ', fun

END PROGRAM funxy


PROGRAM  matmulCheck
    IMPLICIT NONE

    REAL, ALLOCATABLE :: A(:, :), B(:, :)
    REAL:: D(10, 10) = 0
    INTEGER:: L, M, N, O,  i, j

    WRITE(*, *) "Please Enter L M"
    READ(*, *) L, M
    ALLOCATE(A(L, M))

    WRITE(*, *) "Enter Matrix A()"
    DO i = 1, L
        READ(*, *) (A(i,j), j=1,M) ! A() is L-by-M
    ENDDO

    WRITE(*, *) "Please Enter N O"
    READ(*, *) N, O
    ALLOCATE(B(N, O))

    WRITE(*, *) "Enter Matrix B()"
    DO i = 1, N
        READ(*, *) (B(i,j), j=1, O) ! B() is N-by-O
    ENDDO

    ! Matmul will be check for column(A) = row(B) or not => If not than give runtime error
    D = matmul(a, b)
    WRITE(*, *) "Matrix D calculated from matmul library is "
    DO i = 1, L
        Write(*, *) (D(i,j), j=1, O)
    ENDDO

END


!! ------------------------------------------------------------------------- !!
module m_matrix

  implicit none
  private

  integer, parameter :: DP = selected_real_kind(13)
  integer, parameter :: STDERR  = 0

  public matrix__gs

contains

  !! ----------------------------------------------------------------------- !!
  !>
  !! Solve the well-conditioned linear system
  !! Sum( m(i,j)*a(j) ) == v(i) for a(:)
  !! by Gauss-Seidel method.
  !<
  !! --
  subroutine matrix__gs( n, m, v, a )

    integer,  intent(in)  :: n       !< model size
    real(DP), intent(in)  :: m(n,n)  !< coefficient matrix
    real(DP), intent(in)  :: v(n)    !< values
    real(DP), intent(out) :: a(n)    !< answers
    real(DP), parameter   :: TOL = 1e-6
    real(DP) :: a0(n)
    integer :: iter
    integer :: i, j
    real(DP) :: m_max, wk
    !! --

    a(:) = 0
    a0(:) = 0
    iter = 0
    m_max = maxval(abs(m))

    do
      do i=1, n
        wk = 0
        do j=1, i-1
          wk = wk + m(i,j) * a(j)
        end do
        do j=i+1, n
          wk = wk + m(i,j) * a(j)
        end do
        a(i) = (v(i) - wk) / m(i,i)
      end do
      if( maxval(abs(a0 - a))/m_max < TOL ) exit
      a0(:) = a(:)
      iter = iter + 1
      if(iter > 10000) then
        write(STDERR,*) "does not converge"
        exit
      end if
    end do

  end subroutine matrix__gs
  !! ----------------------------------------------------------------------- !!

end module m_matrix
!! ------------------------------------------------------------------------- !!


      subroutine fd_insolation(lyear,idayjl,isecdy,xlat, rsol)
      implicit none

c Now, during the time period of 1978 through 1998,
c the mean value of daily averages for the solar constant from six different satellites
c yielded a solar constant of 1366.1 Wm2. This same source offers a minimum - maximum range of
c the readings for 1363 - 1368 Wm2. Adjustments yielded "a solar constant" calculated to 1366.22 Wm2.
c [Royal Meteorological Institute of Belgium: Department of Aerology;
c http://remotesensing.oma.be/RadiometryPapers/article2.html.].
c	c.gentemann gentemann@remss.com
c	6/2009

	real(4), parameter :: solar_constant=1366.2   !watts/m**2
      real(4), parameter :: pi=3.141592654

c     inputs and outputs
	integer(4) lyear,idayjl,isecdy  ! year, julian day, seconds in day
	real(4)    xlat                 ! latitude of observation
	real(4)    rsol                 ! average insolation watts/m**2
	real(4) sunlat,sunlon,sundis,rr,H,sinh,Q

	call sunloc1(lyear,idayjl,isecdy, sunlat,sunlon,sundis)	  !sundis is radius/(mean radius)

      rr=-tand(xlat)*tand(sunlat);
      if(rr> 1) rr= 1.
      if(rr<-1) rr=-1.

      H = acos(rr);
      sinH=sqrt(1 - rr**2) !sqrt(1-cos(h)**2) =sin(h)
	Q=sind(xlat)*sind(sunlat)*H + cosd(xlat)*cosd(sunlat)*sinH
      rsol = (solar_constant/pi)*Q/sundis**2

      return
      end


module maths
use variables
implicit none
contains
! *********************************************************
! *********************************************************
! MATHEMATICAL ROUTINES
! *********************************************************
! *********************************************************

!-----------------------------------------------------------------
! Returns the value of the exponential integral En(x)
!-----------------------------------------------------------------
      FUNCTION expint(n,x)
      INTEGER n,MAXIT
      REAL(kind=8) expint,x,EPS,FPMIN,EULER
      PARAMETER (MAXIT=100,EPS=1.e-7,FPMIN=1.e-30,EULER=.5772156649)
      INTEGER i,ii,nm1
      REAL(kind=8) a,b,c,d,del,fact,h,psi
      nm1=n-1
      if(n.lt.0.or.x.lt.0..or.(x.eq.0..and.(n.eq.0.or.n.eq.1)))then
        print *,'bad arguments in expint'
		  stop
      else if(n.eq.0)then
        expint=exp(-x)/x
      else if(x.eq.0.)then
        expint=1./nm1
      else if(x.gt.1.)then
        b=x+n
        c=1./FPMIN
        d=1./b
        h=d
        do 11 i=1,MAXIT
          a=-i*(nm1+i)
          b=b+2.
          d=1./(a*d+b)
          c=b+a/c
          del=c*d
          h=h*del
          if(abs(del-1.).lt.EPS)then
            expint=h*exp(-x)
            return
          endif
11      continue
        print *,'continued fraction failed in expint'
		  stop
      else
        if(nm1.ne.0)then
          expint=1./nm1
        else
          expint=-log(x)-EULER
        endif
        fact=1.
        do 13 i=1,MAXIT
          fact=-fact*x/i
          if(i.ne.nm1)then
            del=-fact/(i-nm1)
          else
            psi=-EULER
            do 12 ii=1,nm1
              psi=psi+1./ii
12          continue
            del=fact*(-log(x)+psi)
          endif
          expint=expint+del
          if(abs(del).lt.abs(expint)*EPS) return
13      continue
        print *, 'series failed in expint'
		  stop
      endif
      return
      END function expint

!-----------------------------------------------------------------
! Returns the weights (w) and the abscissas (x) for a Gaussian integration using the
! Gauss-Legendre formula, using n points
!-----------------------------------------------------------------
	subroutine gauleg(x1,x2,x,w,n)
	integer, INTENT(IN) :: n
	real(kind=8), INTENT(IN) :: x1,x2
	real(kind=8), INTENT(INOUT) :: x(n),w(n)
	real(kind=8), parameter :: eps = 3.d-14
	integer :: i,j,m
	real(kind=8) :: p1,p2,p3,pp,xl,xm,z,z1

	m=(n+1)/2
   xm=0.5d0*(x2+x1)
   xl=0.5d0*(x2-x1)
   do i=1,m
   	z=dcos(3.141592654d0*(i-.25d0)/(n+.5d0))
1  	continue
   	p1=1.d0
   	p2=0.d0
   	do j=1,n
   		p3=p2
      	p2=p1
      	p1=((2.d0*j-1.d0)*z*p2-(j-1.d0)*p3)/j
		enddo
   	pp=n*(z*p1-p2)/(z*z-1.d0)
   	z1=z
   	z=z1-p1/pp
  		if(abs(z-z1).gt.EPS)goto 1
   	x(i)=xm-xl*z
   	x(n+1-i)=xm+xl*z
   	w(i)=2.d0*xl/((1.d0-z*z)*pp*pp)
   	w(n+1-i)=w(i)
	enddo

	end subroutine gauleg

! ---------------------------------------------------------
! Returns the mean of the vector x
! ---------------------------------------------------------
	function mean(x)
	real(kind=8) :: mean
	real(kind=8), INTENT(IN) :: x(:)
		mean = sum(x) / dble(size(x))
	end function mean

! ---------------------------------------------------------
! Derivative of a function using a 3-point Lagrange interpolation formulae
! ---------------------------------------------------------
	function deriv(x0, x1, x2, f0, f1, f2, which)
	real(kind=8) :: deriv
	real(kind=8), INTENT(IN) :: x0, x1, x2, f0, f1, f2
	integer, INTENT(IN) :: which
	real(kind=8) :: h1, h2, c0, c1, c2, x

		x = 0.d0
		if (which == 0) x = x0
		if (which == 1) x = x1
		if (which == 2) x = x2
		h1 = x1 - x0
		h2 = x2 - x1
		c0 = 1.d0 / (h1*(h1+h2))
		c1 = 1.d0 / (h1*h2)
		c2 = 1.d0 / (h2*(h1+h2))

		deriv = f0 * c0 * ( (x-x2) + (x-x1) ) - f1 * c1 * ( (x-x0) + (x-x2) ) + &
			f2 * c2 * ( (x-x0) + (x-x1) )

	end function deriv

! ---------------------------------------------------------
! Derivative of a function using a 3-point Lagrange interpolation formulae
! It seems to be wrong
! ---------------------------------------------------------
	function lag_deriv(x0, x1, x2, f0, f1, f2, which)
	real(kind=8) :: lag_deriv
	real(kind=8), INTENT(IN) :: x0, x1, x2, f0, f1, f2
	integer, INTENT(IN) :: which
	real(kind=8) :: h1, h2, c0, c1, c2
		h1 = x1 - x0
		h2 = x2 - x1
		c0 = 1.d0 / (h1*(h1+h2))
		c1 = 1.d0 / (h1*h2)
		c2 = 1.d0 / (h2*(h1+h2))

		lag_deriv = 0.d0

		if (which == 0) then
			lag_deriv = -c0 * f0 * (2d0 * h1 + h2) - c1 * f1 * (h1 + h2) - c2 * f2 * h1
		endif

		if (which == 1) then
			lag_deriv = -c0 * f0 * h2 + c1 * f1 * (h1 - h2) + c2 * f2 * h1
		endif

		if (which == 2) then
			lag_deriv = c0 * f0 * h2 + c1 * f1 * (h1 + h2) + c2 * f2 * (2.d0 * h2 + h1)
		endif

	end function lag_deriv
! ---------------------------------------------------------
! LU decomposition of a matrix
!  INPUT:
!		- a is the matrix to decompose
!
!  OUTPUT:
!		- a is the LU decomposition of a
!		- indx is a vector that records the row permutation effected by the partial pivoting
!		- d takes values +1/-1 depending on whether the number of row interchanges was odd or even
! ---------------------------------------------------------
	subroutine ludcmp(a,indx,d)
	integer, INTENT(INOUT) :: indx(:)
	real(kind=8), INTENT(INOUT) :: a(:,:), d
	real(kind=8), parameter :: TINY = 1.d-20
	integer :: i, imax, j, k, n
	real(kind=8) :: aamax, dum, sum, vv(size(a,1))
		d = 1.d0
		n = size(a,1)

		imax = 0

		do i = 1, n
			aamax = 0.d0
			aamax = maxval(dabs(a(i,:)))
			if (aamax == 0.d0) print *, 'Singular matrix in LU decomposition'
			vv(i) = 1.d0 / aamax
		enddo

		do j = 1, n
			do i = 1, j-1
				sum = a(i,j)
				do k = 1, i-1
					sum = sum - a(i,k) * a(k,j)
				enddo
				a(i,j) = sum
			enddo
			aamax = 0.d0
			do i = j, n
				sum = a(i,j)
				do k = 1, j-1
					sum = sum - a(i,k) * a(k,j)
				enddo
				a(i,j) = sum
				dum = vv(i) * dabs(sum)
				if (dum >= aamax) then
					imax = i
					aamax = dum
				endif
			enddo
			if (j /= imax) then
				do k = 1, n
					dum = a(imax,k)
					a(imax,k) = a(j,k)
					a(j,k) = dum
				enddo
				d = -d
				vv(imax) = vv(j)
			endif
			indx(j) = imax
			if (a(j,j) == 0.d0) a(j,j) = TINY
			if (j /= n) then
				dum = 1.d0 / a(j,j)
				do i = j+1, n
					a(i,j) = a(i,j) * dum
				enddo
			endif
		enddo

	end subroutine ludcmp

! ---------------------------------------------------------
! Solves the set of equations AX=b where A is the LU decomposition of a matrix
!  INPUT:
!		- a is the LU decomposition of the system matrix
!		- b is the right hand side vector of the system
! 		- indx is the vector returned by ludcmp
!  OUTPUT:
!		- b is the solution of the system
! ---------------------------------------------------------
	subroutine lubksb(a,indx,b)
	real(kind=8), INTENT(IN) :: a(:,:)
	real(kind=8), INTENT(INOUT) :: b(:)
	integer, INTENT(IN) :: indx(:)
	integer :: i, ii, n, j, ll
	real(kind=8) :: sum
		n = size(a,1)
		ii = 0
		do i = 1, n
			ll = indx(i)
			sum = b(ll)
			b(ll) = b(i)
			if (ii /= 0) then
				do j = ii, i-1
					sum = sum - a(i,j) * b(j)
				enddo
			else if (sum /= 0.d0) then
				ii = i
			endif
			b(i) = sum
		enddo
		do i = n, 1, -1
			sum = b(i)
			do j = i+1, n
				sum = sum - a(i,j) * b(j)
			enddo
			b(i) = sum / a(i,i)
		enddo
	end subroutine lubksb

! ---------------------------------------------------------
! This subroutine solves a linear system of equations using a BiCGStab iterative method
! ---------------------------------------------------------
	subroutine bicgstab(a,b)
	real(kind=8), INTENT(INOUT) :: a(:,:), b(:)
	real(kind=8) :: x(size(b)), r(size(b)), rhat(size(b)), p(size(b)), phat(size(b)), v(size(b))
	real(kind=8) :: s(size(b)), shat(size(b)), t(size(b)), delta(size(b))
	real(kind=8) :: rho, rho_ant, alpha, beta, omega, relative
	integer :: i

		alpha = 0.d0
		omega = 0.d0
! Initial solution
		x = 1.d0

		r = b - matmul(A,x)
		rhat = r
		rho = 1.d0
		relative = 1.d10
		i = 1
		do while (relative > 1.d-10)
			rho_ant = rho
			rho = sum(rhat*r)
			if (rho == 0) then
				stop
			endif
			if (i == 1) then
				p = r
			else
				beta = (rho/rho_ant) * (alpha/omega)
				p = r + beta * (p - omega * v)
			endif
			phat = p
			v = matmul(A,phat)
			alpha = rho / sum(rhat*v)
			s = r - alpha * v

			shat = s
			t = matmul(A,shat)
			omega = sum(t*s)/sum(t*t)
			delta = alpha * p + omega * s
			relative = maxval(abs(delta) / x)
			x = x + delta
			r = s - omega * t
			i = i + 1
		enddo

		b = x

	end subroutine bicgstab

! ---------------------------------------------------------
! This subroutine solves a linear system of equations using the SLAP routines
! It uses an Incomplete LU BiConjugate Gradient Sparse Ax=b solver
! ---------------------------------------------------------
	subroutine slapsolver(a,b,initial)
	real(kind=8), INTENT(INOUT) :: a(:,:), b(:), initial(:)
	integer :: i, j, k
	real(kind=8), allocatable :: a_sparse(:), x(:), rwork(:)
	integer, allocatable :: ia(:), ja(:), iwork(:)
	integer :: n, nelt, isym, itol, itmax, iter, ierr, iunit, lenw, leniw, nsave
	real(kind=8) :: tol
	integer, allocatable :: indx(:)

		iter = 0
		ierr = 1
		n = size(b)
		allocate(x(n))
		k = 0
		do i = 1, n
			do j = 1, n
				if (a(j,i) /= 0.d0) k = k + 1
			enddo
		enddo
		nelt = k
		allocate(a_sparse(nelt))
		allocate(ia(nelt))
		allocate(ja(nelt))

		k = 1
		do i = 1, n
			do j = 1, n
				if (a(j,i) /= 0.d0) then
					a_sparse(k) = a(j,i)
					ia(k) = j
					ja(k) = i
					k = k + 1
				endif
			enddo
		enddo

! First try with BiCGStab
		x = initial
		isym = 0
		itol = 2
		tol = 1.d-10
		itmax = 10000
		iunit = 0
		lenw = n*n
		leniw = n*n
		nsave = 10
		allocate(iwork(leniw))
		allocate(rwork(lenw))

!		print *, 'Solving the system...'
! 		call ds2y( n, nelt, ia, ja, a_sparse, isym )
! 		call dslucs(n, b, x, nelt, ia, ja, a_sparse, isym, itol, tol, &
! 			itmax, iter, err, ierr, iunit, rwork, lenw, iwork, leniw )
!		print *, 'Number of iterations : ', iter, 'of ', itmax
!		print *, 'Error : ', err, ierr
		if (iter >= itmax+1 .or. ierr /= 0) then
			print *, 'Couldn''t reach convergence. Trying other initialization...'
!			write(17,*) 'Couldn''t reach convergence. Trying other initialization...'
			x = 1.d0
			isym = 0
			itol = 2
			tol = 1.d-10
			itmax = 10000
			iunit = 0
			lenw = n*n
			leniw = n*n
			nsave = 10
! 			call dslucs(n, b, x, nelt, ia, ja, a_sparse, isym, itol, tol, &
! 			itmax, iter, err, ierr, iunit, rwork, lenw, iwork, leniw )
!			print *, 'Number of iterations : ', iter, 'of ', itmax
!			print *, 'Error : ', err, ierr
		endif

! Let's try GMRES
		if (iter >= itmax+1 .or. ierr /= 0) then
			print *, 'Couldn''t reach convergence. Trying GMRES...'
!			write(17,*) 'Couldn''t reach convergence. Trying GMRES...'
			x = 0.d0
			isym = 0
			itol = 2
			tol = 1.d-10
			itmax = 10000
			iunit = 0
			lenw = n*n
			leniw = n*n
			nsave = 10
! 			call dsdgmr(n, b, x, nelt, ia, ja, a_sparse, isym, nsave, itol, tol, &
! 			itmax, iter, err, ierr, iunit, rwork, lenw, iwork, leniw )
!			print *, 'Number of iterations : ', iter, 'of ', itmax
!			print *, 'Error : ', err, ierr
		endif

		if (iter >= itmax+1 .or. ierr /= 0) then
			print *, 'Couldn''t reach convergence. Trying other initialization...'
!			write(17,*) 'Couldn''t reach convergence. Trying other initialization...'
			x = 1.d0
			isym = 0
			itol = 0
			tol = 1.d-10
			itmax = 10000
			iunit = 0
			lenw = n*n
			leniw = n*n
			nsave = 10
! 			call dsdgmr(n, b, x, nelt, ia, ja, a_sparse, isym, nsave, itol, tol, &
! 			itmax, iter, err, ierr, iunit, rwork, lenw, iwork, leniw )
!			print *, 'Number of iterations : ', iter, 'of ', itmax
!			print *, 'Error : ', err, ierr
		endif

		b = x

		deallocate(x)
		deallocate(a_sparse)
		deallocate(ia)
		deallocate(ja)
		deallocate(iwork)
		deallocate(rwork)

		if (iter >= itmax+1 .or. ierr /= 0) then
			print *, 'Couldn''t reach convergence. Trying LU decomposition...'
			write(17,*) 'Couldn''t reach convergence. Trying LU decomposition...'
			allocate(indx(n))
			call ludcmp(a,indx,tol)
			call lubksb(a,indx,b)
			deallocate(indx)
		endif

	end subroutine slapsolver

! ---------------------------------------------------------
! Interface to the LU solver
!  INPUT:
!		- a is the system matrix (if alu=0) or the LU decomposition (if alu /= 0)
!		- b is the right hand side of the system
!		- indx is the vector of permutations
!		- alu is a flag to indicate if LU decomposition has to be done or not
! ---------------------------------------------------------
	subroutine linsolve(a, b, indx, alu)
	real(kind=8), INTENT(INOUT) :: a(:,:), b(:)
	integer, INTENT(INOUT) :: indx(:)
	real(kind=8) :: d, v(size(b),size(b)), w(size(b)), solution(size(b))
	integer :: alu, n
		n = size(b)

		if (linear_solver_algorithm == 0) then
			if (alu == 0) then
				call ludcmp(a,indx,d)
				call lubksb(a,indx,b)
			else
				call lubksb(a,indx,b)
			endif
		else if (linear_solver_algorithm == 1) then
			call svdcmp(a,n,n,n,n,w,v)
			call svbksb(a,w,v,n,n,n,n,b,solution)
			b = solution
		else if (linear_solver_algorithm == 2) then
			print *, 'Not implemented yet'
! 			call slapsolver(a,b,initial)
		else
! 			call bicgstab(a,b)
		endif

	end subroutine linsolve

! ---------------------------------------------------------
! Returns the SVD decomposition of a matrix
! ---------------------------------------------------------
   subroutine svdcmp(a,m,n,mp,np,w,v)
   integer :: m,mp,n,np
   integer, parameter :: nmax=500
   real(kind=8) :: a(mp,np),v(np,np),w(np)
   integer :: i,its,j,jj,k,l,nm
   real(kind=8) :: anorm,c,f,g,h,s,scale,x,y,z,rv1(NMAX)
   	nm = 0
   	g=0.d0
   	scale=0.d0
   	anorm=0.d0
   	do 25 i=1,n
   	  l=i+1
   	  rv1(i)=scale*g
   	  g=0.d0
   	  s=0.d0
   	  scale=0.d0
   	  if(i.le.m)then
      	 do 11 k=i,m
	      	scale=scale+abs(a(k,i))
11           continue
	   	 if(scale.ne.0.d0)then
	      	do 12 k=i,m
	      	  a(k,i)=a(k,i)/scale
	      	  s=s+a(k,i)*a(k,i)
12             continue
	      	f=a(i,i)
	      	g=-sign(sqrt(s),f)
	      	h=f*g-s
	      	a(i,i)=f-g
	      	do 15 j=l,n
	      	  s=0.d0
	      	  do 13 k=i,m
	         	 s=s+a(k,i)*a(k,j)
13               continue
	      	  f=s/h
	      	  do 14 k=i,m
	         	 a(k,j)=a(k,j)+f*a(k,i)
14               continue
15             continue
	      	do 16 k=i,m
	      	  a(k,i)=scale*a(k,i)
16             continue
	   	 endif
	     endif
	     w(i)=scale *g
	     g=0.d0
	     s=0.d0
	     scale=0.d0
	     if((i.le.m).and.(i.ne.n))then
	   	 do 17 k=l,n
	      	scale=scale+abs(a(i,k))
17           continue
	   	 if(scale.ne.0.d0)then
	      	do 18 k=l,n
	      	  a(i,k)=a(i,k)/scale
	      	  s=s+a(i,k)*a(i,k)
18             continue
	      	f=a(i,l)
	      	g=-sign(sqrt(s),f)
	      	h=f*g-s
	      	a(i,l)=f-g
	      	do 19 k=l,n
	      	  rv1(k)=a(i,k)/h
19             continue
	      	do 23 j=l,m
	      	  s=0.d0
	      	  do 21 k=l,n
	         	 s=s+a(j,k)*a(i,k)
21               continue
	      	  do 22 k=l,n
	         	 a(j,k)=a(j,k)+s*rv1(k)
22               continue
23             continue
	      	do 24 k=l,n
	      	  a(i,k)=scale*a(i,k)
24             continue
	   	 endif
	     endif
	     anorm=max(anorm,(abs(w(i))+abs(rv1(i))))
25       continue
	   do 32 i=n,1,-1
	     if(i.lt.n)then
	   	 if(g.ne.0.d0)then
	      	do 26 j=l,n
	      	  v(j,i)=(a(i,j)/a(i,l))/g
26             continue
	      	do 29 j=l,n
	      	  s=0.d0
	      	  do 27 k=l,n
	         	 s=s+a(i,k)*v(k,j)
27               continue
	      	  do 28 k=l,n
	         	 v(k,j)=v(k,j)+s*v(k,i)
28               continue
29             continue
	   	 endif
	   	 do 31 j=l,n
	      	v(i,j)=0.d0
	      	v(j,i)=0.d0
31           continue
	     endif
	     v(i,i)=1.d0
	     g=rv1(i)
	     l=i
32       continue
	   do 39 i=min(m,n),1,-1
	     l=i+1
	     g=w(i)
	     do 33 j=l,n
	   	 a(i,j)=0.d0
33         continue
	     if(g.ne.0.d0)then
	   	 g=1.d0/g
	   	 do 36 j=l,n
	      	s=0.d0
	      	do 34 k=l,m
	      	  s=s+a(k,i)*a(k,j)
34             continue
	      	f=(s/a(i,i))*g
	      	do 35 k=i,m
	      	  a(k,j)=a(k,j)+f*a(k,i)
35             continue
36           continue
	   	 do 37 j=i,m
	      	a(j,i)=a(j,i)*g
37           continue
	     else
	   	 do 38 j= i,m
	      	a(j,i)=0.d0
38           continue
	     endif
	     a(i,i)=a(i,i)+1.d0
39       continue
	   do 49 k=n,1,-1
	     do 48 its=1,30
	   	 do 41 l=k,1,-1
	      	nm=l-1
	      	if((abs(rv1(l))+anorm).eq.anorm)  goto 2
	      	if((abs(w(nm))+anorm).eq.anorm)  goto 1
41           continue
1            c=0.d0
	   	 s=1.d0
	   	 do 43 i=l,k
	      	f=s*rv1(i)
	      	rv1(i)=c*rv1(i)
	      	if((abs(f)+anorm).eq.anorm) goto 2
	      	g=w(i)
	      	h=pythag(f,g)
	      	w(i)=h
	      	h=1.d0/h
	      	c= (g*h)
	      	s=-(f*h)
	      	do 42 j=1,m
	      	  y=a(j,nm)
	      	  z=a(j,i)
	      	  a(j,nm)=(y*c)+(z*s)
	      	  a(j,i)=-(y*s)+(z*c)
42             continue
43           continue
2            z=w(k)
	   	 if(l.eq.k)then
	      	if(z.lt.0.d0)then
	      	  w(k)=-z
	      	  do 44 j=1,n
	         	 v(j,k)=-v(j,k)
44               continue
	      	endif
	      	goto 3
	   	 endif
	   	 if(its.eq.30) then
				print *, 'no convergence in svdcmp'
				stop
			endif
	   	 x=w(l)
	   	 nm=k-1
	   	 y=w(nm)
	   	 g=rv1(nm)
	   	 h=rv1(k)
	   	 f=((y-z)*(y+z)+(g-h)*(g+h))/(2.d0*h*y)
	   	 g=pythag(f,1.d0)
	   	 f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x
	   	 c=1.d0
	   	 s=1.d0
	   	 do 47 j=l,nm
	      	i=j+1
	      	g=rv1(i)
	      	y=w(i)
	      	h=s*g
	      	g=c*g
	      	z=pythag(f,h)
	      	rv1(j)=z
	      	c=f/z
	      	s=h/z
	      	f= (x*c)+(g*s)
	      	g=-(x*s)+(g*c)
	      	h=y*s
	      	y=y*c
	      	do 45 jj=1,n
	      	  x=v(jj,j)
	      	  z=v(jj,i)
	      	  v(jj,j)= (x*c)+(z*s)
	      	  v(jj,i)=-(x*s)+(z*c)
45             continue
	      	z=pythag(f,h)
	      	w(j)=z
	      	if(z.ne.0.d0)then
	      	  z=1.d0/z
	      	  c=f*z
	      	  s=h*z
	      	endif
	      	f= (c*g)+(s*y)
	      	x=-(s*g)+(c*y)
	      	do 46 jj=1,m
	      	  y=a(jj,j)
	      	  z=a(jj,i)
	      	  a(jj,j)= (y*c)+(z*s)
	      	  a(jj,i)=-(y*s)+(z*c)
46             continue
47           continue
	   	 rv1(l)=0.d0
	   	 rv1(k)=f
	   	 w(k)=x
48         continue
3          continue
49       continue
	   return
   end subroutine svdcmp

! ---------------------------------------------------------
! Solves a linear system of equations using the SVD decomposition
! ---------------------------------------------------------
   subroutine svbksb(u,w,v,m,n,mp,np,b,x)
   integer :: m,mp,n,np
	integer, parameter :: NMAX=500
   real(kind=8) :: b(mp),u(mp,np),v(np,np),w(np),x(np)
   integer :: i,j,jj
   real(kind=8) :: s,tmp(NMAX)
      do 12 j=1,n
        s=0.d0
        if(w(j).ne.0.d0)then
          do 11 i=1,m
            s=s+u(i,j)*b(i)
11        continue
          s=s/w(j)
        endif
        tmp(j)=s
12    continue
      do 14 j=1,n
        s=0.d0
        do 13 jj=1,n
          s=s+v(j,jj)*tmp(jj)
13      continue
        x(j)=s
14    continue
      return
   end subroutine svbksb

! ---------------------------------------------------------
! Returns (a^2+b^2)^(1/2) without destructive underflow or overflow
! ---------------------------------------------------------
	function pythag(a,b)
   real(kind=8) :: a,b,pythag
   real(kind=8) :: absa,absb
      absa=dabs(a)
      absb=dabs(b)
      if(absa.gt.absb)then
        pythag=absa*dsqrt(1.+(absb/absa)**2)
      else
        if(absb.eq.0.d0)then
          pythag=0.d0
        else
          pythag=absb*sqrt(1.d0+(absa/absb)**2)
        endif
      endif
      return
	end function pythag

! ---------------------------------------------------------
! Iterative improvement of a solution to a linear set of equations
! ---------------------------------------------------------
	subroutine mprove(a, alud, indx, b, x)
	real(kind=8), INTENT(IN) :: a(:,:), alud(:,:), b(:)
	real(kind=8), INTENT(INOUT) :: x(:)
	integer, INTENT(IN) :: indx(:)
	integer :: i, j, n
	real(kind=8) :: r(size(a,1)), sdp
		n = size(a,1)
		do i = 1, n
			sdp = -b(i)
			do j = 1, n
				sdp = sdp + a(i,j) * x(j)
			enddo
			r(i) = sdp
		enddo
		call lubksb(alud,indx,r)

		x = x - r

	end subroutine mprove

! ---------------------------------------------------------
! Solves a symmetric linear system of equations
! ---------------------------------------------------------
	subroutine llslv(S,X,N,NR)
	integer, INTENT(IN) :: n, nr
	real(kind=8), INTENT(INOUT) :: S(nr,nr), x(nr)
	real(kind=8) :: sum
	integer :: i, j, k

! Decompose symmetric matrix L*LT=S
	do i = 1, n
		do j = 1, i
			sum = s(i,j)
			do k = 1, j-1
				sum = sum - S(i,k) * S(j,k)
			enddo !k
			if (j < i) then
				s(i,j) = sum / S(j,j)
			else
				S(i,j) = dsqrt(dabs(sum))
			endif
		enddo !j
	enddo !i

	entry llreslv(S,X,N,NR)
! Solve the system

	do i = 1, n
		sum = x(i)
		do j = 1, i-1
			sum = sum - S(i,j)*x(j)
		enddo !j
		x(i) = sum / S(i,i)
	enddo !i
	do i = n, 1, -1
		sum = x(i)
		do j = n, i+1, -1
			sum = sum - S(j,i)*x(j)
		enddo !j
		x(i) = sum / S(i,i)
	enddo !i

	end subroutine llslv

! ---------------------------------------------------------
! Returns a Voigt profile for the line
! ---------------------------------------------------------
      function voigt(a,vv,j)
	  real(kind=8) :: voigt, a, vv
	  integer :: j, k, i, kk, kkk
	  real(kind=8) :: d1, d2, d3, d12, d13, d23, d, y
      real(kind=8) :: a0, a1, a2, a3, a4, a5, a6, b0, b1, b2, b3, b4, b5, b6
	  real(kind=8) :: v
      complex :: z
      real(kind=8) :: xdws(28),ydws(28)

      data a0,a1,a2,a3,a4,a5,a6,b0,b1,b2,b3,b4,b5,b6/&
      122.607931777104326d0,214.382388694706425d0,181.928533092181549d0,&
      93.155580458138441d0,30.180142196210589d0,5.912626209773153d0,&
      .564189583562615d0,122.60793177387535d0,352.730625110963558d0,&
      457.334478783897737d0,348.703917719495792d0,170.354001821091472d0,&
      53.992906912940207d0,10.479857114260399d0/

      data xdws/.1d0,.2d0,.3d0,.4d0,.5d0,.6d0,.7d0,.8d0,.9d0,1.d0,1.2d0,1.4d0,1.6d0,1.8d0,2.d0,&
      3.d0,4.d0,5.d0,6.d0,7.d0,8.d0,9.d0,10.d0,12.d0,14.d0,16.d0,18.d0,20.d0/,ydws/&
      9.9335991d-02,1.9475104d-01,2.8263167d-01,3.5994348d-01,&
      4.2443639d-01,4.7476321d-01,5.1050407d-01,5.3210169d-01,&
      5.4072434d-01,5.3807950d-01,5.0727350d-01,4.5650724d-01,&
      3.9993989d-01,3.4677279d-01,3.0134040d-01,1.7827103d-01,&
      1.2934799d-01,1.0213407d-01,8.4542692d-02,7.2180972d-02,&
      6.3000202d-02,5.5905048d-02,5.0253846d-02,4.1812878d-02,&
      3.5806101d-02,3.1311397d-02,2.7820844d-02,2.5031367d-02/

      v=dabs(vv)
      IF(A.NE.0) GOTO 1
      IF(J.NE.0) GOTO 3
      VOIGT=DEXP(-V*V)
      RETURN
   3  IF(V.GT.XDWS(1)) GOTO 4
      D=V*(1.-.66666667d0*V*V)
      GOTO 8
   4  IF(V.GT.XDWS(28)) GOTO 5
      K=27
      DO 7 I=2,27
      IF(XDWS(I).LT.V) GOTO 7
      K=I
      GOTO 6
   7  CONTINUE
   6  KK=K-1
      KKK=K+1
      D1=V-XDWS(KK)
      D2=V-XDWS(K)
      D3=V-XDWS(KKK)
      D12=XDWS(KK)-XDWS(K)
      D13=XDWS(KK)-XDWS(KKK)
      D23=XDWS(K)-XDWS(KKK)
      D=YDWS(KK)*D2*D3/(D12*D13)-YDWS(K)*D1*D3/(D12*D23)+YDWS(KKK)*&
        D1*D2/(D13*D23)
      GOTO 8
   5  Y=.5/V
      D=Y*(1.+Y/V)
   8  VOIGT=5.641895836d-1*D
   9  IF(VV.LT.0.) VOIGT=-VOIGT
      RETURN
   1  Z=CMPLX(A,-V)
      Z=((((((A6*Z+A5)*Z+A4)*Z+A3)*Z+A2)*Z+A1)*Z+A0)/&
      (((((((Z+B6)*Z+B5)*Z+B4)*Z+B3)*Z+B2)*Z+B1)*Z+B0)
      IF(J.NE.0) GOTO 2
      VOIGT=REAL(Z)
      RETURN
   2  VOIGT=.5d0*AIMAG(Z)
      GOTO 9
      END function voigt

! ---------------------------------------------------------
! Given x(:) and y(:) which tabulate a function and the derivative at the boundary points
! this function returns the second derivative of the spline at each point
! ---------------------------------------------------------
		subroutine splin1(x,y,yp1,ypn,y2)
		real(kind=8), INTENT(IN) :: x(:), y(:), yp1, ypn
		real(kind=8), INTENT(INOUT) :: y2(size(x))
		integer :: n, i, k
		real(kind=8) :: p, qn, sig, un, u(size(x))

			n = size(x)

			if (yp1 > .99d30) then
				y2(1) = 0.d0
				u(1) = 0.d0
			else
				y2(1) = -0.5d0
				u(1) = (3.d0/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
			endif

			do i = 2, n-1
				sig = (x(i)-x(i-1))/(x(i+1)-x(i-1))
				p = sig * y2(i-1)+2.d0
				y2(i) = (sig-1.d0)/p
				u(i) = (6.d0*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/&
					(x(i+1)-x(i-1))-sig*u(i-1))/p
			enddo
			if (ypn > .99d30) then
				qn = 0.d0
				un = 0.d0
			else
				qn = 0.5d0
				un = (3.d0/(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
			endif

			y2(n) = (un-qn*u(n-1))/(qn*y2(n-1)+1.d0)

			do k = n-1, 1, -1
				y2(k) = y2(k)*y2(k+1)+u(k)
			enddo

		end subroutine splin1

! ---------------------------------------------------------
! Given xa(:) and ya(:) which tabulate a function, returns the interpolation using
! splines of vector x(:) in y(:)
! ---------------------------------------------------------
		subroutine spline(xa,ya,x,y,extrapolation)
		real(kind=8), INTENT(INOUT) :: y(:)
		real(kind=8), INTENT(IN) :: xa(:), ya(:), x(:)
		real(kind=8) :: y2a(size(xa))
		character*4 :: extrapolation
		integer :: n_x, n, i, k, khi, klo
		real(kind=8) :: a, b, h, extrap

			n = size(xa)
			n_x = size(x)
			call splin1(xa,ya,1.d30,1.d30,y2a)

			do i = 1, n_x

! Downward extrapolation
				if (x(i) < xa(1)) then
					select case(extrapolation)
						case('NO  ')
							y(i) = ya(1)
						case('SQRT')
							extrap = mean(ya/dsqrt(xa))
							y(i) = extrap * x(i)
					end select
				else

! Upward extrapolation
				if (x(i) > xa(n)) then
					select case(extrapolation)
						case('NO  ')
							y(i) = ya(n)
						case('SQRT')
							extrap = mean(ya/dsqrt(xa))
							y(i) = extrap * x(i)
					end select
				else
! In range
						klo = 1
						khi = n
1						if(khi-klo > 1) then
							k = (khi+klo)/2
							if (xa(k) > x(i)) then
								khi = k
							else
								klo = k
							endif
							go to 1
						endif

						h = xa(khi)-xa(klo)

						if (h == 0.d0) then
							print *, 'bad xa input in spline'
							stop
						endif
						a = (xa(khi)-x(i))/h
						b = (x(i)-xa(klo))/h

						y(i) = a*ya(klo)+b*ya(khi)+((a**3.d0-a)*y2a(klo)+(b**3.d0-b)*y2a(khi))*(h**2.d0)/6.d0
					endif
				endif
			enddo

		end subroutine spline

! ---------------------------------------------------------
! Returns the value at x0 with an interpolation in the data (x,y)
! ---------------------------------------------------------
		function interpolate(x,y,x0)
		real(kind=8) :: interpolate
		real(kind=8) :: x0
		real(kind=8), INTENT(IN) :: x(:), y(:)
		real(kind=8) :: x1(1), y1(1)
			x1(1) = x0
			call spline(x,y,x1,y1,'NO  ')
			interpolate = y1(1)
		end function interpolate

! ---------------------------------------------------------
! Returns the vector of linearly interpolated data for a given data x0, y0 at given values x
! ---------------------------------------------------------
		subroutine linear_interpol(x0,y0,x,y)
		real(kind=8), INTENT(IN) :: x0(:), y0(:)
		real(kind=8), INTENT(INOUT) :: x(:), y(:)
		real(kind=8) :: a, b, ya, yb, m, n
		integer :: n1, n2, i, j, which

			which = 0

			n1 = size(x0)
			n2 = size(x)

			do i = 1, n2
				if (x(i) < x0(1)) then
					which = 1
				else
					do j = 1, n1-1
						if (x(i) >= x0(j) .and. x(i) <= x0(j+1)) then
							which = j
						endif
					enddo
				endif
				a = x0(which)
				b = x0(which+1)
				ya = y0(which)
				yb = y0(which+1)

				m = (ya-yb)/(a-b)
				n = (yb*a-ya*b)/(a-b)
				y(i) = m * x(i) + n
			enddo

		end subroutine linear_interpol

! ---------------------------------------------------------
! Returns the imaginary part of a complex number
! ---------------------------------------------------------
		function imaginary(x)
		real(kind=8) :: imaginary
		complex(kind=8), INTENT(IN) :: x
		complex(kind=8) :: i
			i = cmplx(0.d0,1.d0)
			imaginary = -real(i*x)
		end function imaginary

end module maths


module interpolation
  use lin_alg
contains
  subroutine pinex(xi,yi,x,y,dy)
    !=========================================================!
    ! Polynomial INterpolation and EXtrapolation (PINEX).     !
    ! Runge-Kutta 4 Gill's method                             !
    ! Daniel Celis Garza 24 Sept. 2015                        !
    !---------------------------------------------------------!
    ! Inputs:                                                 !
    ! x    = independent variable                             !
    ! xi() = independent variable points                      !
    ! yi() = independent variable points                      !
    !---------------------------------------------------------!
    ! Outputs:                                                !
    ! y  = dependent variable                                 !
    ! dy = dependent variable increment/error                 !
    !---------------------------------------------------------!
    ! Locals:                                                 !
    ! c()        = small difference 1                         !
    ! d()        = small difference 2                         !
    ! difx()     = distance between point i and input x       !
    ! aux_difx() = aux var to find distance of x to point i   !
    ! den()      = denominator                                !
    ! idx        = closest point to x                         !
    ! aux_idx    = aux var to find index i                    !
    ! i          = counter                                    !
    ! n          = size(xi)                                   !
    !=========================================================!
    implicit none
    real(dp), intent(in)          :: x, xi(:), yi(:)
    real(dp), intent(out)         :: y, dy
    real(dp), dimension(size(xi)) :: c, d, difx, aux_difx, den
    integer                       :: i, idx, aux_idx(1), n

    ! Making sure we're using equally sized arrays.
    check_size: if(size(xi) /= size(yi)) then
      print*, ' Size of x and y arrays must be equal.'
      return
    endif check_size

    ! The order of the interpolation.
    n = size(xi)

    ! Calculating (x-xi) for all i  [and (xj-x) for all j].
    difx = x-xi

    ! Looking for the index of the entry with the closest value to x from xi.
    aux_difx = abs(x-xi)
    aux_idx  = minloc(aux_difx)
    idx      = aux_idx(1)

    ! Our initial best guess for y.
    y        = yi(idx)

    ! Drop down an index because that's what's required by the relationships of Cs and Ds
    idx      = idx - 1

    ! Initialising relationships of Cs and Ds.
    c = yi
    d = yi

    ! Looping over the columns of Neville's tree.
    nev_loop: do i = 1, n - 1
      den(1:n-i) = difx(1:n-i) - difx(1+i:n)
      if ( any( den(1:n-i) == 0._dp ) ) print*, ' Error: subr: poly_interpol: nev_loop. Division by zero.'
      den(1:n-i) = ( c(2:n-i+1) - d(1:n-i) ) / den(1:n-i)
      d(1:n-i)   = difx(1+i:n) * den(1:n-i)
      c(1:n-i)   = difx(1:n-i) * den(1:n-i)

      ! Calculate error terms.
      err: if (2*idx < n-i) then
        dy  = c(idx+1)
      else err
        dy  = d(idx)
        idx = idx-1
      end if err

      ! Increase the value of y.
      y = y + dy
    end do nev_loop
  end subroutine pinex

  subroutine rinex(xi,yi,x,y,dy)
    ! Polynomial INterpolation and EXtrapolation (PINEX).
    implicit none
    real(dp), intent(in)          :: x, xi(:), yi(:)
    real(dp), intent(out)         :: y, dy
    integer                       :: i, j, idx, aux_idx(1), n
    real(dp), dimension(size(xi)) :: c, d, difx, aux_difx, w, v
    real(dp), parameter           :: tiny = 1.d-25

    ! Making sure we're using equally sized arrays.
    check_size: if(size(xi) /= size(yi)) then
      print*, " Size of x and y/home/krunos/Documents/interpolation/interpol_mod.f08 arrays must be equal."
      return
    end if check_size

    ! The order of the interpolation.
    n = size(xi)

    ! Calculating (x-xi) for all i  [and (xj-x) for all j].
    difx = x-xi

    ! Looking for the index of the entry with the closest value to x from xi.
    aux_difx = abs(x-xi)
    aux_idx  = minloc(aux_difx)
    idx      = aux_idx(1)

    ! Our initial best guess for y.
    y        = yi(idx)

    ! Return when x == xi(idx).
    ret: if (x == xi(idx)) then
      dy = 0._dp
      return
    endif ret

    ! Drop down an index because that's what's required by the relationships of Cs and Ds
    idx      = idx - 1

    ! Initialising relationships of Cs and Ds.
    c = yi
    d = yi + tiny

    ! Looping over the columns of Neville's tree.
    nev_loop: do i = 1, n - 1
      ! Calculating (x - x_{i}) / (x - x_{i+m+1}) * D_{m,i}.
      w( 1: n - i ) = ( x - xi( 1: n - i) ) * d( 1: n - i ) / difx( 1 + i: n )
      ! Calculating (x - x_{i}) / (x - x_{i+m+1}) * D_{m,i} - C_{m,i+1}.
      v( 1: n - i ) = w( 1: n - i ) - c( 2: n - i + 1 )

      ! Making sure we're using equally sized arrays.
      check_underflow: if( any( v( 1: n - 1 ) == 0._dp )  ) then
        print*, " Error: rinex: nev_loop: Denominator = 0, use different points."
        return
      end if check_underflow

      ! Calculate the common factor ( c(m,i+1) - d(m,i) ) / ( (x - x_{i}) / ( x - x_{i+m+1}) * D_{m,i} - C_{m,i+1} ).
      v( 1: n - i ) = ( c(2: n - i + 1) - d( 1: n - i ) ) / v( 1: n - i )
      ! Calcualte D(m+1, i).
      d( 1: n - i ) = c(2: n - i + 1) * v ( 1: n - i )
      ! Calcualte C(m+1, i).
      c( 1: n - i ) = w(1: n - i ) * v ( 1: n - i )

      ! Calculate the interpolated value of y.
      ! Decide by how much we're going to increase y so as to cover Neville's tree the fastest.
      err: if ( 2 * idx < n - i ) then
        dy  = c(idx+1)
      else err
        dy  = d(idx)
        idx = idx-1
      end if err
      y = y + dy
    end do nev_loop
  end subroutine rinex

  subroutine csplinec(xi,yi,y,dydx1,dydx2)
    ! better way of doing things http://mathworld.wolfram.com/CubicSpline.html
    !===============================================!
    ! Cubic spline                                  !
    ! Daniel Celis Garza 9 Apr. 2016                !
    !-----------------------------------------------!
    ! Inputs:                                       !
    ! dydx = derivatives                            !
    ! xi   = points in x                            !
    ! yi   = points in y                            !
    ! dxdy = array of derivatives at points 1 and N !
    !-----------------------------------------------!
    ! Locals:                                       !
    ! a() =
    ! b() =
    ! c() =                        !
    ! d() =
    !-----------------------------------------------!
    ! Outputs:                                      !
    ! y() = array of interpolated values            !
    !===============================================!
    implicit none
    real(dp), intent(in)           :: xi(:), yi(:)
    real(dp), optional, intent(in) :: dydx1, dydx2
    real(dp), intent(out)          :: y(:)
    real(dp), dimension(size(xi))  :: a, b, c, d
    integer                        :: n

    check_size: if (size(xi) /= size(yi) .or. size(xi) /= size(y)) then
      print*, " Error: subr: csplinec: check_size: sizes of xi, yi and y arrays must be the same. "
      return
    end if check_size

    ! Number of points.
    n = size(xi)

    ! Set up tridiagonal matrix.

    ! a(1) = x(2) - x(1)
    ! ...
    ! a(n-1) = x(n) - x(n-1)
    a(1: n - 1) = xi(2: n) - xi(1: n - 1)

    ! b(1) = 6 * ( y(2) - y(1) ) / ( x(2) - x(1) )
    ! ...
    ! b(n-1) = 6 * ( y(n) - y(n-1) ) / ( x(n) - x(n - 1) )
    b(1: n - 1) = 6._dp * ( yi(2: n) - yi(1: n - 1) ) / a(1: n - 1)

    ! b(2) = 6 *( ( y(3) - y(2) ) / ( x(3) - x(2) ) - ( y(2) - y(1) ) / ( x(2) - x(1) ) )
    ! ...
    ! b(n-1) = 6 *( ( y(n) - y(n - 1) ) / ( x(n) - x(n - 1) ) - ( y(n - 1) - y(n - 2) ) / ( x(n - 1) - x(n - 2) ) )
    b(2: n - 1) = b(2: n - 1) - b(1: n - 2)

    ! c(2) = x(2) - x(1)
    ! ...
    ! c(n-1) = x(n - 1) - x(n - 2)
    c(2: n - 1) = a(1: n - 2)

    ! d(2) = 2 * ( x(3) - x(2) + x(2) - x(1) )
    ! d(2) = 2 * ( x(3) - x(1) )
    ! ...
    ! d(n-1) = 2 * ( x(n - 1) - x(n - 2) + x(n - 2) - x(n - 3) )
    d(2: n - 1) = 2._dp * ( a(2: n - 1) + c(2: n - 1) )
    ! Because A = 1 at x1. numerical recipes 107--108
    d(1) = 1._dp
    ! Because B = 1 at xn. numerical recipes 107--108
    d(n) = 1._dp

    ! Lower boundary conditions.
    ! If the Lower Boundary Condition (LBC) is not present.
    lbc: if (present(dydx1) .eqv. .false.) then
      ! If there is no LBC, it is set to the natural value.
      a(1) = 0._dp
      b(1) = 0._dp
    else lbc
      ! Else, it is set to a specified first derivative.
      a(1) = 0.5_dp
      b(1) = ( 3._dp / ( xi(2) - xi(1) ) ) * ( ( yi(2) - yi(1) ) / ( xi(2) - xi(1) ) - dydx1 )
    end if lbc

    ! Lower boundary conditions.
    ! If the Upper Boundary Condition (UBC) is not present.
    ubc: if (present(dydx1) .eqv. .false.) then
      ! If there is no LBC, it is set to the natural value.
      c(n) = 0._dp
      b(n) = 0._dp
    else ubc
      ! Else, it is set to a specified first derivative.
      c(n) = 0.5_dp
      b(n) = ( - 3._dp / ( xi(n) - xi(n - 1) ) ) * ( ( yi(n) - yi(n - 1) ) / ( xi(n) - xi(n - 1) ) - dydx2 )
    end if ubc

    ! Call subroutine to solve tridiagonal matrix.
    call tridiag(c(2: n), d, a(1: n - 1), b, y)
  end subroutine csplinec

  subroutine csplnei(xi, yi, yi2, x, y)
    implicit none
    real(dp), intent(in)  :: x, xi(:), yi(:), yi2(:)
    real(dp), intent(out) :: y
    real(dp) :: h, a, b
    integer  :: n, oidx, nidx

    ! Set the value of n to be the number of dots to interpolate.
    n = size(xi)
    ! Check that the sizes of all arrays involved are the same.
    check_size: if ( n /= size(yi) .or. &
    n /= size(yi2) ) then
    write(*,*) " Error: subr: csplinei: check_size: sizes of xi, yi and yi2 arrays must be the same; size(xi) = ", n, &
    "; size(yi) = ", size(yi), "; size(yi2) = ", size(yi2)
    return
  end if check_size

  ! Find the index corresponding to the value of x.
  oidx = vbisect(xi, x)

  nidx = oidx + 1

  ! Calculate the interval.
  h = xi( nidx ) - xi( oidx )
  ! Check if h is zero.
  if ( h == 0._dp ) write(*,*) " Error: subr: csplinei: h is too small, wrong values of xi; h = ", h, "; x(nidx) = ", xi(nidx), &
  "; x(oidx) = ", xi(oidx)

  a = ( x - xi( oidx ) ) / h
  b = ( xi( nidx ) - x  ) / h

  ! Construct the cubic equation.
  y = a * yi(nidx) + b * yi(oidx) + ( ( a*a*a - a ) * yi2(nidx) + ( b*b*b - b ) * yi2(oidx) ) * h*h / 6._dp
end subroutine csplnei

function vbisect(xi, x)
  ! Find x in within an interval in xa.
  implicit none
  real(dp), intent(in) :: xi(:), x
  integer :: vbisect
  integer :: n, i, a, b, c
  logical :: up

  n  = size(xi)
  up = ( xi(n) >= xi(1) )
  a  = 0
  b  = n + 1

  ! Carry out Bisection.
  bisect: do
    ! If we are in adjacent or equal positions, exit.
    ! [ | n | n+1 | | ]
    ! Exit if (a = n and b = n + 1), or  Exit if ( a = n and b = n )
    if ( b - a <= 1 ) exit bisect
    ! Find midpoint via integer division.
    c = ( a + b ) / 2
    ! Decide whether to move a Up or b Down.
    ud: if ( up .eqv. ( x >= xi(c) ) ) then
      a = c
    else ud
      b = c
    end if ud
  end do bisect

  ! Check Location of X Within the Interval (LXWI).
  lxwi: if ( x == xi(1) ) then
    vbisect = 1
  else if ( x == xi(n) ) then
    vbisect = n - 1
  else lxwi
    vbisect = a
  end if lxwi

end function vbisect
end module interpolation


C$Procedure  MTXVG ( Matrix transpose times vector, general dimension )

      SUBROUTINE MTXVG ( M1, V2, NC1, NR1R2, VOUT )

C$ Abstract
C
C      Multiply the transpose of a matrix and a vector of
C      arbitrary size.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C      MATRIX,  VECTOR
C
C$ Declarations

      INTEGER            NC1
      INTEGER            NR1R2
      DOUBLE PRECISION   M1   ( NR1R2,NC1 )
      DOUBLE PRECISION   V2   ( NR1R2     )
      DOUBLE PRECISION   VOUT (       NC1 )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C       M1        I     Left-hand matrix whose transpose is to be
C                       multiplied.
C       V2        I     Right-hand vector to be multiplied.
C       NC1       I     Column dimension of M1 and length of VOUT.
C       NR1R2     I     Row dimension of M1 and length of V2.
C       VOUT      O     Product vector M1**T * V2.
C                       VOUT must NOT overwrite either M1 or V2.
C
C$ Detailed_Input
C
C      M1      This is a double precision matrix of arbitrary size whose
C              transpose forms the left-hand matrix of the
C              multiplication.
C
C      V2      This is a double precision vector on the right of the
C              multiplication.
C
C      NC1     This is the column dimension of M1 and length of VOUT.
C
C      NR1R2   This is the row dimension of M1 and length of V2.
C
C$ Detailed_Output
C
C      VOUT    This is the double precision vector which results from
C              the expression
C
C                         T
C              VOUT = (M1)  x V2
C
C              where the T denotes the transpose of M1.
C
C$ Parameters
C
C     None.
C
C$ Particulars
C
C      The code reflects precisely the following mathematical expression
C
C      For each value of the subscript I from 1 to NC1,
C
C      VOUT(I) = Summation from K=1 to NR1R2 of  ( M1(K,I) * V2(K) )
C
C      Note that the reversal of the K and I subscripts in the left-hand
C      matrix M1 is what makes VOUT the product of the TRANSPOSE of M1
C      and not simply of M1 itself.
C
C      Since this subroutine operates on matrices of arbitrary size, it
C      is not feasible to buffer intermediate results.  Thus, VOUT
C      should NOT overwrite either M1 or V2.
C
C$ Examples
C
C                        | 1  2 |
C      Suppose that M1 = | 1  3 |
C                        | 1  4 |
C
C                        | 1 |
C      and that     V2 = | 2 |
C                        | 3 |
C
C      Then calling MTXVG according to the following calling sequence
C
C      CALL MTXVG (M1, V2, 2, 3, VOUT)
C
C      will yield the following vector value for VOUT
C
C      VOUT = | 6  |
C             | 20 |
C
C$ Restrictions
C
C      1) The user is responsible for checking the magnitudes of the
C      elements of M1 and V2 so that a floating point overflow does
C      not occur.
C      2) VOUT not overwrite M1 or V2 or else the intermediate
C      will affect the final result.
C
C$ Exceptions
C
C      Error free.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      W.M. Owen       (JPL)
C
C$ Literature_References
C
C      None.
C
C$ Version
C
C-     SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C         Comment section for permuted index source lines was added
C         following the header.
C
C-     SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     matrix_transpose times n-dimensional vector
C
C-&

C
C     Local variables
C
      DOUBLE PRECISION SUM
      INTEGER          I,K

C
C  Perform the matrix-vector multiplication
C
      DO I = 1, NC1

         SUM = 0.D0

         DO K = 1, NR1R2
            SUM = SUM + M1(K,I)*V2(K)
         END DO

         VOUT(I) = SUM

      END DO

      RETURN
      END


SUBROUTINE rod_mm(mm,length)
!
! This subroutine forms the consistent mass matrix of a 1-d "rod" element.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),intent(in)::length
 REAL(iwp),intent(out)::mm(:,:)
 REAL(iwp)::one=1.0_iwp,d3=3.0_iwp,d6=6.0_iwp
 mm(1,1)=one/d3
 mm(1,2)=one/d6
 mm(2,1)=one/d6
 mm(2,2)=one/d3
 mm=mm*length
RETURN
END SUBROUTINE rod_mm


      SUBROUTINE shape3(deriv,shape,s,t,nnode )
      !********************************************************************
      !
      !***  calculates shape functions and their derivatives for 2d elements
      !
      !********************************************************************
      IMPLICIT NONE
      INTEGER (kind=4) :: nnode
      REAL (kind=8)    deriv(nnode,2),shape(nnode),s,t
      REAL (kind=8)    st

      st = s*t

      IF (nnode == 4) THEN

         !  shape functions for 4 noded element

         shape(1) = (1D0 - s - t + st)/4D0
         shape(2) = (1D0 + s - t - st)/4D0
         shape(3) = (1D0 + s + t + st)/4D0
         shape(4) = (1D0 - s + t - st)/4D0

         ! and derivatives

         deriv(1,1) = (-1d0 + t)/4d0
         deriv(2,1) = -deriv(1,1)
         deriv(3,1) = ( 1d0 + t)/4d0
         deriv(4,1) = -deriv(3,1)
         deriv(1,2) = (-1d0 + s)/4d0
         deriv(2,2) = (-1d0 - s)/4d0
         deriv(3,2) = -deriv(2,2)
         deriv(4,2) = -deriv(1,2)

      ELSE IF (nnode == 3) THEN

         !  shape functions for 3-node element

         shape(1) = 1.d0 - s - t
         shape(2) = s
         shape(3) = t

         !  and derivatives

         deriv(1,1) = -1.d0
         deriv(1,2) = -1.d0
         deriv(2,1) =  1.d0
         deriv(2,2) =  0.d0
         deriv(3,1) =  0.d0
         deriv(3,2) =  1.d0

      END IF

      END SUBROUTINE shape3


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
subroutine gaussian_random_number(x1,x2)
  implicit none
  real(8),parameter :: pi = 4d0*atan(1d0)
  real(8), intent(out) :: x1,x2
  real(8) :: r1,r2,tmp

  call random_number(r1)
  call random_number(r2)

  if(r1 == 0d0)then
    x1 = 0d0
    x2 = 0d0
  else
    tmp = sqrt(-2d0*log(r1))
    x1 = tmp*cos(2d0*pi*r2)
    x2 = tmp*sin(2d0*pi*r2)
  end if
  return
end subroutine gaussian_random_number


PROGRAM menxb

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:10

!       =========================================================
!       Purpose: This program computes the exponential integral
!                En(x) using subroutine ENXB
!       Example: x = 10.0
!                   n         En(x)
!                 ----------------------
!                   0     .45399930D-05
!                   1     .41569689D-05
!                   2     .38302405D-05
!                   3     .35487626D-05
!                   4     .33041014D-05
!                   5     .30897289D-05
!       =========================================================

IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION en(0:100)
WRITE(*,*)'Please enter n and x '
!        READ(*,*)N,X
n=5
x=10.0
WRITE(*,20)n,x
WRITE(*,*)
WRITE(*,*)'   n         En(x)'
WRITE(*,*)' ----------------------'
CALL enxb(n,x,en)
DO  k=0,n
  WRITE(*,30)k,en(k)
END DO
20      FORMAT(5X,i3,',   ','x=',f5.1)
30      FORMAT(2X,i3,d18.8)
END PROGRAM menxb

SUBROUTINE enxb(n,x,en)

!       ===============================================
!       Purpose: Compute exponential integral En(x)
!       Input :  x --- Argument of En(x)
!                n --- Order of En(x)  (n = 0,1,2,...)
!       Output:  EN(n) --- En(x)
!       ===============================================

INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN)             :: x
DOUBLE PRECISION, INTENT(OUT)            :: en(0:n)
IMPLICIT DOUBLE PRECISION (a-h,o-z)

IF (x == 0.0) THEN
  en(0)=1.0D+300
  en(1)=1.0D+300
  DO  k=2,n
    en(k)=1.0D0/(k-1.0)
  END DO
  RETURN
ELSE IF (x <= 1.0) THEN
  en(0)=DEXP(-x)/x
  DO  l=1,n
    rp=1.0D0
    DO  j=1,l-1
      rp=-rp*x/j
    END DO
    ps=-0.5772156649015328D0
    DO  m=1,l-1
      ps=ps+1.0D0/m
    END DO
    ens=rp*(-DLOG(x)+ps)
    s=0.0D0
    DO  m=0,20
      IF (.NOT.(m == l-1)) THEN
        r=1.0D0
        DO  j=1,m
          r=-r*x/j
        END DO
        s=s+r/(m-l+1.0D0)
        IF (DABS(s-s0) < DABS(s)*1.0D-15) EXIT
        s0=s
      END IF
    END DO
    35            en(l)=ens-s
  END DO
ELSE
  en(0)=DEXP(-x)/x
  m=15+INT(100.0/x)
  DO  l=1,n
    t0=0.0D0
    DO  k=m,1,-1
      t0=(l+k-1.0D0)/(1.0D0+k/(x+t0))
    END DO
    t=1.0D0/(x+t0)
    en(l)=DEXP(-x)*t
  END DO
END IF
END SUBROUTINE enxb


program factorial

      implicit none
      integer :: n
      integer :: nmax
      integer :: fact

      fact = 1
      nmax = 10

      ! compute factorial version 1
      do n = 1, nmax
          fact = fact * n;
      end do
      print *, "Version 1. Factorial of ", nmax, "is:    ", fact

      fact = 1
      n    = 1
      do while(n <= nmax)
          fact = fact * n;
          print *, "n = ", n, "  ", "factorial = ", fact
          n = n + 1
      end do

end program factorial


module special_functions
  use numerical_constants
  implicit none

contains
  subroutine gen_assoc_legendre_pol(x_pts, n_pts, lmax, alp)
    implicit none
    integer, intent(in) :: n_pts, lmax
    real(kind=dp), intent(in) :: x_pts(n_pts)
    real(kind=dp), intent(out) :: alp(n_pts, 0:lmax, -lmax:lmax)
    integer :: l, m, fact(lmax)

    call calc_factorials(lmax, fact)

    alp(:, 0, 0) = 1.0d0
    do l=1,lmax
        alp(:,l,l-1)=x_pts*(2.0d0*(l-1.0d0)+1.0d0)*alp(:,l-1,l-1)
        alp(:,l,-l+1)=(-1)**(l-1)*alp(:,l,l-1)/fact(l+l-1)  !m=l-1
        alp(:,l,l)=-(2.0d0*(l-1.0d0)+1.0d0)*sqrt(1.d0-x_pts*x_pts)*alp(:,l-1,l-1)
        alp(:,l,-l)=(-1)**l*alp(:,l,l)/fact(l+l)
        do m=l-2,1,-1
            alp(:,l,m)=(x_pts*(2*l-1)*alp(:,l-1,m)-(l+m-1)*alp(:,l-2,m))/float(l-m)
            alp(:,l,-m)=(-1)**m*fact(l-m)*alp(:,l,m)/fact(l+m)
        end do
        alp(:,l,0)=(x_pts*(2*l-1)*alp(:,l-1,0)-(l-1)*alp(:,l-2,0))/float(l)
    end do
  end subroutine gen_assoc_legendre_pol

  subroutine calc_factorials(nmax, fact)
    implicit none
    integer, intent(in) :: nmax
    integer, intent(out) :: fact(nmax)
    integer :: i

    fact(0) = 1
    do i=1,nmax
       fact(i) = fact(i-1)*i
    end do

  end subroutine calc_factorials
end module special_functions