! This program will numerically compute the integral of
!                  4/(1+x*x)
! from 0 to 1.  The value of this integral is pi -- which
! is great since it gives us an easy way to check the answer.

! The program was parallelized using OpenMP by adding just
! four lines

! (1) A line to include omp.h -- the include file that
! contains OpenMP's function prototypes and constants.

! (2) A pragma that tells OpenMP to create a team of threads

! (3) A pragma to cause one of the threads to print the
! number of threads being used by the program.

! (4) A pragma to split up loop iterations among the team
! of threads.  This pragma includes 2 clauses to (1) create a
! private variable and (2) to cause the threads to compute their
! sums locally and then combine their local sums into a
! single global value.

! History: C Code written by Tim Mattson, 11/1999.
!          Adapted to Fortran code by Helen He, 09/2017.
!          Changed to Fortran90 code by Helen He, 11/2020.

  PROGRAM MAIN
  USE OMP_LIB
  IMPLICIT NONE

  INTEGER :: i
  INTEGER*8 :: num_steps
  REAL*8 :: error
  INTEGER, PARAMETER :: NSTEPS=100000000
  REAL*8, PARAMETER :: REAL_PI = 3.1415926535897932
  REAL*8 :: x, pi, sum, step
  REAL*8 :: start_time, run_time

  CALL OMP_SET_NUM_THREADS(4)

  num_steps = 1
  DO WHILE  (num_steps < NSTEPS)
     step = 1.0 / num_steps

     sum = 0.0
!$OMP PARALLEL DO REDUCTION(+:sum) PRIVATE(x)
     DO i = 1, num_steps
        x = (i - 0.5) * step
        sum = sum + 4.0 / (1.0 + x*x)
     ENDDO
!$OMP END PARALLEL DO

     pi = step * sum
     error = ABS(pi - REAL_PI)

     WRITE(*,100) 1.0*num_steps, pi, error
100  FORMAT(f20.6, f15.8, e15.7)

    num_steps = 10 * num_steps
    ENDDO

    END PROGRAM MAIN


! $UWHPSC/codes/fortran/circles/circle_mod.f90

module circle_mod

    implicit none
    real(kind=8), parameter :: pi = 3.141592653589793d0

contains

    real(kind=8) function area(r)
        real(kind=8), intent(in) :: r
        area = pi * r**2
    end function area

    real(kind=8) function circumference(r)
        real(kind=8), intent(in) :: r
        circumference = 2.d0 * pi * r
    end function circumference

end module circle_mod


program poisson1D
    implicit none
    integer :: x, t, tMax, old, new, temp
    integer, parameter :: nx = 100
    real :: w0(0:2), w1(0:2), k, tau, omega, alpha, D, dx, c, uA, dt
    real :: u(0:nx), f(0:nx,0:2,2), feq(0:nx,0:2)
    old = 1
    new = 2

    ! weighting factors
    w0(0:2) = (/2./3.,1./6.,1./6./)
    w1(0:2) = (/0.0,0.5,0.5/)

    ! number of nodes and timesteps
    dx = 1.0/real(nx)
    c = 1.0
    dt = dx/c
    tMax = 1000000

    ! coefficient
    k = 27.79

    ! relaxation time
    tau = 1.0
    omega = 1.0/tau

    ! artificial diffusion coefficient
    alpha = 1./3.
    D = alpha*c**2*(0.5-tau)*dt

    !----------------------------------------------------

    ! initial condition
    u(0:nx) = 0.0
    u(0)    = 1.0
    u(nx)   = 1.0

    ! initialize to equilibrium
    f(0:nx,0,old) = (w0(0)-1.0)*u(0:nx)
    f(0:nx,1,old) = w0(1)*u(0:nx)
    f(0:nx,2,old) = w0(2)*u(0:nx)

    do t = 1, tMax

        ! macroscopic variable
        u(0:nx) = (f(0:nx,1,old)+f(0:nx,2,old))/(1.0-w0(0))

        ! equilibrium-
        feq(0:nx,0) = (w0(0)-1.0)*u(0:nx)
        feq(0:nx,1) = w0(1)*u(0:nx)
        feq(0:nx,2) = w0(2)*u(0:nx)

        ! streaming + collision
        f(0:nx,0,new)   = (1-omega)*f(0:nx,0,old) + omega*feq(0:nx,0)
        f(1:nx,1,new)   = (1-omega)*f(0:nx-1,1,old) + omega*feq(0:nx-1,1) + dt*D*w1(1)*k**2*u(0:nx-1)
        f(0:nx-1,2,new) = (1-omega)*f(1:nx,2,old) + omega*feq(1:nx,2) + dt*D*w1(2)*k**2*u(1:nx)

        ! boundaries
        f(0,1,new)  = w0(1)*1.0 + (1-omega)*(f(1,1,new)  - feq(1,1))
        f(nx,2,new) = w0(2)*1.0 + (1-omega)*(f(nx-1,2,new) - feq(nx-1,2))

        temp = old
        old = new
        new = temp

    end do

    open(10,file="results.dat")

    do x = 0, nx
        write(10,*) x*dx, u(x), uA(real(x)*dx,k)
    end do

    close(10)

end program

function uA(x,k)
    implicit none
    real:: uA, x, k

    uA = (exp(k)-1.0)/(exp(k)-exp(-k))*exp(-k*x) + &
       & (1.0-exp(-k))/(exp(k)-exp(-k))*exp(k*x)

end function uA


program average

! Read in some numbers and take the average
! As written, if there are no data points, an average of zero is returned
! While this may not be desired behavior, it keeps this example simple

  implicit none
  integer :: number_of_points
  real, dimension(:), allocatable :: points
  real :: average_points=0., positive_average=0., negative_average=0.

  write (*,*) "Input number of points to average:"
  read (*,*) number_of_points

  allocate (points(number_of_points))

  write (*,*) "Enter the points to average:"
  read (*,*) points

! Take the average by summing points and dividing by number_of_points
  if (number_of_points > 0) average_points = sum(points)/number_of_points

! Now form average over positive and negative points only
  if (count(points > 0.) > 0) positive_average = sum(points, points > 0.) &
        /count(points > 0.)
  if (count(points < 0.) > 0) negative_average = sum(points, points < 0.) &
        /count(points < 0.)

  deallocate (points)

! Print result to terminal
  write (*,'(''Average = '', 1g12.4)') average_points
  write (*,'(''Average of positive points = '', 1g12.4)') positive_average
  write (*,'(''Average of negative points = '', 1g12.4)') negative_average

end program average


      FUNCTION dawson(x)
      INTEGER NMAX
      REAL dawson,x,H,A1,A2,A3
      PARAMETER (NMAX=6,H=0.4,A1=2./3.,A2=0.4,A3=2./7.)
      INTEGER i,init,n0
      REAL d1,d2,e1,e2,sum,x2,xp,xx,c(NMAX)
      SAVE init,c
      DATA init/0/
      if(init.eq.0)then
        init=1
        do 11 i=1,NMAX
          c(i)=exp(-((2.*float(i)-1.)*H)**2)
11      continue
      endif
      if(abs(x).lt.0.2)then
        x2=x**2
        dawson=x*(1.-A1*x2*(1.-A2*x2*(1.-A3*x2)))
      else
        xx=abs(x)
        n0=2*nint(0.5*xx/H)
        xp=xx-float(n0)*H
        e1=exp(2.*xp*H)
        e2=e1**2
        d1=float(n0+1)
        d2=d1-2.
        sum=0.
        do 12 i=1,NMAX
          sum=sum+c(i)*(e1/d1+1./(d2*e1))
          d1=d1+2.
          d2=d2-2.
          e1=e2*e1
12      continue
        dawson=0.5641895835*sign(exp(-xp**2),x)*sum
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/dawson.for


subroutine CalcEnergy(Pos, PEnergy, Dim, NAtom)
    implicit none
    integer, intent(in) :: Dim, NAtom
    real(8), intent(in), dimension(0:NAtom-1, 0:Dim-1) :: Pos
    real(8), intent(out) :: PEnergy
    real(8), dimension(Dim) :: rij, Posi
    real(8) :: d2, id2, id6, id12
    real(8) :: alpha
    integer :: i, j
    !alpha varies with system size
    alpha = 0.0001 * dble(NAtom)**(-2./3.)
    PEnergy = 0.
    do i = 0, NAtom - 1
        !store Pos(i,:) in a temporary array for faster access in j loop
        Posi = Pos(i,:)
        do j = i + 1, NAtom - 1
            rij = Pos(j,:) - Posi
            d2 = sum(rij * rij)
            id2 = 1. / d2            !inverse squared distance
            id6 = id2 * id2 * id2    !inverse sixth distance
            id12 = id6 * id6         !inverse twelvth distance
            PEnergy = PEnergy + 4. * (id12 - id6)
        enddo
        !compute the single-body term
        PEnergy = PEnergy + alpha * sum(Posi * Posi)
    enddo
end subroutine

subroutine CalcForces(Pos, Forces, Dim, NAtom)
    implicit none
    integer, intent(in) :: Dim, NAtom
    real(8), intent(in), dimension(0:NAtom-1, 0:Dim-1) :: Pos
    real(8), intent(out), dimension(0:NAtom-1, 0:Dim-1) :: Forces
    real(8), dimension(Dim) :: rij, Fij, Posi
    real(8) :: d2, id2, id6, id12
    real(8) :: alpha
    integer :: i, j
    !alpha varies with system size
    alpha = 0.0001 * dble(NAtom)**(-2./3.)
    Forces = 0.
    do i = 0, NAtom - 1
        !store Pos(i,:) in a temporary array for faster access in j loop
        Posi = Pos(i,:)
        do j = i + 1, NAtom - 1
            rij = Pos(j,:) - Posi
            d2 = sum(rij * rij)
            id2 = 1. / d2            !inverse squared distance
            id6 = id2 * id2 * id2    !inverse sixth distance
            id12 = id6 * id6         !inverse twelvth distance
            Fij = rij * ((-48. * id12 + 24. * id6) * id2)
            Forces(i,:) = Forces(i,:) + Fij
            Forces(j,:) = Forces(j,:) - Fij
        enddo
        !compute the single-body term
        Forces(i,:) = Forces(i,:) - 2. * alpha *Posi
    enddo
end subroutine

subroutine CalcEnergyForces(Pos, PEnergy, Forces, Dim, NAtom)
    implicit none
    integer, intent(in) :: Dim, NAtom
    real(8), intent(in), dimension(0:NAtom-1, 0:Dim-1) :: Pos
    real(8), intent(out) :: PEnergy
    real(8), intent(out), dimension(0:NAtom-1, 0:Dim-1) :: Forces
    real(8), dimension(Dim) :: rij, Fij, Posi
    real(8) :: d2, id2, id6, id12
    real(8) :: alpha
    integer :: i, j
    !alpha varies with system size
    alpha = 0.0001 * dble(NAtom)**(-2./3.)
    PEnergy = 0.
    Forces = 0.
    do i = 0, NAtom - 1
        !store Pos(i,:) in a temporary array for faster access in j loop
        Posi = Pos(i,:)
        do j = i + 1, NAtom - 1
            rij = Pos(j,:) - Posi
            d2 = sum(rij * rij)
            id2 = 1. / d2            !inverse squared distance
            id6 = id2 * id2 * id2    !inverse sixth distance
            id12 = id6 * id6         !inverse twelvth distance
            PEnergy = PEnergy + 4. * (id12 - id6)
            Fij = rij * ((-48. * id12 + 24. * id6) * id2)
            Forces(i,:) = Forces(i,:) + Fij
            Forces(j,:) = Forces(j,:) - Fij
        enddo
        !compute the single-body term
        PEnergy = PEnergy + alpha * sum(Posi * Posi)
        Forces(i,:) = Forces(i,:) - 2. * alpha *Posi
    enddo
end subroutine


implicit real*4(a-h, o-z) ! The pppack is in single precision

real tau(201), c(4, 201)
f(x) = exp(x)*sin(x)
fderiv(x) = exp(x) * (sin(x) + cos(x))
ibcbeg = 2 ! Natural Cubic Spline
ibcend = 2
a = 0.0 ! Starting point
b = 2.0 ! End point

write(*,*) '-- Enter Number of SubIntervals --' ! ’ -- Enter Number of SubIntervals --’

read(*,*) N
h = (b-a)/N ! h is the length of the subinterval

do i = 1, N+1
    tau(i) = a + (i-1)*h
    c(1, i) = f(tau(i))
enddo

c(2,1) = 0.0 ! Natural Cubic Spline
c(2,N+1) = 0.0 ! Natural Cubic Spline
call cubspl(tau, c, N, ibcbeg, ibcend)

! Using the coefficient computed above, we actually
! evaluate function values
! at mid-points and compare with the exact values.
k = 4
jderiv = 0 ! Compute the 0-th derivative, i.e,
! The function values.

do i= 1, N-1
    x = a + (i+0.5)*h ! At the mid-point of the subintervals.
    y = f(x) ! The Exact Value
    y2 = ppvalu(tau, c, N, k, x, jderiv) ! Cubic Spline Value
    d = ABS(y2 - y)
    write(*,*) ' Value at x = ', x, y, y2 , d !’ Value at x = ’, x, y, y2
enddo

write(*,*) '-- Derivatives --' ! ’ -- Derivatives --’

k = 4
jderiv = 1 ! Compute the 1-th derivative, i.e,
! The first-derivative values.
do i= 1, N-1
    x = a + (i+0.5)*h ! At the mid-point of the subintervals.
    y = fderiv(x) ! The Exact Value
    y2 = ppvalu(tau, c, N, k, x, jderiv) ! Cubic Spline Value
    d = ABS(y2 - y)
    write(*,*) ' Value at x = ', x, y, y2 ,d !
enddo

read(*,*)

stop
end


*
* squares - Print a table of squares from 1 to 10
*
*  Written by: C. Severance 16Mar92
*
* Declare the variables:
*
      INTEGER I
      REAL X,XSQ
*
* Generate the table using a DO LOOP
*
      PRINT *,'The first table'
      DO I=1,10
        X = I
        XSQ = X ** 2
        PRINT *,I,XSQ
      ENDDO
*
* Print out the table a different way - Use a real number for the index
*
      PRINT *,'The second table'
      DO X=1.0,10.0
        XSQ = X ** 2
        PRINT *,X,XSQ
      ENDDO
      END


subroutine poisson(n)
! solves the poisson equation nabla^2 psi = -vort using the Jacobi method with successive over-relaxation (SOR)

!Jacobi method: psi(i,j,n+1) = 1/4( psi(i-1,j,n) + psi(i+1,j,n) + psi(i,j-1,n) + psi(i,j+1,n) + vort(i,j) )
! SOR: psi(n+1) = (1-w)*psi(n) + w*JacobiRHS

! First, the grid is split up into a chessboard, depending on whether i+j is even or odd
! Next the Jacobi SOR method is applied to even squares (using the odd squares to update even squares)
! Then the Jacobi SOR method is applied to odd squares (using the updated values of the even squares)

    use vars
    use parallel
    implicit none

    integer :: n, it
    integer :: i, j

    real :: w !successive over-relaxation parameter

    w=1./(1+pi/nx_global) !optimal value of w

    do it=1,n
        !! old Jacobi method
        ! !$OMP DO PRIVATE(j)
        ! do j=0,ny+1
        !     psidum(:,j) = psi(:,j)
        ! enddo
        ! !$OMP END DO

        ! !$OMP DO PRIVATE(i,j)
        ! do j=1,ny
        !     do i=1,nx
        !         if (mask(i,j) .eq. 0) then
        !             psi(i,j) = (psidum(i-1,j) + psidum(i+1,j))*dy*dy &
        !                  + (psidum(i,j-1)+psidum(i,j+1))*dx*dx +dx*dx*dy*dy*vort(i,j)
        !             psi(i,j) = psi(i,j)/2./(dx*dx+dy*dy)
        !         endif
        !     enddo
        ! enddo
        ! !$OMP END DO

        !update even squares
        !$OMP DO PRIVATE(i,j)
        do j=1,ny
            do i=1,nx
                if (mask(i,j) .eq. 0) then
                    if (mod(i+j,2) .eq. 0) then
                        psi(i,j) = (1-w)*psi(i,j) +w*( (psi(i-1,j) + psi(i+1,j))*dy*dy &
                             + (psi(i,j-1)+psi(i,j+1))*dx*dx +dx*dx*dy*dy*vort(i,j) ) &
                             /2./(dx*dx+dy*dy)
                    endif
                endif
            enddo
        enddo
        !$OMP END DO

         !$OMP SINGLE
         call haloswap(psi)
         !$OMP END SINGLE
         !$OMP BARRIER

        !update odd squares
        !$OMP DO PRIVATE(i,j)
        do j=1,ny
            do i=1,nx
                if (mask(i,j) .eq. 0) then
                    if (mod(i+j,2) .eq. 1) then
                        psi(i,j) = (1-w)*psi(i,j) +w*( (psi(i-1,j) + psi(i+1,j))*dy*dy &
                             + (psi(i,j-1)+psi(i,j+1))*dx*dx +dx*dx*dy*dy*vort(i,j) ) &
                             /2./(dx*dx+dy*dy)
                    endif
                endif
            enddo
        enddo
        !$OMP END DO

        !apply right boundary condition
        !$OMP DO PRIVATE(j)
        do j=1,ny
            psi(nx+1,j) = 2.*psi(nx,j) - psi(nx-1,j)
        enddo
        !$OMP END DO

        !$OMP SINGLE
        call haloswap(psi)
        !apply top/bottom boundary conditions
        if (down .eq. MPI_PROC_NULL) psi(:,0) = 2*psi(:,1) - psi(:,2)
        if (up .eq. MPI_PROC_NULL) psi(:,ny+1) = 2*psi(:,ny) - psi(:,ny-1)
        !$OMP END SINGLE
        !$OMP BARRIER

    enddo

end subroutine


program multipole_moment
  use special_functions
  use numerical_integration
  integer, parameter :: num_theta_pts = 101, num_phi_pts = 101, num_r_pts = 101, lmax=4
  real(kind=dp) :: alp(num_theta_pts, 0:lmax,-lmax:lmax), theta_pts(num_theta_pts), dtheta, dphi
  real(kind=dp) :: fac, phi, r_pts(num_r_pts), rho_pts(num_r_pts), r_cutoff, dr, phi_pts(num_phi_pts)
  real(kind=dp) :: re_integral, im_integ, re_phi_integ(num_r_pts, num_theta_pts), re_theta_integ(num_r_pts)
  integer :: i, j, k, l, m, fact(2*lmax)
  complex(kind=dp) :: spha_ylm(num_theta_pts, num_phi_pts), integrand(num_r_pts, num_theta_pts, num_phi_pts)
  complex(kind=dp) :: integral

  dtheta = pi/(num_theta_pts-1)
  dphi = 2*pi/(num_phi_pts-1)
  theta_pts = [ (-pi/2 + i*dtheta, i=0, num_theta_pts-1) ]
  r_cutoff = 10.0d0
  dr = r_cutoff/(num_r_pts-1)
  r_pts = [ (i*dr, i=0, num_r_pts-1) ]
  phi_pts = [(i*dphi, i=0, num_phi_pts-1)]
  rho_pts= 1.0d0
  l=2
  m=0

  call calc_factorials(2*lmax, fact)
  call gen_assoc_legendre_pol(cos(theta_pts), num_theta_pts, lmax, alp)

  do i=0,num_phi_pts-1
    phi = i*dphi
    fac=dsqrt((2*l+1)*fact(l-m)/(4.0d0*pi*fact(l+m)))
    spha_ylm(:,i)=fac*alp(:,l,m)*cmplx(cos(m*phi),sin(m*phi))
  end do

  do i=1,num_r_pts
     do j=1,num_theta_pts
        do k=1,num_phi_pts
            integrand(i, j, k) = r_pts(i)**(l+2)*conjg(spha_ylm(j,k))*rho_pts(i)*sin(theta_pts(j))*dr*dtheta*dphi
        end do
     end do
  end do

  do i=1,num_r_pts
    do j=1,num_theta_pts
        re_phi_integ(i,j) = simpson(phi_pts, real(integrand(i,j,:)), num_phi_pts)
    end do
    re_theta_integ(i) = simpson(theta_pts, re_phi_integ(i, :), num_theta_pts)
  end do
  re_integral = simpson(r_pts, re_theta_integ(:), num_r_pts)

  print*, re_integral

  ! do i=1,num_theta_pts
  !    do j=1,num_phi_pts
  !   print '(5f10.4)', theta_pts(i), (j-1)*dphi,  spha_ylm(i,j)%re, spha_ylm(i,j)%im, abs(spha_ylm(i, j))
  !    end do
  ! end do
end program multipole_moment


!=====================================================================!
! Module that contains handy linear algebra operations using LAPACK.
!=====================================================================!

module linear_algebra

  ! import dependencies
  use iso_fortran_env, only : dp => REAL64

  use lapack, only: dsyevd, dsygvd, ilaenv, zgetri, zgetrf, zheevd, &
                    dgeev , zgeev , zhegvd, dgesv , zgesv , dgetrf, &
                    dgetri, dgelsy, zgelsy, dgesvd, zgesvd

  ! disable implicit datatypes
  implicit none

  ! restrict access to all functions
  private

  ! expose only a required functions
  public :: eig, eigvals, eigh                ! eigenvals and vec
  public :: inv, solve, lstsq, svdvals, svd   ! linear system
  public :: det, eye, diag, trace, triu       !, tril ! matrix utils
  public :: assert, stop_error                ! misc

  public :: fwdsub, backsub

  ! Classical Iterative solvers
  public :: dsor, djacobi, dseidel

  ! Sophisticated Iterative solvers
  public :: dcg, dpcg, dsd

  ! Solvers for non-symmetric systems
  public :: dcgnr, dcgne

  ! Module parameters
  complex(dp), parameter :: i_ = (0, 1)

  !===================================================================!
  ! Eigen interfaces
  !===================================================================!

  ! eigenvalue/-vector problem for general matrices:
  interface eig
     module procedure deig
     module procedure zeig
  end interface eig

  ! eigenvalue/-vector problem for real symmetric/complex hermitian
  ! matrices:
  interface eigh
     module procedure deigh_generalized
     module procedure deigh_simple
     module procedure zeigh_generalized
     module procedure zeigh_simple
  end interface eigh

  ! eigenvalues for general matrices:
  interface eigvals
     module procedure deigvals
     module procedure zeigvals
  end interface eigvals

  !===================================================================!
  ! Linear solve interfaces
  !===================================================================!

  ! matrix inversion for real/complex matrices:
  interface inv
     module procedure dinv
     module procedure zinv
  end interface inv

  ! solution to linear systems of equation with real/complex
  ! coefficients:
  interface solve
     module procedure dsolve
     module procedure zsolve
  end interface solve

  ! least square solutions the real/complex systems of equations of
  ! possibly non-square shape:
  interface lstsq
     module procedure dlstsq
     module procedure zlstsq
  end interface lstsq

  ! singular values of real/complex matrices:
  interface svdvals
     module procedure dsvdvals
     module procedure zsvdvals
  end interface svdvals

  ! singular value decomposition of real/complex matrices:
  interface svd
     module procedure dsvd
     module procedure zsvd
  end interface svd

  !===================================================================!
  ! Utility interfaces
  !===================================================================!

  ! determinants of real/complex square matrices:
  interface det
     module procedure ddet
     module procedure zdet
  end interface det

  ! construction of square matrices from the diagonal elements:
  interface diag
     module procedure ddiag
     module procedure zdiag
     !module procedure ddiagfrommat
     !module procedure zdiagfrommat
  end interface diag

  ! trace of real/complex matrices:
  interface trace
     module procedure dtrace
     module procedure ztrace
  end interface trace

  ! Upper triangular matrix
  interface triu
     module procedure dtriu
  end interface triu

  ! assert shape of matrices:
  interface assert_shape
     module procedure dassert_shape
     module procedure zassert_shape
  end interface assert_shape

contains

  !-------------------------------------------------------------------!
  ! Solve the linear system using conjugate gradient for minimum
  ! error
  ! -------------------------------------------------------------------!

  subroutine dcgne(A, b, max_it, max_tol, x, iter, tol, flag)

    real(dp), intent(in) :: A(:,:)
    real(dp), intent(in) :: b(:)
    integer , intent(in) :: max_it
    real(dp), intent(in) :: max_tol

    real(dp), intent(inout) :: x(:)
    integer , intent(out)   :: iter
    real(dp), intent(out)   :: tol
    integer , intent(out)   :: flag

    ! Solve the new system AA^T y = b ; x = A^T y
    call dcg(matmul(A, transpose(A)), b, max_it, &
         & max_tol, x, iter, tol, flag)
    x = matmul(transpose(A), x)

  end subroutine dcgne

  !-------------------------------------------------------------------!
  ! Solve the linear system using conjugate gradient for minimum
  ! residual
  ! -------------------------------------------------------------------!

  subroutine dcgnr(A, b, max_it, max_tol, x, iter, tol, flag)

    real(dp), intent(in) :: A(:,:)
    real(dp), intent(in) :: b(:)
    integer , intent(in) :: max_it
    real(dp), intent(in) :: max_tol

    real(dp), intent(inout) :: x(:)
    integer , intent(out)   :: iter
    real(dp), intent(out)   :: tol
    integer , intent(out)   :: flag

    ! Solve the new system A^T A x = A^T b
    call dcg(matmul(transpose(A),A), matmul(transpose(A),b), max_it, &
         & max_tol, x, iter, tol, flag)

  end subroutine dcgnr

  !-------------------------------------------------------------------!
  ! Solve the linear system using conjugate gradient method A A^T y = b
  !-------------------------------------------------------------------!

  subroutine dcg(A, b, max_it, max_tol, x, iter, tol, flag)

    real(dp), intent(in) :: A(:,:)
    real(dp), intent(in) :: b(:)
    integer , intent(in) :: max_it
    real(dp), intent(in) :: max_tol

    real(dp), intent(inout) :: x(:)
    integer , intent(out)   :: iter
    real(dp), intent(out)   :: tol
    integer , intent(out)   :: flag

    ! create local data
    real(dp), allocatable :: p(:), r(:), w(:)
    real(dp), allocatable :: rho(:)
    real(dp) :: alpha, beta
    real(dp) :: bnorm, rnorm

    ! Memory allocations
    allocate(r, p, w, mold=x)
    allocate(rho(max_it))

    ! Start the iteration counter
    iter = 1

    ! Norm of the right hand side
    bnorm = norm2(b)

    ! Norm of the initial residual
    r         = b - matmul(A, x)
    rnorm     = norm2(r)
    tol       = rnorm/bnorm
    rho(iter) = rnorm*rnorm

    open(10, file='cg.log', action='write', position='append')

    ! Apply Iterative scheme until tolerance is achieved
    do while ((tol .gt. max_tol) .and. (iter .lt. max_it))

       ! step (a) compute the descent direction
       if ( iter .eq. 1) then
          ! steepest descent direction p
          p = r
       else
          ! take a conjugate direction
          beta = rho(iter)/rho(iter-1)
          p = r + beta*p
       end if

       ! step (b) compute the solution update
       w = matmul(A,p)

       ! step (c) compute the step size for update
       alpha = rho(iter)/dot_product(p, w)

       ! step (d) Add dx to the old solution
       x = x + alpha*p

       ! step (e) compute the new residual
       r = r - alpha*w
       !r = b - matmul(A, x)

       ! step(f) update values before next iteration
       rnorm = norm2(r)
       tol = rnorm/bnorm

       write(10,*) iter, tol
       print *, iter, tol

       iter = iter + 1

       rho(iter) = rnorm*rnorm

    end do

    close(10)

    deallocate(r, p, w, rho)

    flag = 0

  end subroutine dcg

  !-------------------------------------------------------------------!
  ! Solve the linear system using preconditioned conjugate gradient
  ! method
  !-------------------------------------------------------------------!

  subroutine dpcg(A, M, b, max_it, max_tol, x, iter, tol, flag)

    real(dp), intent(in) :: A(:,:)
    real(dp), intent(in) :: M(:,:)
    real(dp), intent(in) :: b(:)
    integer , intent(in) :: max_it
    real(dp), intent(in) :: max_tol

    real(dp), intent(inout) :: x(:)
    integer , intent(out)   :: iter
    real(dp), intent(out)   :: tol
    integer , intent(out)   :: flag

    ! create local data
    real(dp), allocatable :: p(:), r(:), w(:), z(:)
    real(dp), allocatable :: rho(:), tau(:)
    real(dp) :: alpha, beta
    real(dp) :: bnorm, rnorm

    ! Memory allocations
    allocate(r, p, w, z, mold=x)
    allocate(rho(max_it))
    allocate(tau(max_it))

    ! Start the iteration counter
    iter = 1

    ! Norm of the right hand side
    bnorm = norm2(b)

    ! Norm of the initial residual
    r         = b - matmul(A, x)
    rnorm     = norm2(r)
    tol       = rnorm/bnorm
    rho(iter) = rnorm*rnorm

    open(10, file='pcg.log', action='write', position='append')

    ! Apply Iterative scheme until tolerance is achieved
    do while ((tol .gt. max_tol) .and. (iter .lt. max_it))
       ! step (a)
       z = matmul(M,r)

       ! step (b)
       tau(iter) = dot_product(z,r)

       ! step (c) compute the descent direction
       if ( iter .eq. 1) then
          ! steepest descent direction p
          beta = 0.0d0
          p = z
       else
          ! take a conjugate direction
          beta = tau(iter)/tau(iter-1)
          p = z + beta*p
       end if

       ! step (b) compute the solution update
       w = matmul(A,p)

       ! step (c) compute the step size for update
       alpha = tau(iter)/dot_product(p, w)

       ! step (d) Add dx to the old solution
       x = x + alpha*p

       ! step (e) compute the new residual
       r = r - alpha*w
       !r = b - matmul(A, x)

       ! step(f) update values before next iteration
       rnorm = norm2(r)
       tol = rnorm/bnorm

       write(10,*) iter, tol
       print *, iter, tol

       iter = iter + 1

       rho(iter) = rnorm*rnorm

    end do

    close(10)

    deallocate(r, p, w, rho, tau)

    flag = 0

  end subroutine dpcg

  !-------------------------------------------------------------------!
  ! Solve the linear system using conjugate gradient method
  !-------------------------------------------------------------------!

  subroutine dsd(A, b, max_it, max_tol, x, iter, tol, flag)

    real(dp), intent(in) :: A(:,:)
    real(dp), intent(in) :: b(:)
    integer , intent(in) :: max_it
    real(dp), intent(in) :: max_tol

    real(dp), intent(inout) :: x(:)
    integer , intent(out)   :: iter
    real(dp), intent(out)   :: tol
    integer , intent(out)   :: flag

    ! create local data
    real(dp), allocatable :: r(:), w(:)
    real(dp), allocatable :: rho(:)
    real(dp) :: alpha, beta
    real(dp) :: bnorm, rnorm

    stop

    ! Memory allocations
    allocate(r, w, mold=x)
    allocate(rho(max_it))

    ! Start the iteration counter
    iter = 1

    ! Norm of the right hand side
    bnorm = norm2(b)

    ! Norm of the initial residual
    r         = b - matmul(A, x)
    rnorm     = norm2(r)
    tol       = rnorm/bnorm
    rho(iter) = rnorm*rnorm

    open(10, file='sd.log', action='write', position='append')

    ! Apply Iterative scheme until tolerance is achieved
    do while ((tol .gt. max_tol) .and. (iter .lt. max_it))

       ! step (b) compute the solution update
       w = matmul(A,r)

       ! step (c) compute the step size for update using A-norm of the residual
       alpha = rho(iter)/dot_product(r, w)

       ! step (d) Add dx to the old solution
       x = x + alpha*w

       ! step (e) compute the new residual
       r = r - alpha*w
       !r = b - matmul(A, x)

       ! step(f) update values before next iteration
       rnorm = norm2(r)
       tol = rnorm/bnorm

       write(10,*) iter, tol
       print *, iter, tol

       iter = iter + 1

       rho(iter) = rnorm*rnorm

    end do

    close(10)

    deallocate(r, w, rho)

    flag = 0

  end subroutine dsd

  !-------------------------------------------------------------------!
  ! Solve the linear system using classical Jacobi iterations
  !-------------------------------------------------------------------!

  subroutine djacobi(A, b, max_it, max_tol, x, iter, tol, flag)

    real(dp), intent(in) :: A(:,:)
    real(dp), intent(in) :: b(:)
    integer , intent(in) :: max_it
    real(dp), intent(in) :: max_tol

    real(dp), intent(inout) :: x(:)
    integer , intent(out)   :: iter
    real(dp), intent(out)   :: tol
    integer , intent(out)   :: flag

    real(dp), allocatable :: D(:,:), L(:,:), U(:,:)
    real(dp), allocatable :: c(:), xnew(:)
    real(dp):: init_norm
    integer :: nrows, ncols, i, j

    nrows = size(A(:,1))
    ncols = size(A(1,:))

    allocate(D, L, U, source=A)
    D = 0.0d0
    L = 0.0d0
    U = 0.0d0

    allocate(c(nrows),xnew(nrows))
    c = 0.0d0
    xnew = 0.0d0

    ! Split matrix A = D-L-U
    do j = 1, ncols
       do i = 1, nrows
          if (i .eq. j) then
             D(i,j) = A(i,j)
          else if (i .gt. j) then
             L(i,j) = -A(i,j)
          else
             U(i,j) = -A(i,j)
          end if
       end do
    end do

    ! Apply Iterative scheme until tolerance is achieved
    tol = huge(0.0d0)
    iter = 0

    open(10, file='jacobi.log', action='write',position='append')

    do while ((tol .gt. max_tol) .and. (iter .lt. max_it))

       !xnew = solve(D, b + matmul(L+U, x))
       ! Gauss Jacobi
       c = b + matmul(L+U, x)
       do i = 1, nrows
          xnew(i) = c(i)/D(i,i)
       end do
       !call backsub(D, c, xnew, flag)

       ! Compute norms and increment iteration
       tol = norm2(xnew-x)

       x = xnew

       write(10,*) iter, tol
       !print *, iter, tol

       iter = iter + 1

    end do

    close(10)

    flag = 0

    deallocate(D, L, U, c)

  end subroutine djacobi

  subroutine dseidel(A, b, omega, max_it, max_tol, x, iter, tol, flag)

    real(dp), intent(in) :: A(:,:)
    real(dp), intent(in) :: b(:)
    real(dp), intent(in) :: omega
    integer , intent(in) :: max_it
    real(dp), intent(in) :: max_tol

    real(dp), intent(inout) :: x(:)
    integer , intent(out)   :: iter
    real(dp), intent(out)   :: tol
    integer , intent(out)   :: flag

    real(dp), allocatable :: D(:,:), L(:,:), U(:,:)
    real(dp), allocatable :: c(:), xnew(:)

    integer :: nrows, ncols, i, j

    nrows = size(A(:,1))
    ncols = size(A(1,:))

    allocate(D, L, U, source=A)
    D = 0.0d0
    L = 0.0d0
    U = 0.0d0

    allocate(c(nrows),xnew(nrows))
    c = 0.0d0
    xnew = 0.0d0

    ! Split matrix A = D - L - U
    do j = 1, ncols
       do i = 1, nrows
          if (i .eq. j) then
             D(i,j) = A(i,j)
          else if (i .gt. j) then
             L(i,j) = -A(i,j)
          else
             U(i,j) = -A(i,j)
          end if
       end do
    end do

    ! Apply Iterative scheme until tolerance is achieved
    tol = huge(0.0d0)
    iter = 0

    open(10, file='seidel.log', action='write',position='append')

    do while ((tol .gt. max_tol) .and. (iter .lt. max_it))

       ! Gauss Seidel/SOR Iteration
       c = b + matmul(U, x)
       call fwdsub(D-L, c, xnew, flag)

       ! Compute norms and increment iteration
       tol = norm2(xnew-x)

       x = xnew

       write(10,*) iter, tol

       !print *, iter, tol

       iter = iter + 1

    end do

    close(10)

    flag = 0

    deallocate(D, L, U, c)

  end subroutine dseidel

  subroutine dsor(A, b, omega, max_it, max_tol, x, iter, tol, flag)

    real(dp), intent(in) :: A(:,:)
    real(dp), intent(in) :: b(:)
    real(dp), intent(in) :: omega
    integer , intent(in) :: max_it
    real(dp), intent(in) :: max_tol

    real(dp), intent(inout) :: x(:)
    integer , intent(out)   :: iter
    real(dp), intent(out)   :: tol
    integer , intent(out)   :: flag

    real(dp), allocatable :: D(:,:), L(:,:), U(:,:)
    real(dp), allocatable :: c(:), xnew(:)

    integer :: nrows, ncols, i, j

    nrows = size(A(:,1))
    ncols = size(A(1,:))

    allocate(D, L, U, source=A)
    D = 0.0d0
    L = 0.0d0
    U = 0.0d0

    allocate(c(nrows),xnew(nrows))
    c = 0.0d0
    xnew = 0.0d0

    ! Split matrix A = D - L - U
    do j = 1, ncols
       do i = 1, nrows
          if (i .eq. j) then
             D(i,j) = A(i,j)
          else if (i .gt. j) then
             L(i,j) = -A(i,j)
          else
             U(i,j) = -A(i,j)
          end if
       end do
    end do

    ! Apply Iterative scheme until tolerance is achieved
    tol = huge(0.0d0)
    iter = 0

    open(10, file='sor.log', action='write',position='append')

    do while ((tol .gt. max_tol) .and. (iter .lt. max_it))

       ! Gauss Seidel/SOR Iteration
       c = omega*b + matmul((1.0d0-omega)*D + omega*U, x)
       call fwdsub(D-omega*L, c, xnew, flag)

       ! Compute norms and increment iteration
       tol = norm2(xnew-x)

       x = xnew

       write(10, *) iter, tol
       !print *, iter, tol

       iter = iter + 1

    end do

    close(10)

    flag = 0

    deallocate(D, L, U, c)

  end subroutine dsor

  !-------------------------------------------------------------------!
  ! Get the eigenvalues and eigenvectors of a real matrix.
  !
  ! TODO: add optional switch for left or right eigenvectors in deig()
  ! and zeig()?
  ! -------------------------------------------------------------------!

  subroutine deig(A, lam, c)

    real(dp), intent(in)     :: A(:,:)  ! matrix for eigenvalue compuation
    complex(dp), intent(out) :: lam(:)  ! eigenvalues: A c = lam c
    complex(dp), intent(out) :: c(:,:)  ! eigenvectors: A c = lam c; c(i,j) = ith component of jth vec.

    ! LAPACK variables for DGEEV:
    real(dp), allocatable :: At(:,:), vl(:,: ), vr(:,:)
    real(dp), allocatable :: wi(:), work(:), wr(:)
    integer               :: info, lda, ldvl, ldvr, lwork, n, i

    preprocess: block

      ! Determine the size of the linear system
      lda = size(A(:,1))
      n = size(A(1,:))
      call assert_shape(A, [n, n], "solve", "A")
      call assert_shape(c, [n, n], "solve", "c")
      ldvl = n
      ldvr = n
      lwork = 8*n  ! TODO: can this size be optimized? query first?
      allocate(At(lda,n), wr(n), wi(n), vl(ldvl,n), vr(ldvr,n), work(lwork))
      At = A

    end block preprocess

    solve: block

      ! Call LAPACK to find the eigen values and vectors
      call dgeev('N', 'V', n, At, lda, wr, wi, vl, ldvl, vr, ldvr, &
           work, lwork, info)

    end block solve

    postprocess: block

      if (info .ne. 0) then
         print *, "dgeev returned info = ", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else
            print *, "the QR algorithm failed to compute all the"
            print *, "eigenvalues, and no eigenvectors have been computed;"
            print *, "elements ", info+1, ":", n, "of WR and WI contain eigenvalues which"
            print *, "have converged."
         end if
         call stop_error('eig: dgeev error')
      end if

      lam = wr + i_*wi
      ! As DGEEV has a rather complicated way of returning the
      ! eigenvectors, it is necessary to build the complex array of
      ! eigenvectors from two real arrays:
      do concurrent (i = 1: n)
         if (wi(i) > 0.0) then
            ! first of two conjugate eigenvalues
            c(:, i) = vr(:, i) + i_*vr(:, i+1)
         elseif (wi(i) < 0.0_dp) then
            ! second of two conjugate eigenvalues
            c(:, i) = vr(:, i-1) - i_*vr(:, i)
         else
            c(:, i) = vr(:, i)
         end if
      end do

    end block postprocess

  end subroutine deig

  !-------------------------------------------------------------------!
  ! Get the eigenvalues and eigenvectors of a complex matrix.
  !
  ! TODO: add optional switch for left or right eigenvectors in deig()
  ! and zeig()?
  !-------------------------------------------------------------------!

  subroutine zeig(A, lam, c)

    complex(dp), intent(in)  :: A(:, :) ! matrix to solve eigenproblem for
    complex(dp), intent(out) :: lam(:)  ! eigenvalues: A c = lam c
    complex(dp), intent(out) :: c(:,:)  ! eigenvectors: A c = lam c;
                                        ! c(i,j) = ith component of
                                        ! jth vec.

    ! LAPACK variables:
    integer                  :: info, lda, ldvl, ldvr, lwork, n, lrwork
    real(dp), allocatable    :: rwork(:)
    complex(dp), allocatable :: vl(:,:), vr(:,:), work(:)

    preprocess: block

      ! Determine the size of matrix
      lda = size(A(:,1))
      n = size(A(1,:))
      call assert_shape(A, [n, n], "solve", "A")
      call assert_shape(c, [n, n], "solve", "c")
      ldvl = n
      ldvr = n
      lwork = 8*n  ! TODO: can this size be optimized? query first?
      lrwork = 2*n
      allocate(vl(ldvl,n), vr(ldvr,n), work(lwork), rwork(lrwork))
      c = A

    end block preprocess

    solve: block

      ! Find the eigen values
      call zgeev('N', 'V', n, c, lda, lam, vl, ldvl, vr, ldvr, work, &
           lwork, rwork, info)

    end block solve

    postprocess: block

      if (info .ne. 0) then
         print *, "zgeev returned info = ", info
         if (info .lt. 0) then
            print *, "the ",-info, "-th argument had an illegal value."
         else
            print *, "the QR algorithm failed to compute all the"
            print *, "eigenvalues, and no eigenvectors have been computed;"
            print *, "elements and ", info+1, ":", n, " of W contain eigenvalues which have"
            print *, "converged."
         end if
         call stop_error('eig: zgeev error')
      end if

      c = vr

    end block postprocess

  end subroutine zeig

  !-------------------------------------------------------------------!
  ! Returns the eigen values of the matrix
  !-------------------------------------------------------------------!

  function deigvals(A) result(lam)

    real(dp), intent(in)     :: A(:, :) ! matrix for eigenvalue compuation
    complex(dp), allocatable :: lam(:)  ! eigenvalues: A c = lam c

    ! LAPACK variables for DGEEV:
    real(dp), allocatable :: At(:,:), vl(:,: ), vr(:,:)
    real(dp), allocatable :: wi(:), work(:), wr(:)
    integer               :: info, lda, ldvl, ldvr, lwork, n

    preprocess: block

      ! Determine the size of the matrix
      lda = size(A(:,1))
      n = size(A(1,:))
      call assert_shape(A, [n, n], "solve", "A")
      ldvl = n
      ldvr = n
      lwork = 8*n  ! TODO: can this size be optimized? query first?
      allocate(At(lda,n), wr(n), wi(n), vl(ldvl,n), vr(ldvr,n), work(lwork), lam(n))
      At = A

    end block preprocess

    solve: block

      ! Determine the eigenvalues
      call dgeev('N', 'N', n, At, lda, wr, wi, vl, ldvl, vr, ldvr, &
           work, lwork, info)

    end block solve

    postprocess: block

      ! Post process
      if (info .ne. 0) then
         print *, "dgeev returned info = ", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else
            print *, "the QR algorithm failed to compute all the"
            print *, "eigenvalues, and no eigenvectors have been computed;"
            print *, "elements ", info+1, ":", n, "of WR and WI contain eigenvalues which"
            print *, "have converged."
         end if
         call stop_error('eigvals: dgeev error')
      end if

      lam = wr + i_*wi

    end block postprocess

  end function deigvals

  !===================================================================!
  ! Eigenvalues of a complex matrix
  !===================================================================!

  function zeigvals(A) result(lam)

    complex(dp), intent(in)  :: A(:, :)  ! matrix to solve eigenproblem for
    complex(dp), allocatable :: lam(:)  ! eigenvalues: A c = lam c

    ! LAPACK variables:
    integer                  :: info, lda, ldvl, ldvr, lwork, n, lrwork
    real(dp), allocatable    :: rwork(:)
    complex(dp), allocatable :: At(:,:), vl(:,:), vr(:,:), work(:)

    preprocess: block

      ! Determine the size of the matrix
      lda = size(A(:,1))
      n = size(A(1,:))
      call assert_shape(A, [n, n], "solve", "A")
      ldvl = n
      ldvr = n
      lwork = 8*n  ! TODO: can this size be optimized? query first?
      lrwork = 2*n
      allocate(At(lda,n), &
           & vl(ldvl,n), vr(ldvr,n), &
           & work(lwork), rwork(lrwork), lam(n))
      At = A

    end block preprocess

    solve: block

      ! Determine the eigen values
      call zgeev('N', 'N', n, At, lda, lam, vl, ldvl, vr, ldvr, work, &
           lwork, rwork, info)

    end block solve

    postprocess: block

      ! Post process
      if (info .ne. 0) then
         print *, "zgeev returned info = ", info
         if (info .lt. 0) then
            print *, "the ",-info, "-th argument had an illegal value."
         else
            print *, "the QR algorithm failed to compute all the"
            print *, "eigenvalues, and no eigenvectors have been computed;"
            print *, "elements and ", info+1, ":", n, " of W contain eigenvalues which have"
            print *, "converged."
         end if
         call stop_error('eig: zgeev error')
      end if

    end block postprocess

  end function zeigvals

  !-------------------------------------------------------------------!
  ! Solves generalized eigen value problem for all eigenvalues and
  ! eigenvectors. Am must be symmetric and Bm symmetric positive
  ! definite. Only the lower triangular part of Am and Bm is used in
  ! computations.
  !-------------------------------------------------------------------!

  subroutine deigh_generalized(Am, Bm, lam, c)

    real(dp), intent(in)  :: Am(:,:)  ! LHS matrix: Am c = lam Bm c
    real(dp), intent(in)  :: Bm(:,:)  ! RHS matrix: Am c = lam Bm c
    real(dp), intent(out) :: lam(:)   ! eigenvalues: Am c = lam Bm c
    real(dp), intent(out) :: c(:,:)   ! eigenvectors: Am c = lam Bm c;
                                      ! c(i,j) = ith component of jth
                                      ! vec.
    integer :: n

    ! LLAPACK variables
    integer               :: lwork, liwork, info
    integer, allocatable  :: iwork(:)
    real(dp), allocatable :: Bmt(:,:), work(:)

    preprocess: block

      ! Matrix size
      n = size(Am,1)
      call assert_shape(Am, [n, n], "eigh", "Am")
      call assert_shape(Bm, [n, n], "eigh", "B")
      call assert_shape(c, [n, n], "eigh", "c")

      ! Determine the work size arrays
      lwork = 1 + 6*n + 2*n**2
      liwork = 3 + 5*n
      allocate(Bmt(n,n), work(lwork), iwork(liwork))
      c = Am; Bmt = Bm  ! Bmt temporaries overwritten by dsygvd

    end block preprocess

    solve: block

      call dsygvd(1,'V','L',n,c,n,Bmt,n,lam,work,lwork,iwork,liwork,info)

    end block solve

    postprocess: block

      ! Post process
      if (info .ne. 0) then
         print *, "dsygvd returned info =", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else if (info .le. n) then
            print *, "the algorithm failed to compute an eigenvalue while working"
            print *, "on the submatrix lying in rows and columns", 1.0_dp*info/(n+1)
            print *, "through", mod(info, n+1)
         else
            print *, "The leading minor of order ", info-n, &
                 "of B is not positive definite. The factorization of B could ", &
                 "not be completed and no eigenvalues or eigenvectors were computed."
         end if
         call stop_error('eigh: dsygvd error')
      end if

    end block postprocess

  end subroutine deigh_generalized

  !-------------------------------------------------------------------!
  ! Solves eigenvalue problem for all eigenvalues and eigenvectors. Am
  ! must by symmetric. Only the lower triangular part of Am is used.
  !-------------------------------------------------------------------!

  subroutine deigh_simple(Am, lam, c)

    real(dp), intent(in)  :: Am(:,:)  ! LHS matrix: Am c = lam c
    real(dp), intent(out) :: lam(:)   ! eigenvalues: Am c = lam c
    real(dp), intent(out) :: c(:,:)   ! eigenvectors: Am c = lam c;
                                      ! c(i,j) = ith component of jth
                                      ! vec.
    integer               :: n

    ! Lapack variables
    integer               :: lwork, liwork, info
    integer, allocatable  :: iwork(:)
    real(dp), allocatable :: work(:)

    preprocess: block

      ! Determine space
      n = size(Am,1)
      call assert_shape(Am, [n, n], "eigh", "Am")
      call assert_shape(c, [n, n], "eigh", "c")
      lwork = 1 + 6*n + 2*n**2
      liwork = 3 + 5*n
      allocate(work(lwork), iwork(liwork))
      c = Am

    end block preprocess

    solve: block

      ! Solve
      call dsyevd('V','L',n,c,n,lam,work,lwork,iwork,liwork,info)

    end block solve

    postprocess: block

      ! Post process
      if (info .ne. 0) then
         print *, "dsyevd returned info =", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else
            print *, "the algorithm failed to compute an eigenvalue while working"
            print *, "on the submatrix lying in rows and columns", 1.0_dp*info/(n+1)
            print *, "through", mod(info, n+1)
         end if
         call stop_error('eigh: dsyevd error')
      end if

    end block postprocess

  end subroutine deigh_simple

  !-------------------------------------------------------------------!
  ! Solves generalized eigen value problem for all eigenvalues and
  ! eigenvectors Am must by hermitian, Bm hermitian positive definite.
  ! Only the lower triangular part of Am and Bm is used.
  !-------------------------------------------------------------------!

  subroutine zeigh_generalized(Am, Bm, lam, c)

    complex(dp), intent(in)  :: Am(:,:)   ! LHS matrix: Am c = lam Bm c
    complex(dp), intent(in)  :: Bm(:,:)   ! RHS matrix: Am c = lam Bm c
    real(dp), intent(out)    :: lam(:)      ! eigenvalues: Am c = lam Bm c
    complex(dp), intent(out) :: c(:,:)   ! eigenvectors: Am c = lam Bm c; c(i,j) = ith component of jth vec.

    ! LAPACK variables
    integer                  :: info, liwork, lrwork, lwork, n
    integer, allocatable     :: iwork(:)
    real(dp), allocatable    :: rwork(:)
    complex(dp), allocatable :: Bmt(:,:), work(:)

    preprocess: block

      ! Determine shape
      n = size(Am,1)
      call assert_shape(Am, [n, n], "eigh", "Am")
      call assert_shape(Bm, [n, n], "eigh", "Bm")
      call assert_shape(c, [n, n], "eigh", "c")
      lwork = 2*n + n**2
      lrwork = 1 + 5*N + 2*n**2
      liwork = 3 + 5*n
      allocate(Bmt(n,n), work(lwork), rwork(lrwork), iwork(liwork))
      c = Am; Bmt = Bm  ! Bmt temporary overwritten by zhegvd

    end block preprocess

    solve: block

      ! Solve using lapack
      call zhegvd(1,'V','L',n,c,n,Bmt,n,lam,work,lwork,rwork,lrwork,iwork,liwork,info)

    end block solve

    postprocess: block

      ! Post process
      if (info .ne. 0) then
         print *, "zhegvd returned info =", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else if (info .le. n) then
            print *, "the algorithm failed to compute an eigenvalue while working"
            print *, "on the submatrix lying in rows and columns", 1.0_dp*info/(n+1)
            print *, "through", mod(info, n+1)
         else
            print *, "The leading minor of order ", info-n, &
                 "of B is not positive definite. The factorization of B could ", &
                 "not be completed and no eigenvalues or eigenvectors were computed."
         end if
         call stop_error('eigh: zhegvd error')
      end if

    end block postprocess

  end subroutine zeigh_generalized

  !-------------------------------------------------------------------!
  ! Solves eigenvalue problem for all eigenvalues and eigenvectors. Am
  ! must by symmetric Only the lower triangular part of Am is used.
  !-------------------------------------------------------------------!

  subroutine zeigh_simple(Am, lam, c)

    complex(dp), intent(in)  :: Am(:,:)   ! LHS matrix: Am c = lam c
    real(dp), intent(out)    :: lam(:)   ! eigenvalues: Am c = lam c
    complex(dp), intent(out) :: c(:,:)   ! eigenvectors: Am c = lam c; c(i,j) = ith component of jth vec.

    ! LAPACK variables:
    integer                  :: info, lda, liwork, lrwork, lwork, n
    integer, allocatable     :: iwork(:)
    real(dp), allocatable    :: rwork(:)
    complex(dp), allocatable :: work(:)

    preprocess: block

      ! use LAPACK's zheevd routine
      n = size(Am, 1)
      call assert_shape(Am, [n, n], "eigh", "Am")
      call assert_shape(c, [n, n], "eigh", "c")
      lda = max(1, n)
      lwork = 2*n + n**2
      lrwork = 1 + 5*n + 2*n**2
      liwork = 3 + 5*n
      allocate(work(lwork), rwork(lrwork), iwork(liwork))
      c = Am

    end block preprocess

    solve: block

      ! Solve
      call zheevd("V", "L", n, c, lda, lam, work, lwork, rwork, lrwork, &
           iwork, liwork, info)

    end block solve

    postprocess: block

      ! Post process
      if (info .ne. 0) then
         print *, "zheevd returned info =", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else
            print *, "the algorithm failed to compute an eigenvalue while working"
            print *, "through the submatrix lying in rows and columns through"
            print *, info/(n+1), " through ", mod(info, n+1)
         end if
         call stop_error('eigh: zheevd error')
      end if

    end block postprocess

  end subroutine zeigh_simple

  !-------------------------------------------------------------------!
  ! Return the inverse of a real matrix
  !-------------------------------------------------------------------!

  function dinv(Am) result(Bm)

    real(dp), intent(in)  :: Am(:,:)  ! matrix to be inverted
    real(dp)              :: Bm(size(Am, 1), size(Am, 2))   ! Bm = inv(Am)
    real(dp), allocatable :: Amt(:,:), work(:)  ! temporary work arrays

    ! LAPACK variables:
    integer              ::  info, lda, n, lwork, nb
    integer, allocatable :: ipiv(:)

    ! use LAPACK's dgetrf and dgetri
    n = size(Am(1, :))
    call assert_shape(Am, [n, n], "inv", "Am")
    lda = n
    nb = ilaenv(1, 'DGETRI', "UN", n, -1, -1, -1)  ! TODO: check UN param
    lwork = n*nb
    if (nb .lt. 1) nb = max(1, n)
    allocate(Amt(n,n), work(lwork), ipiv(n))
    Amt = Am

    ! Solve
    call dgetrf(n, n, Amt, lda, ipiv, info)

    ! Post process
    if (info .ne. 0) then
       print *, "dgetrf returned info =", info
       if (info .lt. 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "U(", info, ",", info, ") is exactly zero; The factorization"
          print *, "has been completed, but the factor U is exactly"
          print *, "singular, and division by zero will occur if it is used"
          print *, "to solve a system of equations."
       end if
       call stop_error('inv: dgetrf error')
    end if

    ! Solve
    call dgetri(n, Amt, n, ipiv, work, lwork, info)

    ! Post process
    if (info .ne. 0) then
       print *, "dgetri returned info =", info
       if (info .lt. 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "U(", info, ",", info, ") is exactly zero; the matrix is"
          print *, "singular and its inverse could not be computed."
       end if
       call stop_error('inv: dgetri error')
    end if

    ! Result
    Bm = Amt

  end function dinv

  !-------------------------------------------------------------------!
  ! Inverse of a complex matrix
  !-------------------------------------------------------------------!

  function zinv(Am) result(Bm)

    ! Inverts the general complex matrix Am
    complex(dp), intent(in) :: Am(:,:)   ! Matrix to be inverted
    complex(dp)             :: Bm(size(Am, 1), size(Am, 2))   ! Bm = inv(Am)
    integer                 :: n, nb

    ! LAPACK variables
    integer                  :: lwork, info
    complex(dp), allocatable :: Amt(:,:), work(:)
    integer, allocatable     :: ipiv(:)

    ! Determine size
    n = size(Am, 1)
    call assert_shape(Am, [n, n], "inv", "Am")
    nb = ilaenv(1, 'ZGETRI', "UN", n, -1, -1, -1) ! TODO: check UN param
    if (nb .lt. 1) nb = max(1, n)
    lwork = n*nb
    allocate(Amt(n,n), ipiv(n), work(lwork))
    Amt = Am

    ! Solve
    call zgetrf(n, n, Amt, n, ipiv, info)

    ! Post process
    if (info .ne. 0) then
       print *, "zgetrf returned info =", info
       if (info .lt. 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "U(", info, ",", info, ") is exactly zero; The factorization"
          print *, "has been completed, but the factor U is exactly"
          print *, "singular, and division by zero will occur if it is used"
          print *, "to solve a system of equations."
       end if
       call stop_error('inv: zgetrf error')
    end if

    ! Solve
    call zgetri(n, Amt, n, ipiv, work, lwork, info)
    if (info .ne. 0) then
       print *, "zgetri returned info =", info
       if (info .lt. 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "U(", info, ",", info, ") is exactly zero; the matrix is"
          print *, "singular and its inverse could not be computed."
       end if
       call stop_error('inv: zgetri error')
    end if

    Bm = Amt

  end function zinv

  !-------------------------------------------------------------------!
  ! Solves a system of equations A x = b with one right hand side
  !-------------------------------------------------------------------!

  function dsolve(A, b) result(x)

    real(dp), intent(in)  :: A(:,:)  ! coefficient matrix A
    real(dp), intent(in)  :: b(:)  ! right-hand-side A x = b
    real(dp), allocatable :: x(:)

    ! LAPACK variables:
    real(dp), allocatable :: At(:,:), bt(:,:)
    integer               :: n, info, lda
    integer, allocatable  :: ipiv(:)

    preprocess: block

      ! Determine size
      n = size(A(1,:))
      lda = size(A(:, 1))  ! TODO: remove lda (which is = n!)
      call assert_shape(A, [n, n], "solve", "A")
      allocate(At(lda,n), bt(n,1), ipiv(n), x(n))
      At = A
      bt(:,1) = b(:)

    end block preprocess

    solve: block

      ! Solve the linear system
      call dgesv(n, 1, At, lda, ipiv, bt, n, info)

    end block solve

    postprocess: block

      ! Post process
      if (info .ne. 0) then
         print *, "dgesv returned info =", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else
            print *, "U(", info, ",", info, ") is exactly zero; The factorization"
            print *, "has been completed, but the factor U is exactly"
            print *, "singular, so the solution could not be computed."
         end if
         call stop_error('inv: dgesv error')
      end if

      ! Store the result
      x = bt(:,1)

    end block postprocess

  end function dsolve

  !-------------------------------------------------------------------!
  ! Solves a system of equations A x = b with one right hand side
  !-------------------------------------------------------------------!

  function zsolve(A, b) result(x)

    complex(dp), intent(in)  :: A(:,:)  ! coefficient matrix A
    complex(dp), intent(in)  :: b(:)    ! right-hand-side A x = b
    complex(dp), allocatable :: x(:)

    ! LAPACK variables:
    complex(dp), allocatable :: At(:,:), bt(:,:)
    integer                  :: n, info, lda
    integer, allocatable     :: ipiv(:)

    preprocess: block
      ! Determine size
      n = size(A(1,:))
      lda = size(A(:, 1))  ! TODO: remove lda here, too
      call assert_shape(A, [n, n], "solve", "A")
      allocate(At(lda,n), bt(n,1), ipiv(n), x(n))
      At = A
      bt(:,1) = b(:)
    end block preprocess

    solve: block
      ! Solve using LAPACK
      call zgesv(n, 1, At, lda, ipiv, bt, n, info)
    end block solve

    postprocess: block
      ! Post process
      if (info .ne. 0) then
         print *, "zgesv returned info =", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else
            print *, "U(", info, ",", info, ") is exactly zero; The factorization"
            print *, "has been completed, but the factor U is exactly"
            print *, "singular, so the solution could not be computed."
         end if
         call stop_error('inv: zgesv error')
      end if

      ! Store the result
      x = bt(:,1)
    end block postprocess

  end function zsolve

  !-------------------------------------------------------------------!
  ! Generates a nxn identity matrix
  !-------------------------------------------------------------------!

  pure function eye(n)

    integer, intent(in) :: n
    real(dp)    :: eye(n,n)
    integer     :: i, j

    ! generate a zero matrix
    eye = 0.0_dp

    ! replace the diagonals with one
    forall(i=1:n)
       eye(i,i) = 1.0_dp
    end forall

  end function eye

  !-------------------------------------------------------------------!
  ! A function that returns the determinant value of the matrix. This
  ! computes the determinant of a REAL matrix using an LU
  ! factorization.
  !-------------------------------------------------------------------!

  real(dp) function ddet(A) result(x)

    real(dp), intent(in) :: A(:, :)
    integer              :: i

    ! LAPACK variables:
    integer               :: info, n
    integer, allocatable  :: ipiv(:)
    real(dp), allocatable :: At(:,:)

    preprocess: block

      ! Determine the size of the linear system
      n = size(A(1,:))
      call assert_shape(A, [n, n], "det", "A")

      !allocate(At, source=A) ! not supported by compiler yet

      ! Make a copy of the matrix as the input is modified in LU
      ! decomposition
      allocate(At(n,n), ipiv(n))
      At = A

    end block preprocess

    solve: block

      ! LU decomposition on the temp matrix
      call dgetrf(n, n, At, n, ipiv, info)

    end block solve

    postprocess: block

      ! Check the LAPACK output flag for potential issues in solution
      if (info .ne. 0) then
         print *, "dgetrf returned info =", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else
            print *, "U(", info, ",", info, ") is exactly zero; The factorization"
            print *, "has been completed, but the factor U is exactly"
            print *, "singular, and division by zero will occur if it is used"
            print *, "to solve a system of equations."
         end if
         call stop_error('det: dgetrf error')
      end if

      ! At now contains the LU of the factorization A = PLU as L has
      ! unit diagonal entries, the determinant can be computed from the
      ! product of U's diagonal entries. Additional sign changes
      ! stemming from the permutations P have to be taken into account
      ! as well.
      x = 1.0_dp
      do i = 1, n
         if (ipiv(i) .ne. i) then  ! additional sign change
            x = -x*At(i,i)
         else
            x = x*At(i,i)
         end if
      end do

    end block postprocess

  end function ddet

  !-------------------------------------------------------------------!
  ! A function that returns the determinant value of the matrix. This
  ! computes the determinant of a COMPLEX matrix using an LU
  ! factorization.
  !-------------------------------------------------------------------!

  complex(dp) function zdet(A) result(x)

    complex(dp), intent(in) :: A(:, :)
    integer                 :: i

    ! LAPACK variables:
    integer                  :: info, n
    integer, allocatable     :: ipiv(:)
    complex(dp), allocatable :: At(:,:)

    preprocess: block

      ! Determine the size of the linear system
      n = size(A(1,:))
      call assert_shape(A, [n, n], "det", "A")

      ! Make a copy of the matrix as the input is modified in LU
      ! decomposition
      allocate(At(n,n), ipiv(n))
      At = A

    end block preprocess

    solve: block

      ! LU decomposition on the temp matrix
      call zgetrf(n, n, At, n, ipiv, info)

    end block solve

    postprocess: block

      ! Check the LAPACK output flag for potential issues in solution
      if (info .ne. 0) then
         print *, "zgetrf returned info =", info
         if (info .lt. 0) then
            print *, "the", -info, "-th argument had an illegal value"
         else
            print *, "U(", info, ",", info, ") is exactly zero; The factorization"
            print *, "has been completed, but the factor U is exactly"
            print *, "singular, and division by zero will occur if it is used"
            print *, "to solve a system of equations."
         end if
         call stop_error('inv: zgetrf error')
      end if

      ! Compute the determinant (see ddet for details)
      x = 1.0_dp + 0*i_
      do i = 1, n
         if (ipiv(i) .ne. i) then  ! additional sign change
            x = -x*At(i,i)
         else
            x = x*At(i,i)
         end if
      end do

    end block postprocess

  end function zdet

  !-------------------------------------------------------------------!
  ! Compute least square solution to A x = b for real A, b
  !-------------------------------------------------------------------!

  function dlstsq(A, b) result(x)

    real(dp), intent(in)  :: A(:,:), b(:)
    real(dp), allocatable :: x(:)

    ! LAPACK variables:
    integer               :: info, ldb, lwork, m, n, rank
    real(dp)              :: rcond
    real(dp), allocatable :: work(:), At(:,:), Bt(:,:)
    integer, allocatable  :: jpvt(:)

    ! Handle allocations
    preprocess: block

      ! Determine the matrix size
      m = size(A(:,1)) ! = lda
      n = size(A(1,:))
      ldb = size(b)

      ! Determine the optimal workspace size
      allocate(x(n), At(m,n), Bt(ldb,1), jpvt(n), work(1))
      call dgelsy(m, n, 1, At, m, Bt, ldb, jpvt, rcond, rank, work, &
           -1, info)  ! query optimal workspace size
      lwork = int(real(work(1)))
      deallocate(work)

      ! Allocate with optimal size
      allocate(work(lwork))  ! allocate with ideal size
      rcond = 0.0_dp
      jpvt(:) = 0
      Bt(:,1) = b(:)  ! only one right-hand side
      At(:,:) = A(:,:)

    end block preprocess

    solve: block

      ! Call LAPACK for lease squares solution
      call dgelsy(m, n, 1, At, m, Bt, ldb, jpvt, rcond, rank, work, &
           lwork, info)

    end block solve

    postprocess: block

      ! Find any error code
      if (info .ne. 0) then
         print *, "dgelsy returned info = ", info
         print *, "the ", -info, "-th argument had an illegal value"
         call stop_error('lstsq: dgelsy error')
      end if

      ! Store the solution
      x(:) = Bt(1:n,1)

    end block postprocess

  end function dlstsq

  !-------------------------------------------------------------------!
  ! Compute least square solution to A x = b for complex A, b
  !-------------------------------------------------------------------!

  function zlstsq(A, b) result(x)

    complex(dp), intent(in)  :: A(:,:), b(:)
    complex(dp), allocatable :: x(:)

    ! LAPACK variables:
    integer                  :: info, ldb, lwork, m, n, rank
    real(dp)                 :: rcond
    complex(dp), allocatable :: At(:,:), Bt(:,:), work(:)
    real(dp), allocatable    :: rwork(:)
    integer, allocatable     :: jpvt(:)

    preprocess: block

      ! Determine the matrix size
      m = size(A(:,1)) ! = lda
      n = size(A(1,:))
      ldb = size(b)

      ! Query optimal workspace size
      allocate(x(n), At(m,n), Bt(ldb,1), jpvt(n), work(1), rwork(2*n))
      call zgelsy(m, n, 1, At, m, Bt, ldb, jpvt, rcond, rank, work, &
           -1, rwork, info)
      lwork = int(real(work(1)))
      deallocate(work)

      ! Allocate the optimal (ideal) workspace size
      allocate(work(lwork))
      rcond = 0.0_dp
      jpvt(:) = 0
      Bt(:,1) = b(:)  ! only one right-hand side
      At(:,:) = A(:,:)

    end block preprocess

    solve: block

      ! Call LAPACK to solve the system
      call zgelsy(m, n, 1, At, m, Bt, ldb, jpvt, rcond, rank, work, &
           lwork, rwork, info)

    end block solve

    ! Post process
    postprocess: block

      if (info /= 0) then
         print *, "zgelsy returned info = ", info
         print *, "the ", -info, "-th argument had an illegal value"
         call stop_error('lstsq: zgelsy error')
      end if

      ! Store the results
      x(:) = Bt(1:n,1)

    end block postprocess

  end function zlstsq

  !-------------------------------------------------------------------!
  ! Construct real matrix from diagonal elements
  !-------------------------------------------------------------------!

  pure function ddiag(x) result(A)

    real(dp), intent(in)  :: x(:)
    real(dp), allocatable :: A(:,:)
    integer               :: i, n

    n = size(x)

    allocate(A(n,n))
    A = 0.0_dp

    forall(i=1:n) A(i,i) = x(i)

  end function ddiag

  !-------------------------------------------------------------------!
  ! Construct complex matrix from diagonal elements
  !-------------------------------------------------------------------!

  pure function zdiag(x) result(A)

    complex(dp), intent(in)  :: x(:)
    complex(dp), allocatable :: A(:,:)
    integer                  :: i, n

    n = size(x)

    allocate(A(n,n))

    A = 0*i_

    forall(i=1:n) A(i,i) = x(i)

  end function zdiag

  !-------------------------------------------------------------------!
  ! Construct real matrix from upper triangular elements
  !-------------------------------------------------------------------!

  pure function dtriu(A) result(U)

    real(dp), intent(in)  :: A(:,:)
    real(dp), allocatable :: U(:,:)
    integer               :: i, j, n

    n = size(A(1,:))

    allocate(U(n,n))
    U = 0.0_dp

     do concurrent (i=1:n)
         U(i+1:n,i) = A(:,i)
      end do

    do i = 1, n
       do j = i, n
          U(j,i) = A(j,i)
       end do
    end do

  end function dtriu

  !-------------------------------------------------------------------!
  ! Return trace along the main diagonal of a real matrix
  !-------------------------------------------------------------------!

  pure real(dp) function dtrace(A) result(t)

    real(dp), intent(in) :: A(:,:)
    integer              :: i

    t = 0.0_dp
    do i = 1, minval(shape(A))
       t = t + A(i,i)
    end do

  end function dtrace

  !-------------------------------------------------------------------!
  ! Return trace along the main diagonal of a real matrix
  !-------------------------------------------------------------------!

  pure complex(dp) function ztrace(A) result(t)

    complex(dp), intent(in) :: A(:,:)
    integer                 :: i

    t = 0*i_
    do i = 1, minval(shape(A))
       t = t + A(i,i)
    end do

  end function ztrace

  !-------------------------------------------------------------------!
  ! Find the singular values s_i of a real m x n matrix
  !-------------------------------------------------------------------!

  function dsvdvals(A) result(s)

    real(dp), intent(in)  :: A(:,:)
    real(dp), allocatable :: s(:)

    ! LAPACK related:
    integer               :: info, lwork, m, n
    real(dp), allocatable :: work(:), At(:,:)
    real(dp)              :: u(1,1), vt(1,1)  ! not used if only s is
                                              ! to be computed
    preprocess: block

      m = size(A(:,1))  ! = lda
      n = size(A(1,:))
      allocate(At(m,n), s(min(m,n)))
      At(:,:) = A(:, :)  ! A is overwritten in dgesvd

      ! Query optimal lwork and allocate workspace:
      allocate(work(1))
      call dgesvd('N', 'N', m, n, At, m, s, u, 1, vt, 1, work, -1, info)
      lwork = int(real(work(1)))
      deallocate(work)
      allocate(work(lwork))

    end block preprocess

    solve: block

      ! Compute the singular value decomposition
      call dgesvd('N', 'N', m, n, At, m, s, u, 1, vt, 1, work, lwork, info)

    end block solve

    postprocess: block

      if (info .ne. 0) then
         print *, "dgesvd returned info = ", info
         if (info .lt. 0) then
            print *, "the ", -info, "-th argument had an illegal value"
         else
            print *, "DBDSQR did not converge, there are ", info
            print *, "superdiagonals of an intermediate bidiagonal form B"
            print *, "did not converge to zero. See the description of WORK"
            print *, "in DGESVD's man page for details."
         end if
         call stop_error('svdvals: dgesvd error')
      end if

    end block postprocess

  end function dsvdvals

  !-------------------------------------------------------------------!
  ! Find the singular values s_i of a complex m x n matrix
  !-------------------------------------------------------------------!

  function zsvdvals(A) result(s)

    complex(dp), intent(in) :: A(:,:)
    real(dp), allocatable   :: s(:)

    ! LAPACK related:
    integer                  :: info, lwork, m, n, lrwork
    complex(dp), allocatable :: work(:), At(:,:)
    real(dp), allocatable    :: rwork(:)
    complex(dp)              :: u(1,1), vt(1,1)  ! not used if only s is to be computed

    preprocess: block

      ! Determine size and allocate space
      m = size(A(:,1))  ! = lda
      n = size(A(1,:))
      lrwork = 5*min(m,n)
      allocate(At(m,n), s(min(m,n)), rwork(lrwork))
      At(:,:) = A(:,:)  ! A is overwritten in zgesvd!

      ! Query optimal lwork and allocate workspace
      allocate(work(1))
      call zgesvd('N', 'N', m, n, At, m, s, u, 1, vt, 1, work, -1, rwork, info)
      lwork = int(real(work(1)))
      deallocate(work)
      allocate(work(lwork))

    end block preprocess

    solve: block

      ! Compute the singular value decomposition
      call zgesvd('N', 'N', m, n, At, m, s, u, 1, vt, 1, work, lwork, rwork, info)

    end block solve

    postprocess: block

      if (info .ne. 0) then
         print *, "zgesvd returned info = ", info
         if (info .lt. 0) then
            print *, "the ", -info, "-th argument had an illegal value"
         else
            print *, "ZBDSQR did not converge, there are ", info
            print *, "superdiagonals of an intermediate bidiagonal form B"
            print *, "did not converge to zero. See the description of RWORK"
            print *, "in ZGESVD's man page for details."
         end if
         call stop_error('svdvals: zgesvd error')
      end if

    end block postprocess

  end function zsvdvals

  !-------------------------------------------------------------------!
  ! compute the singular value decomposition A = U sigma V^T of a real
  ! m x n matrix A. U is m x m. V^T is n x n. s has size min(m, n) -->
  ! sigma matrix is (n x m) with sigma_ii = s_i
  ! -------------------------------------------------------------------!

  subroutine dsvd(A, s, U, Vtransp)

    real(dp), intent(in)  :: A(:,:)
    real(dp), intent(out) :: s(:), U(:,:), Vtransp(:,:)

    ! LAPACK related:
    integer               :: info, lwork, m, n, ldu
    real(dp), allocatable :: work(:), At(:,:)

    preallocate: block

      m = size(A(:,1))  ! = lda
      n = size(A(1,:))
      ldu = m
      allocate(At(m,n))
      At(:,:) = A(:,:)  ! use a temporary as dgesvd destroys its input

      call assert_shape(U, [m, m], "svd", "U")
      call assert_shape(Vtransp, [n, n], "svd", "Vtransp")

      ! query optimal lwork and allocate workspace:
      allocate(work(1))
      call dgesvd('A', 'A', m, n, At, m, s, U, ldu, Vtransp, n, work, -1, info)
      lwork = int(real(work(1)))
      deallocate(work)
      allocate(work(lwork))

    end block preallocate

    solve: block

      call dgesvd('A', 'A', m, n, At, m, s, U, ldu, Vtransp, n, work, lwork, info)

    end block solve

    postprocess: block

      if (info /= 0) then
         print *, "dgesvd returned info = ", info
         if (info < 0) then
            print *, "the ", -info, "-th argument had an illegal value"
         else
            print *, "DBDSQR did not converge, there are ", info
            print *, "superdiagonals of an intermediate bidiagonal form B"
            print *, "did not converge to zero. See the description of WORK"
            print *, "in DGESVD's man page for details."
         end if
         call stop_error('svd: dgesvd error')
      end if

    end block postprocess

  end subroutine dsvd

  !-------------------------------------------------------------------!
  ! compute the singular value decomposition A = U sigma V^H of a
  ! complex m x m matrix A
  ! U is m x min(m, n)
  ! Vtransp is n x n
  ! sigma is m x n with with sigma_ii = s_i
  ! note that this routine returns V^H, not V!
  !-------------------------------------------------------------------!

  subroutine zsvd(A, s, U, Vtransp)

    complex(dp), intent(in)  :: A(:,:)
    real(dp), intent(out)    :: s(:)
    complex(dp), intent(out) :: U(:,:), Vtransp(:,:)

    ! LAPACK related:
    integer                  :: info, lwork, m, n, ldu, lrwork
    real(dp), allocatable    :: rwork(:)
    complex(dp), allocatable :: work(:), At(:,:)

    ! TODO: check shapes here and in other routines?

    preprocess: block

      m = size(A(:,1))  ! = lda
      n = size(A(1,:))
      ldu = m
      lrwork = 5*min(m,n)
      allocate(rwork(lrwork), At(m,n))
      At(:,:) = A(:,:)  ! use a temporary as zgesvd destroys its input

      call assert_shape(U, [m, m], "svd", "U")
      call assert_shape(Vtransp, [n, n], "svd", "Vtransp")

      ! query optimal lwork and allocate workspace:
      allocate(work(1))
      call zgesvd('A', 'A', m, n, At, m, s, U, ldu, Vtransp, n, work, -1,&
           rwork, info)
      lwork = int(real(work(1)))
      deallocate(work)
      allocate(work(lwork))

    end block preprocess

    solve: block

      call zgesvd('A', 'A', m, n, At, m, s, U, ldu, Vtransp, n, work, &
           lwork, rwork, info)

    end block solve

    postprocess: block

      if (info /= 0) then
         print *, "zgesvd returned info = ", info
         if (info < 0) then
            print *, "the ", -info, "-th argument had an illegal value"
         else
            print *, "ZBDSQR did not converge, there are ", info
            print *, "superdiagonals of an intermediate bidiagonal form B"
            print *, "did not converge to zero. See the description of WORK"
            print *, "in DGESVD's man page for details."
         end if
         call stop_error('svd: zgesvd error')
      end if

    end block postprocess

  end subroutine zsvd

  !-------------------------------------------------------------------!
  ! Make sure a given real matrix has a given shape
  !-------------------------------------------------------------------!

  subroutine dassert_shape(A, shap, routine, matname)

    real(dp), intent(in) :: A(:,:)
    integer, intent(in)  :: shap(:)
    character(len=*)     :: routine, matname

    if (any(shape(A) .ne. shap)) then
       print *, "In routine " // routine // " matrix " // matname // " has illegal shape ", shape(A)
       print *, "Shape should be ", shap
       call stop_error("Aborting due to illegal matrix operation")
    end if

  end subroutine dassert_shape

  !-------------------------------------------------------------------!
  ! Make sure a given real matrix has a given shape
  !-------------------------------------------------------------------!

  subroutine zassert_shape(A, shap, routine, matname)

    complex(dp), intent(in) :: A(:,:)
    integer, intent(in)     :: shap(:)
    character(len=*)        :: routine, matname

    if (any(shape(A) .ne. shap)) then
       print *, "In routine " // routine // " matrix " // matname // " has illegal shape ", shape(A)
       print *, "Shape should be ", shap
       call stop_error("Aborting due to illegal matrix operation")
    end if

  end subroutine zassert_shape

  !-------------------------------------------------------------------!
  ! Stop with an error message
  !-------------------------------------------------------------------!

  subroutine stop_error( message )

    character(len=*) :: message

    print *, message
    stop

  end subroutine stop_error

  !-------------------------------------------------------------------!
  ! Assert if the condition is not met (i.e. condition .eq. false)
  !-------------------------------------------------------------------!

  subroutine assert(condition)

    logical, intent(in) :: condition

    if (.not. condition) call stop_error("Assert failed.")

  end subroutine assert

  !-------------------------------------------------------------------!
  ! Solve an upper triangular linear system using backward
  ! substitution procedure starting from the last equation.
  ! ------------------------------------------------------------------!

  subroutine backsub(U, b, x, flag)

    ! inputs and outputs
    real(dp), intent(in)    :: U(:,:)
    real(dp), intent(in)    :: b(:)
    real(dp), intent(inout) :: x(:)
    integer , intent(inout) :: flag

    ! local variables
    integer :: i, j, m, n

    ! zero result vector for safety
    x = 0.0d0

    ! Size of the system
    m = size(U(:,1))
    n = size(U(1,:))

    ! find the last variable
    if (abs(U(m,m)) .le. tiny(1.0d0)) then
       flag = -1
       return
    end if

    x(m) = b(m)/U(m,m)

    ! find the other unknowns
    rows: do i = m-1, 1, -1
       if (abs(U(i,i)) .le. tiny(1.0d0)) then
          flag = -1
          return
       else
          ! RHS - take the known values to RHS (columnwise sum)
          x(i) = b(i) - sum(U(i,i+1:n)*x(i+1:n))
          x(i) = x(i)/U(i,i)
       end if
    end do rows

    flag = 0

  end subroutine backsub

  !-------------------------------------------------------------------!
  ! Solve a lower triangular linear system using forward substitution
  ! procedure starting from the first equation.
  ! ------------------------------------------------------------------!

  pure subroutine fwdsub(L, b, x, flag)

    ! inputs and outputs
    real(dp), intent(in)    :: L(:,:)
    real(dp), intent(in)    :: b(:)
    real(dp), intent(inout) :: x(:)
    integer , intent(inout) :: flag

    ! local variables
    integer :: i, j, m, n

    ! zero result vector for safety
    x = 0.0d0

    ! Size of the system
    m = size(L(:,1))
    n = size(L(1,:))

    ! find the last variable
    if (abs(L(1,1)) .le. tiny(1.0d0)) then
       flag = -1
       return
    end if
    x(1) = b(1)/L(1,1)

    ! find the other unknowns
    rows: do i = 2, m
       if (abs(L(i,i)) .le. tiny(1.0d0)) then
          flag = -1
          return
       else
          ! RHS - take the known values to RHS (columnwise sum)
          x(i) = b(i) - sum(L(i,1:i-1)*x(1:i-1))
          x(i) = x(i)/L(i,i)
       end if
    end do rows

    flag = 0

  end subroutine fwdsub

end module linear_algebra


subroutine f(u, r)
implicit none
  real(kind(0.d0)), intent(out) :: r
  real(kind(0.d0)), intent(in) :: u
  r = u*(1.d0-u)
end subroutine f

subroutine  fortran_logistic(N, dt, u)
  integer, intent(in) :: N
  real(kind(0.d0)), intent(in) :: dt
  real(kind(0.d0)), intent(out) :: u(N)

  integer :: i
  real(kind(0.d0)) :: temp

  u(1) = 1.d-5
  do i=1, N-1
    call f(u(i), temp)
    u(i+1) = u(i) + dt*temp
  end do
end subroutine  fortran_logistic

program main

real(kind(0.d0)) :: start, finish, u(1000), dt
integer :: i, N

N = 1000
dt = 25.d0/1000.d0

call cpu_time(start)

do i = 1, 100000
  call fortran_logistic(N, dt, u)
end do

call cpu_time(finish)
print '(f6.3)', (finish-start)*1000000/100000
print *, u(1000)
end program


      SUBROUTINE shape1 (nnode ,deriv ,shape ,exisp,etasp )
!********************************************************************
!
!***  calculates shape functions and their derivatives for 2d elements
!
!********************************************************************
      IMPLICIT NONE

      INTEGER (kind=4) nnode
      REAL (kind=8)    deriv(nnode,2),shape(nnode),exisp,etasp

      REAL (kind=8)    s,t,s2,t2,ss,tt,st,sst,stt,st2,stq,q2

      s  = exisp
      t  = etasp
      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

        s2 = s*2d0
        t2 = t*2d0
        ss = s*s
        tt = t*t
        sst = ss*t
        stt = st*t
        st2 = st*2d0

        IF (nnode == 8) THEN
          !***    shape functions for 8 noded element
          shape(1) = (-1d0+st+ss+tt-sst-stt)/4d0
          shape(2) = (-1d0-st+ss+tt-sst+stt)/4d0
          shape(3) = (-1d0+st+ss+tt+sst+stt)/4d0
          shape(4) = (-1d0-st+ss+tt+sst-stt)/4d0
          shape(5) = (1d0-t-ss+sst)/2d0
          shape(6) = (1d0+s-tt-stt)/2d0
          shape(7) = (1d0+t-ss-sst)/2d0
          shape(8) = (1d0-s-tt+stt)/2d0

          !***      and derivatives

          deriv(1,1) = (t+s2-st2-tt)/4d0
          deriv(2,1) = (-t+s2-st2+tt)/4d0
          deriv(3,1) = (t+s2+st2+tt)/4d0
          deriv(4,1) = (-t+s2+st2-tt)/4d0
          deriv(5,1) = -s+st
          deriv(6,1) = (1d0-tt)/2d0
          deriv(7,1) = -s-st
          deriv(8,1) = (-1d0+tt)/2d0
          deriv(1,2) = (s+t2-ss-st2)/4d0
          deriv(2,2) = (-s+t2-ss+st2)/4d0
          deriv(3,2) = (s+t2+ss+st2)/4d0
          deriv(4,2) = (-s+t2+ss-st2)/4d0
          deriv(5,2) = (-1d0+ss)/2d0
          deriv(6,2) = -t-st
          deriv(7,2) = (1d0-ss)/2d0
          deriv(8,2) = -t+st

        ELSE IF (nnode == 9) THEN

          ! ***     shape functions for 9 noded element

          stq = st*st
          shape(1) = (st-stt-sst+stq)/4d0
          shape(2) = (-st+stt-sst+stq)/4d0
          shape(3) = (st+stt+sst+stq)/4d0
          shape(4) = (-st-stt+sst+stq)/4d0
          shape(5) = (-t+tt+sst-stq)/2d0
          shape(6) = (s-stt+ss-stq)/2d0
          shape(7) = (t+tt-sst-stq)/2d0
          shape(8) = (-s+stt+ss-stq)/2d0
          shape(9) = 1d0-tt-ss+stq

          ! ***     and derivatives

          q2 = stt*2d0
          deriv(1,1) = (t-tt-st2+q2)/4d0
          deriv(2,1) = (-t+tt-st2+q2)/4d0
          deriv(3,1) = (t+tt+st2+q2)/4d0
          deriv(4,1) = (-t-tt+st2+q2)/4d0
          deriv(5,1) = st-stt
          deriv(6,1) = (1d0-tt+2d0*s-q2)/2d0
          deriv(7,1) = -st-stt
          deriv(8,1) = (-1d0+tt+2d0*s-q2)/2d0
          deriv(9,1) = -2.0*s+q2
          q2=sst*2.0
          deriv(1,2) = (s-st2-ss+q2)/4d0
          deriv(2,2) = (-s+st2-ss+q2)/4d0
          deriv(3,2) = (s+st2+ss+q2)/4d0
          deriv(4,2) = (-s-st2+ss+q2)/4d0
          deriv(5,2) = (-1d0+2d0*t+ss-q2)/2d0
          deriv(6,2) = -st-sst
          deriv(7,2) = (1d0+2d0*t-ss-q2)/2d0
          deriv(8,2) = st-sst
          deriv(9,2) = -2d0*t+q2

        END IF
      END IF
      RETURN
      END SUBROUTINE shape1


#include "scalar.fpp"

!=====================================================================!
! Program that solves the diffusion equation
!=====================================================================!

program main

  use constants
  use variables
  use dense_matrix_test
  use dense_vector_test

  implicit none

  call test_dense_matrix(10,10)
  call test_dense_vector(10)

  stop

  call initialize()

  call execute()

  call finalize()

contains

  !-------------------------------------------------------------------!
  ! Execute the simulation on one dimensional grid
  !-------------------------------------------------------------------!

  subroutine execute()

    use mpi_wrapper

    type(integer), parameter :: NDIM    = 1  ! physical dimension
    type(integer), parameter :: NPOINTS = 99  ! number of grid points
    type(integer), parameter :: NSTEPS  = 99  ! number of time steps

    ! state vector
    type(scalar), allocatable, dimension(:,:) :: state

    ! diffusion operator matrix
    type(scalar), allocatable, dimension(:,:) :: D

    ! grid
    type(scalar), allocatable, dimension(:,:) :: xpts

    ! diffusion parameter
    type(scalar), parameter :: alpha = 1.0d-3

    ! generation of grid and time steps
    type(scalar) :: dx, dt

    ! Loop over
    type(integer) :: i, j, k
    type(integer) :: n, p
    type(integer) :: irow, icol

    ! spatial and temporal bounds
    type(scalar), parameter :: xfinal = 1.0_WP
    type(scalar), parameter :: tfinal = 1.0_WP

    type(scalar) :: dval, odval

    ! Lapack variables
    integer, allocatable, dimension(:)        :: ipiv
    integer                                   :: info, size

    ! Temporary lapack vector for RHS
    type(scalar), allocatable, dimension(:) :: rhs

    allocate(state(NPOINTS, NSTEPS))
    allocate(rhs(NPOINTS))
    allocate(xpts(NDIM,NPOINTS))
    allocate(D(NPOINTS, NPOINTS))

    dx = xfinal/dble(NPOINTS-1)
    dt = tfinal/dble(NSTEPS-1)

    ! generate the spatial grid
    do i = 1, NPOINTS
       xpts(:,i) = dble(i-1)*dx
    end do

    ! Initial condition
    do p = 1, NPOINTS
       state(p,1) = sin(10.0_WP*PI*xpts(1,p)) ! note that
    end do

    ! Boundary conditions

    ! left end
    state(1, :) = 0.15_WP

    ! right end
    state(NPOINTS, :) = 0.15_WP

    odval = alpha*dt/(dx*dx)
    dval  = 1.0_WP + 2.0_WP*odval

    ! Assemble diffusion matrix using central difference
    D = 0.0_WP
    do irow = 1, NPOINTS

       ! leading diagonal
       icol = irow
       D(irow,icol) = dval

       ! sub diagonal
       icol = irow - 1
       if ( icol .ge. 1) then
          D(irow, icol) = -odval
       end if

       ! super diagonal
       icol = irow + 1
       if ( icol .le. NPOINTS) then
          D(irow, icol) = -odval
       end if

    end do

    ! apply BC to the matrix ( make the diagonal as identity, and off
    ! diagonal as zero)
    ! off diagonal as zero
    D(1,:) = 0.0_WP
    D(NPOINTS,:) = 0.0_WP

    D(1,1) = 1.0_WP
    D(NPOINTS,NPOINTS) = 1.0_WP

    !D =  transpose(D)

!!$    do i = 1, NPOINTS
!!$       print *, i, D(i,:)
!!$    end do

    size = NPOINTS
    if ( .not. allocated(ipiv)   ) allocate( ipiv(size) )

    do n = 2, NSTEPS

       ! Previous solution is the RHS
       rhs = state(:, n-1)

#if defined COMPLEX
       call ZGESV(size, 1, D, size, IPIV, rhs, size, INFO)
#else
       call DGESV(size, 1, D, size, IPIV, rhs, size, INFO)
#endif
       if (INFO .ne. 0) then
          print*, "LAPACK ERROR:", info
          call MPI_STOP_ALL
       end if

       ! Result is the next solution
       state(:, n)  = rhs

       write(*,'(F15.3,E15.3)') (n-1)*dt, norm2(state(:,n-1) - state(:,n))/sqrt(dble(NPOINTS))

    end do

    ! write the solution
    open (unit = 2, file = "solution.dat")
    write(2,*) 'variables= "x","t","u"'
    write(2,*) 'zone i=', NPOINTS,' j=',NSTEPS,' datapacking=point'
    do i = 1, NSTEPS
       do j = 1, NPOINTS
          write (2,*) dble(j-1)*dx, dble(i-1)*dt, state(j,i)
       end do
    end do
    close(2)

    if (allocated(ipiv)) deallocate(ipiv)

    deallocate(rhs)
    deallocate(state)
    deallocate(xpts)
    deallocate(D)

  end subroutine execute

  !-------------------------------------------------------------------!
  ! Initialize the simulation
  !-------------------------------------------------------------------!

  subroutine initialize()

    use mpi_wrapper

    integer :: i                    ! loop counter
    integer :: argc                 ! number of command line arguments
    character(len=25) :: argv       ! a command line argument
    character(len=10) :: today_date
    character(len=8)  :: today_time

    ! INITIALIZE MPI

    call MPI_START_ALL()

    ! PRINT DETAILS

    if (master) then

       write(LOG_UNIT,*)
       write(LOG_UNIT,*) '======================================================='
       write(LOG_UNIT,*) '                    DIFFUSION                          '
       write(LOG_UNIT,*) '======================================================='
       write(LOG_UNIT,*)

       ! author
       write(LOG_UNIT, *) &
            '           Author:  Komahan Boopathy'

       ! email
       write(LOG_UNIT, *) &
            '            Email:  komahan@gatech.edu'

       ! institute
       write(LOG_UNIT, *) &
            '     Developed At:  Georgia Institute of Technology'

       ! version
       write(LOG_UNIT, '(6X,"Version:",7X,I1,".",I1,".",I1)') &
            VERSION_MAJOR, VERSION_MINOR, VERSION_RELEASE

       ! date and time of execution
       call clock_tot % getDateTime(today_date, today_time)
       write(LOG_UNIT, '(6X,"Date/Time:",5X,A,1X,A)') &
            trim(today_date), trim(today_time)

       ! number of processors
       write(LOG_UNIT, '(1X,A,I0)') '     MPI Processes: ',numproc

    end if

    ! PROCESS COMMAND LINE ARGS

    ! get number of command line arguments
    argc = COMMAND_ARGUMENT_COUNT()

    ! begin loop around command line args
    do i = 1,argc

      ! get that argument
      call GET_COMMAND_ARGUMENT(i,argv)

      ! begin case structure
      select case(trim(argv))

        ! solver
        case('--solver_type')

          ! get next argument
          call GET_COMMAND_ARGUMENT(i+1,argv)

          ! set global var
          solver_type = trim(argv)

        ! do nothing here
        case DEFAULT

      end select

    end do

    ! Start the total timer clock
    call clock_tot % start()

  end subroutine initialize

  !-------------------------------------------------------------------!
  ! Finalize the simulation
  !-------------------------------------------------------------------!

  subroutine finalize()

    use mpi_wrapper

    ! stop timer
    call clock_tot % stop()

    ! print output
    if (master) then
       write(LOG_UNIT, '(/,A)') '======================================================='
       write(LOG_UNIT, '(A)')   '                    RESULTS                            '
       write(LOG_UNIT, '(A,/)') '======================================================='
       write(LOG_UNIT, '("Total Execution time (s): ",F0.4)') clock_tot % elapsed
    end if

    call MPI_STOP_ALL

  end subroutine finalize

end program main


!  *********************************************************************
!  *                                                                   *
!  *                        function gamln                             *
!  *                                                                   *
!  *********************************************************************
!  Single Precision Version 1.0
!  Written by Gordon A. Fenton, TUNS, Apr. 13, 1993
!
!  PURPOSE  returns the natural logarithm of the gamma function of the
!           supplied argument, z >= 0.
!
!  This routine calculates the definite integral
!
!                  inf
!    gamma(z) = int  t**(z-1)*exp(-t) dt
!                  0
!
!  which is the Gamma function, for argument z >= 0, and returns ln(gamma(z)).
!  The method used is an approximation derived by Lanczos as presented by
!  Press etal. in "Numerical Recipes in C", page 167. This algorithm supposedly
!  has a error of less than 2.E-10. See also GAMMA.f which has a relative
!  error of less than 1.E-14 and is based on a series expansion and can handle
!  negative arguments.
!  Arguments are as follows;
!
!     z    non-negative real value for which the gamma function is desired.
!          (input)
!
!  NOTES: 1) (MXFAC-1)! is the maximum integer factorial we can find without
!            overflowing
!         2) the integer factorial values are stored in fac(i) for later
!            (efficient) use. The first 7 are set explicitly, ie fac(1-7) =
!            0!, 1!, ..., 6!.
!         3) set IDEBUG to 1 if you want overflow errors reported.
!--------------------------------------------------------------------------
      real function gamln(z)
      parameter (IDEBUG = 1, MXFAC = 34)
      dimension cof(6), fac(MXFAC)
      data cof/76.180091730,-86.50532033,24.01409822,                     &
              -1.231739516,  .120858003e-2,-.536382e-5/
      data stp/2.50662827465/, eps/0.119209e-06/
      data zero,half,one,fpf/0.,0.5,1.0,5.5/
      data nfac/7/
      data (fac(i),i=1,7)/1.,1.,2.,6.,24.,120.,720./

   1  format(a,e13.6,a)

      if( z .lt. zero ) then
         if( IDEBUG .eq. 1 )                                              &
           write(0,1)'Negative argument (',z,') in GAMLN.'
         gamln = zero
         return
      endif
!					is z an integer?
      q = z*(one + eps)
      n = int( q )
      f = z - float(n)
      if( f .lt. q*eps .and. n .le. MXFAC ) then
         if( n .gt. nfac ) then
            do 10 i = nfac, n-1
               fac(i+1) = float(i)*fac(i)
  10        continue
            nfac = n
         endif
         gamln = alog(fac(n))
         return
      endif
!					z is non-integer (or is a big integer)
      if( z .lt. one ) then
         x   = z
         az  = alog(z)
      else
         x  = z - one
         az = zero
      endif
      tmp = x + fpf
      tmp = (x+half)*alog(tmp) - tmp
      ser = one
      do 20 j = 1, 6
         x   = x + one
         ser = ser + cof(j)/x
  20  continue
      gamln = tmp + alog(stp*ser) - az
      return
      end


! Name: ARPIT KUMAR JAIN, Roll No: 180122009
PROGRAM ChebyshevInterpolationExp
    IMPLICIT NONE
    REAL, PARAMETER :: pi = acos(-1.0)
    INTEGER:: n, k, j
    REAL:: Xk, TnX, X, Px
    REAL, DIMENSION(:), ALLOCATABLE:: C

    WRITE(*, fmt = '(/A)', ADVANCE = "NO") "Enter Order of Interpolation Polynomial: "
    READ(*, *) n
    ALLOCATE(C(0:n));

    WRITE(*, 10, ADVANCE = "NO") n
    10 FORMAT(/, "Enter the X value to find P", i0, "(X): ")
    READ(*, *) X

    Px = 0.0
    ! Calculating the coefficients and calculation of polynomial
    DO j = 0, n
        C(j) = 0.0
        DO k = 0, n
            Xk = cos(((2*k+1 )*pi)/(2*n+2))
            C(j) = C(j) + EXP(Xk) * TnX(xk, j)
        ENDDO
        IF(j .EQ. 0) THEN
            C(j) = C(j) * (1./(N+1))
        ELSE
            C(j) = C(j) * (2./(N+1))
        ENDIF
        Px = Px + C(j) * TnX(X, j)
    ENDDO

    WRITE(*, 11) X, Px
    11 FORMAT(/,"P(", f0.3, ") = ", f0.8/)

END PROGRAM ChebyshevInterpolationExp

FUNCTION TnX(x, n)
    IMPLICIT NONE
    REAL, PARAMETER :: pi = acos(-1.0)
    REAL:: x, TnX
    INTEGER:: n, i
    REAL, DIMENSION(0:n):: vector
    vector(0) = 1
    vector(1) = x
    IF(n .LE. 1) THEN
        TnX = vector(n)
    ELSE
        DO i = 1, n-1
            vector(i+1) = 2.0*x*vector(i) - vector(i-1)
        ENDDO
        TnX = vector(n)
    ENDIF
    RETURN
END FUNCTION TnX


      program fortran_newtons

      REAL :: x,v2,Psi,phi0,functionPhi
      REAL functionPhiF
      REAL functionPhiDeri

      x = 0.3
      v2 = 0.1
      Psi = 1.5
      phi0 = 3.0
      call functionPhiEval(x, v2, Psi, phi0, functionPhi)
      print *, functionPhi
      print *, 'function : ', functionPhiF(x, v2, Psi, phi0)
      end

      ! phi = phi0 - v2 * sin[2(phi-Psi)]
      ! we need y = x + v2 * sin[2(x-Psi)] - phi0 = 0, where x is phi.
      subroutine functionPhiEval(x, v2, Psi, phi0, functionPhi)
        implicit none
        real, intent(IN)  :: x, v2, Psi, phi0
        real, intent(OUT) :: functionPhi

        functionPhi = ( x + v2*SIN(2*(x-Psi)) - phi0 )

      end subroutine functionPhiEval

      FUNCTION functionPhiF(x, v2, Psi, phi0)
      REAL x, v2, Psi, phi0
      functionPhiF = ( x + v2*SIN(2*(x-Psi)) - phi0 )
      RETURN
      END FUNCTION

      FUNCTION functionPhiDeri(x, v2, Psi)
      REAL x, v2, Psi
      functionPhiDeri = ( 1 + v2*cos(2*(x-Psi))*2 )
      RETURN
      END FUNCTION