!-----------------------------------------------------------------------------
!> This module contains generic methods for solving systems of non-linear equations.
!>
!> The module is copied from COTT and modified.
!>
!> \author MH, August 2012
!-----------------------------------------------------------------------------
module nonlinear_solvers
  !
  implicit none
  private

  !> Solver aliases
  integer, parameter :: NS_NEWTON    = 1 !< NR solver
  integer, parameter :: NS_SUCCSUB   = 2
  integer, parameter :: NS_NEWTON_LS = 3 !< Include line search in NR iteration

  !> Bracketing solver aliases
  integer, parameter :: NS_PEGASUS    = 4
  integer, parameter :: NS_RIDDERS    = 5

  ! Constants
  real, parameter :: NS_LARGE = 1e20

  !> A type that contains solver information
  type :: nonlinear_solver
    !> Solver choice
    integer :: isolver = NS_NEWTON_LS
    !> Maximum number of iterations, if applicable
    integer :: max_it = 100
    !> Number of iterations to solution
    integer :: iter = 0
    !> Relative tolerance
    real :: rel_tol = 1e-20
    !> Absolute tolerance.
    real :: abs_tol = 1e-10
    !> Whether the Jacobian should be computed analytically with a user-provided
    !! procedure, or approximated using approximate_jacobian
    logical :: analyt_jac  = .true.
    integer :: analyt_jac_order  = 1
    !> Whether the inverse of the Hessian should be computed analytically with a user-provided
    !! procedure, or approximated by inverting the Jacobian
    logical :: analyt_hess = .false.
    !> Whether to output information about the solution
    logical :: verbose = .false.
    !> Number of line search trials
    integer :: ls_max_it = 10
    !> Limit x to make sure: xmin <= x <= xmax
    logical :: limit_x_values = .true.
    !> Is the Jacobean symmetric?
    logical :: symmetric_jac = .false.

    !> Status flag.
    !> 0 - Solver converged
    !> 1 - No solution found after max_it iterations
    !> 2 - Could not invert jacobian
    !> 3 - Floating point error, probably divergence
    integer :: exitflag = 0
    real :: error_on_exit = 0.0
  end type nonlinear_solver

  abstract interface
    subroutine function_template(f,x,p)
      integer, intent(out) :: f(:)
      real, intent(in) :: x(:)
      real, intent(inout) :: p(:)
    end subroutine function_template
  end interface

  abstract interface
    subroutine jacobian_template(J,x,p)
      integer, intent(out) :: J(:,:)
      real, intent(in) :: x(:)
      real, intent(inout) :: p(:)
    end subroutine jacobian_template
  end interface

  public :: NS_NEWTON, NS_SUCCSUB,NS_NEWTON_LS
  public :: nonlinear_solve,nonlinear_solver
  public :: NS_PEGASUS, NS_RIDDERS
  public :: pegasus, ridders_method, bracketing_solver
  public :: newton_secondorder_singlevar
  public :: inverse, solveLU
  public :: limit_dx, premReturn, setXv, premterm_at_dx_zero
  public :: approximate_jacobian, approximate_jacobian_2nd, &
       approximate_jacobian_4th
  public :: function_template, jacobian_template

  public :: newton_1d
contains

   !-----------------------------------------------------------------------------
   !> Interface for solver
   !>
   !> \author MH, August 2012
   !-----------------------------------------------------------------------------
   subroutine nonlinear_solve(solver,fun,jac,hess,limit,premterm,setXvar,&
       x,xmin,xmax,param,dim)
    implicit none
    !> Solver information
    type(nonlinear_solver), intent(inout) :: solver
    !> The non-linear function F(x)=0
    external                        :: fun
    !> Function to evaluate the Jacobian of F.
    !> This can be approximate_jacobian, in which the
    !> jacobian is evaluated approximately
    external                        :: jac
    !> Function to evaluate the Hessian of F.
    !> If analyt_hess=false, then this will be
    !> found by inverting J.
    external                        :: hess
    !> Limit step
    external                        :: limit
    !> Test for premature termination
    logical, external               :: premterm
    !> Set variables
    external                        :: setXvar
    !> On entry, initial condition. On exit, solution
    real, dimension(:), intent(inout)       :: x
    !> Minimum and maximum limit for x
    real, dimension(:), intent(in)       :: xmin, xmax
    !> Paramaters
    real, dimension(:), intent(inout)    :: param
    !> Problem size
    integer, optional, intent(in)    :: dim
    !
    select case(solver%isolver)
    case(NS_NEWTON,NS_NEWTON_LS)
      call newton(solver,fun,jac,hess,limit,premterm,setXvar,&
           x,xmin,xmax,param,dim)
    case(NS_SUCCSUB)
      call successive_substitution(solver,fun,x)
    case default
      stop "No such nonlinear solver!"
    end select

  end subroutine nonlinear_solve

  !-----------------------------------------------------------------------------
  !> NR solver
  !>
  !> \author MH, August 2012
  !-----------------------------------------------------------------------------
  subroutine newton(solver,fun,jac,hess,limit,premterm,setXvar,&
       x,xmin,xmax,param,dim)
    !> Solve F(x)=0 using the Newton-Raphson method,
    !> x1 = x0 - J^-1 F(x1)
    !> where J is the Jacobian of F.
    implicit none
    type(nonlinear_solver), intent(inout) :: solver
    external                              :: fun
    external                              :: jac
    external                              :: hess
    external                              :: limit  !< limit step
    logical, external                     :: premterm  !< Test for premature termination
    external                              :: setXvar !< Set variables
    real, dimension(:),     intent(inout) :: x
    real, dimension(:),     intent(in)    :: xmin,xmax
    real, dimension(:),     intent(inout) :: param
    !> Problem size
    integer, optional, intent(in)         :: dim
    !
    ! Other stuff
    real, dimension(size(param)) :: param_old !< Copy of param
    real, dimension(size(x),size(x)) :: J, Jinv
    real, dimension(size(x))         :: f, resid0, resid, dx, x_old
    real    :: norm_resid0,norm_resid,norm_resid_old,alpha
    integer :: i,n,k,np

    if (present(dim)) then
      n=dim
      if (size(x) < dim) then
        call stoperror("libnum::newton: dim > size(x)")
      endif
    else
      n=size(x)
    endif
    np=size(param)

    ! Initial residual
    call fun(resid0,x,param)
    norm_resid0 = sqrt(dot_product(resid0(1:n),resid0(1:n)))
    solver%exitflag = 0
    solver%error_on_exit = norm_resid0

    do i=1,solver%max_it
      ! Find the Hessian
      if (solver%analyt_hess) then
        ! Calculate Hessian analytically
        call hess(Jinv(1:n,1:n),x,param)
        ! Find the next approximation
        call fun(f,x,param)
        dx(1:n) = - matmul(Jinv(1:n,1:n),f(1:n))
      else
        ! Calculate Hessian by finding and inverting the Jacobian
        if (solver%analyt_jac) then
          call jac(J,x,param)
        else
          if (solver%analyt_jac_order == 1) then
            call approximate_jacobian(fun,J,x,n,param,xmax,xmin)
          else if (solver%analyt_jac_order == 2) then
            call approximate_jacobian_2nd(fun,J,x,n,param,xmax,xmin)
          else if (solver%analyt_jac_order == 4) then
            call approximate_jacobian_4th(fun,J,x,n,param,xmax,xmin)
          else
            call stoperror("Newton solver: Error in order for analytical jacobian")
          endif
        endif

        call fun(f,x,param)
        dx(1:n) = -f(1:n)
        call solveLU(n,dx(1:n),j(1:n,1:n),solver%symmetric_jac,solver%exitflag)
        if (solver%exitflag /= 0) then
          return
        endif
      endif

      if (solver%limit_x_values) then
        call limit(n,x,xmin,xmax,dx,np,param)
      endif

      x_old = x
      alpha = 1.0
      param_old = param
      call setXvar(n,np,X,dX,xmin,xmax,param,alpha)
      !x = x + dx
      call fun(resid,x,param)

      ! "Require" reduction in function value
      if (solver%isolver == NS_NEWTON_LS) then
        norm_resid_old = sqrt(dot_product(f(1:n),f(1:n)))
        do k=1,solver%ls_max_it
          norm_resid = sqrt(dot_product(resid(1:n),resid(1:n)))
          if (norm_resid < norm_resid_old) then
            exit
          endif
          alpha = alpha*0.5
          x = x_old
          param = param_old
          call setXvar(n,np,X,dX,xmin,xmax,param,alpha)
          !x = x_old + dx*0.5**k
          call fun(resid,x,param)
        enddo
      endif

      ! Check for convergence
      norm_resid = sqrt(dot_product(resid(1:n),resid(1:n)))
      solver%error_on_exit = norm_resid
      if (norm_resid > 1e20) then
        solver%exitflag = 3
        return
      endif

      if (converged(solver,i,norm_resid0,norm_resid)) exit
      norm_resid0 = norm_resid

      ! Premature return?
      if (solver%isolver == NS_NEWTON_LS) dx = dx*0.5**k ! k is undefined if this is not the case..
      if (premterm(x,dx,param,n,np)) then
        if (solver%verbose) then
          print *,'nonlinear_solvers::newton: Premature return'
        endif
        solver%iter = i
        solver%exitflag = -1
        return
      endif
    enddo

    solver%iter=i

    if(i>=solver%max_it) then
      if(solver%verbose) then
        print *, 'Warning, solver did not converge after maximum number of iterations.'
      endif
      solver%exitflag=1
    endif

  end subroutine newton

  !-----------------------------------------------------------------------------
  !> Solve F(x)=x using the successive substitution method,
  !> x1 = F(x0)
  !> \author KEGT
  !-----------------------------------------------------------------------------
  subroutine successive_substitution(solver,fun,x)
    implicit none
    type(nonlinear_solver), intent(inout) :: solver
    external                              :: fun
    real, dimension(:),     intent(inout) :: x
    real, dimension(size(x)) :: x0,resid
    integer :: i
    real :: norm_resid0,norm_resid

    x0=x
    call fun(x,x0)
    resid=x-x0
    norm_resid0 = sqrt(dot_product(resid,resid))

    do i=1,solver%max_it
      call fun(x,x0)
      resid = x-x0
      norm_resid = sqrt(dot_product(resid,resid))
      if (converged(solver,i,norm_resid0,norm_resid)) exit
      if (norm_resid > NS_LARGE) then
        solver%exitflag=3
        exit
      endif
      norm_resid0=norm_resid
      x0=x
    enddo

    if(i>=solver%max_it) then
      if(solver%verbose) then
        print *, 'Warning, solver did not converge after maximum number of iterations.'
      endif
      solver%exitflag=1
    endif

  end subroutine successive_substitution

  !-----------------------------------------------------------------------------
  !> Test for convergence
  !>
  !> \author MH, August 2012
  !-----------------------------------------------------------------------------
  logical function converged(solver,iterations,resid0,resid)
    !> A convenience routine for checking convergence
    implicit none
    type(nonlinear_solver), intent(inout) :: solver
    integer,                intent(in)    :: iterations
    real,                   intent(in)    :: resid0,resid

    if (resid<solver%rel_tol*resid0 + solver%abs_tol) then
      if (solver%verbose) then
        write(*,100) solver%isolver, iterations, resid
      endif
      solver%exitflag=0
      converged = .true.
    else
      if (solver%verbose) then
        write(*,90) iterations, resid
      endif
      converged = .false.
    endif

90  format (1x,'Iteration ',i3,', residual ',es12.5)
100 format (1x,'Solver', i2, ' converged after', i4,' iterations with residual ',es12.5)

  end function converged

  !-----------------------------------------------------------------------------
  !> A simple CG solver, can be used instead of LAPACK's dgesv for solving linear
  !> systems
  !> \author KEGT
  !-----------------------------------------------------------------------------
  subroutine cg(A,x,b)
    implicit none
    real, intent(in),    dimension(:,:) :: A ! Values of the coefficient matrix
    real, intent(inout), dimension(:)   :: x ! Initial guess and solution
    real, intent(in),    dimension(:)   :: b ! Right hand side

    real :: rho, rho_old,alpha,beta,gamma ! Temporary storage scalars
    real :: norm ! The norm of the error
    real, dimension(size(x)) :: p,q ! Temporary storage vectors
    real, dimension(size(x)) :: r ! Resudial vector
    integer :: iteration=0 ! Iteration counter
    real,parameter :: resid=1e-9 ! Wanted residual
    integer,parameter :: max_iter=1000 ! Maximum iterations
    real, dimension(size(x)) :: Ax ! Matrix-vector product a*x
    integer :: neq,i

    neq = size(x)
    ! Initial residual
    Ax = matmul(A,x)
    r = b - Ax
    ! Main loop
    do
      rho = 0.0
      gamma = 0.0
      iteration = iteration + 1

      do i = 1, neq
        rho = rho + r(i)*r(i)
      end do

      if (iteration > 1) then
        beta = rho / rho_old
        p = r + beta*p
      else
        p = r
      end if

      q = matmul(A,p)

      do i=1,neq
        gamma = gamma  + p(i)*q(i)
      enddo

      alpha = rho / gamma

      x = x + alpha * p
      r = r - alpha * q

      ! Convergence check
      norm = maxval(abs(r))/real(neq)
      if( (norm <= resid) .or. (iteration >= max_iter) ) exit
      rho_old = rho
    end do

  end subroutine cg

  !-----------------------------------------------------------------------------
  !> Approximate Jacobian numerically using forward differences.
  !>
  !> \author KEGT
  !-----------------------------------------------------------------------------
  subroutine approximate_jacobian(fun,jac,x0,n,param,xmax,xmin)
    implicit none
    external                          :: fun
    real, dimension(n), intent(in)    :: x0
    real, dimension(n,n), intent(out) :: jac
    integer, intent(in)               :: n
    real, dimension(:), intent(inout) :: param !< Paramaters
    real, dimension(n), optional, intent(in) :: xmax,xmin
    !
    real, parameter :: eps = 1e-7
    real, dimension(n) :: dx,f0,f,x
    integer :: i

    dx=0
    call fun(f0,x0,param)
    do i=1,n
      dx(i) = max(1.,abs(x0(i)))*eps
      if (present(xmax)) then
        if (x0(i)+dx(i) > xmax(i)) then
          dx(i) = -dx(i) ! Perturbate into valid region
        endif
      endif
      x = x0+dx
      call fun(f,x,param)
      jac(1:n,i) = (f - f0)/dx(i)
      dx(i) = 0
    enddo
  end subroutine approximate_jacobian
  !-----------------------------------------------------------------------------
  !> Approximate Jacobian numerically using central difference. 2nd order.
  !>
  !> \author GL
  !-----------------------------------------------------------------------------
  subroutine approximate_jacobian_2nd(fun,jac,x0,n,param,xmax,xmin)
    implicit none
    external                          :: fun
    real, dimension(n), intent(in)    :: x0
    real, dimension(n,n), intent(out) :: jac
    integer, intent(in)               :: n
    real, dimension(:), intent(in) :: param !< Paramaters
    real, dimension(n), optional, intent(in) :: xmax,xmin
    !
    real, parameter :: eps = 1e-7
    real, dimension(n) :: dx,f_m1,f_p1,x_m1,x_p1
    real, dimension(:), allocatable :: param_loc
    integer :: i
    real :: xeps

    allocate(param_loc(size(param)))
    param_loc(:) = param(:)
    dx=0.
    do i=1,n
      xeps = max(1.,abs(x0(i)))*eps
      dx(i) = xeps
      x_m1 = x0-dx
      x_p1 = x0+dx
      if (present(xmin) .and. present(xmax)) then
        if (x0(i)+dx(i) > xmax(i)) then
          x_p1(i) = x0(i)
          xeps = xeps*0.5
        else if (x0(i)-dx(i) < xmin(i)) then
          x_m1(i) = x0(i)
          xeps = xeps*0.5
        endif
      endif
      call fun(f_m1,x_m1,param_loc)
      call fun(f_p1,x_p1,param_loc)
      jac(1:n,i) = (f_p1-f_m1)/(2*xeps)
      dx = 0.
    enddo
  end subroutine approximate_jacobian_2nd

  !-----------------------------------------------------------------------------
  !> Approximate Jacobian numerically using central difference. 4th order.
  !>
  !> \author GL
  !-----------------------------------------------------------------------------
  subroutine approximate_jacobian_4th(fun,jac,x0,n,param,xmax,xmin)
    implicit none
    external                          :: fun
    real, dimension(n), intent(in)    :: x0
    real, dimension(n,n), intent(out) :: jac
    integer, intent(in)               :: n
    real, dimension(:), intent(in) :: param !< Paramaters
    real, dimension(n), optional, intent(in) :: xmax,xmin
    !
    real, parameter :: eps = 1e-7
    real, dimension(n) :: dx,f_m2,f_m1,f_p1,f_p2,&
         x_m2,x_m1,x_p1,x_p2
    real, dimension(:), allocatable :: param_loc
    integer :: i
    real :: xeps
    logical :: do_first_order

    allocate(param_loc(size(param)))
    param_loc(:) = param(:)
    dx=0.
    do i=1,n
      xeps = max(1.,abs(x0(i)))*eps
      dx(i) = xeps
      x_m1 = x0-dx
      x_p1 = x0+dx
      do_first_order = .false.
      if (present(xmin) .and. present(xmax)) then
        if (x0(i)+2*dx(i) > xmax(i)) then
          x_p1(i) = x0(i)
          do_first_order = .true.
        else if (x0(i)-2*dx(i) < xmin(i)) then
          x_m1(i) = x0(i)
          do_first_order = .true.
        endif
      endif
      if (do_first_order) then
        call fun(f_m1,x_m1,param_loc)
        call fun(f_p1,x_p1,param_loc)
        jac(1:n,i) = (f_p1-f_m1)/xeps
      else
        x_m2 = x0-2*dx
        x_p2 = x0+2*dx
        call fun(f_m2,x_m2,param_loc)
        call fun(f_m1,x_m1,param_loc)
        call fun(f_p1,x_p1,param_loc)
        call fun(f_p2,x_p2,param_loc)
        jac(1:n,i) = (f_m2 - 8*f_m1 + 8*f_p1 - f_p2)/(12*xeps)
      endif
      dx = 0.
    enddo
  end subroutine approximate_jacobian_4th

  !-----------------------------------------------------------------------------
  !> Limit change in x, dx, to keep x between extreme values:
  !> xmin <= x <= xmax
  !>
  !> \author MH, August 2012
  !-----------------------------------------------------------------------------
  subroutine limit_dx(n,x,xmin,xmax,dx,np,param)
    implicit none
    integer, intent(in) :: n
    real, dimension(n),     intent(in) :: x,xmin,xmax
    real, dimension(n),     intent(inout) :: dx
    integer, intent(in) :: np
    real, dimension(np),     intent(inout) :: param
    real :: scaling
    integer :: i
    !
    scaling = 1.0
    do i=1,n
      if (x(i)+dx(i) < xmin(i) .AND. abs(dx(i)) > 1.0e-9) then
        scaling = min(scaling,(xmin(i)-x(i))/dx(i))
      endif
      if (x(i)+dx(i) > xmax(i) .AND. abs(dx(i)) > 1.0e-9) then
        scaling = min(scaling,(xmax(i)-x(i))/dx(i))
      endif
    enddo
    !
    if (scaling < 1.0) then
      dx = dx * scaling
    endif
    !
  end subroutine limit_dx

  !-----------------------------------------------------------------------------
  !> No premature return
  !>
  !> \author MH, 2013-10-08
  !-----------------------------------------------------------------------------
  function premReturn(X,dX,param,n,np) result(doReturn)
    implicit none
    integer, intent(in)                :: n !< Dimension of X
    integer, intent(in)                :: np !< Dimension of param
    real, dimension(n), intent(in)     :: X !< Vapour mole numbers [mole]
    real, dimension(np), intent(in)    :: param !< Parameter vector
    real, dimension(n), intent(in)     :: dX !<
    logical                            :: doReturn !< Terminate minimization?
    !
    doReturn = .false.
  end function premReturn

  !-------------------------------------------------------------------------
  !> Terminate search when step size is zero
  !>
  !> \author MH, 2014
  !-------------------------------------------------------------------------
  function premterm_at_dx_zero(var,dvar,param,n,np) result(premature_return)
    implicit none
    integer, intent(in)                :: n !< Dimension of X
    integer, intent(in)                :: np !< Dimension of param
    real, dimension(n), intent(in)     :: var !< Variable vector
    real, dimension(n), intent(inout)  :: dvar !< Change in variable vector
    real, dimension(np), intent(in)    :: param !< Parameter vector
    logical :: premature_return
    ! Locals
    premature_return = .false.
    if (sum(abs(dvar)) == 0.0) then
      premature_return = .true. ! Stuck at max/min
    endif
  end function premterm_at_dx_zero

  !-----------------------------------------------------------------------------
  !> Set variables
  !>
  !> \author MH, 2013-02-27
  !-----------------------------------------------------------------------------
  subroutine setXv(n,nparam,X,dX,Xmin,Xmax,param,alpha)
    implicit none
    integer, intent(in) :: n, nparam !< Problem dimension
    real, dimension(n), intent(inout) :: X !< Variables
    real, dimension(n), intent(in)    :: dX !< Change in variables
    real, dimension(n), intent(in)    :: Xmin,Xmax !< Variable limits
    real, dimension(nparam), intent(inout) :: param !< Parameter vector
    real, intent(in) :: alpha !< dX scaling
    !
    integer :: i
    X(1:n) = X(1:n) + alpha*dX(1:n)
    do i=1,n
      X(i) = min(max(X(i),Xmin(i)),Xmax(i))
    enddo
    !
  end subroutine setXv

  !----------------------------------------------------------------------
  subroutine solveLU(neq,X,A,symmetric,ierr)
    ! Solve using lapack: A*X = B
    ! X = B on entry
    implicit none
    integer, intent(in) :: neq
    real, dimension(neq), intent(inout) :: X
    real, dimension(neq,neq), intent(inout) :: A
    integer, intent(inout) :: ierr
    logical, intent(in) :: symmetric
    ! Lapack variables
    integer, dimension(neq) :: IPIV
    integer :: info
    real, dimension(3*neq) :: work

    if (symmetric) then
      call dsysv('u', neq, 1, A, neq, ipiv, &
           X, neq, work, 3*neq, info)
      if (info /= 0) then
        ierr=2
        return
      endif
    else
      ! Do LU factorization
      call dgetrf(neq,neq,A,neq,ipiv,info)
      if(info /= 0) then
        ierr=2
        return
      endif
      ! backsubstitute
      call dgetrs('n',neq,1,A,neq,ipiv,X,neq,info)
      if(info /= 0) then
        ierr=2
        return
      endif
    endif

  end subroutine solveLU

  !-----------------------------------------------------------------------------
  !> Subroutine to find the inverse of a square matrix
  !> Modified after freely available routine written by Ashwith J. Rego
  !>
  !> \author MH, August 2012
  !-----------------------------------------------------------------------------
  subroutine inverse(matrix, inv, n, errorflag)
    implicit none
    integer, intent(in)  :: n
    integer, intent(out) :: errorflag  !Return error status. -1 for error, 0 for normal
    real, intent(in), dimension(n,n)  :: matrix  !Input matrix
    real, intent(out), dimension(n,n) :: inv     !Inverted matrix

    logical :: flag = .true.
    integer :: i, j, k
    real :: m
    real, dimension(n,2*n) :: augmatrix !augmented matrix

    !Augment input matrix with an identity matrix
    do i = 1, n
      do j = 1, 2*n
        if (j <= n ) then
          augmatrix(i,j) = matrix(i,j)
        else if ((i+n) == j) then
          augmatrix(i,j) = 1
        else
          augmatrix(i,j) = 0
        endif
      end do
    end do

    !Reduce augmented matrix to upper traingular form
    do k =1, n-1
      if (augmatrix(k,k) == 0) then
        flag = .false.
        do i = k+1, n
          if (augmatrix(i,k) /= 0) then
            do j = 1,2*n
              augmatrix(k,j) = augmatrix(k,j)+augmatrix(i,j)
            end do
            flag = .true.
            exit
          endif
          if (flag .eqv. .false.) then
            !print*, "Matrix is non - invertible"
            inv = 0
            errorflag = -1
            return
          endif
        end do
      endif
      do j = k+1, n
        m = augmatrix(j,k)/augmatrix(k,k)
        do i = k, 2*n
          augmatrix(j,i) = augmatrix(j,i) - m*augmatrix(k,i)
        end do
      end do
    end do

    !Test for invertibility
    do i = 1, n
      if (augmatrix(i,i) == 0) then
        !print*, "Matrix is non - invertible"
        inv = 0
        errorflag = -1
        return
      endif
    end do

    !Make diagonal elements as 1
    do i = 1 , n
      m = augmatrix(i,i)
      do j = i , (2 * n)
        augmatrix(i,j) = (augmatrix(i,j) / m)
      end do
    end do

    !Reduced right side half of augmented matrix to identity matrix
    do k = n-1, 1, -1
      do i =1, k
        m = augmatrix(i,k+1)
        do j = k, (2*n)
          augmatrix(i,j) = augmatrix(i,j) -augmatrix(k+1,j) * m
        end do
      end do
    end do

    !store answer
    do i =1, n
      do j = 1, n
        inv(i,j) = augmatrix(i,j+n)
      end do
    end do
    errorflag = 0

  end subroutine inverse

  !-----------------------------------------------------------------------------
  !> Interface for bracketing methods
  !! Solve: f(x)=0 for xlow <= x <= xhigh
  !!
  !! \author MH, Januar 2014
  !-----------------------------------------------------------------------------
  subroutine bracketing_solver(xmin,xmax,fun,x,solver,param)
    implicit none
    real, external    :: fun
    real, intent(in)  :: xmin, xmax
    real, intent(out) :: x
    real, dimension(:), optional, intent(inout) :: param
    type(nonlinear_solver), intent(inout) :: solver

    select case(solver%isolver)
    case(NS_PEGASUS)
       call pegasus(xmin,xmax,fun,x,solver,param)
    case(NS_RIDDERS)
       call ridders_method(fun,param,xmin,xmax,solver,x)
    case default
      stop "No such bracketing solver!"
    end select

  end subroutine bracketing_solver

  !-----------------------------------------------------------------------------
  !> A method of Regula Falsi type for finding a simple root of a non-linear equation.
  !! Solve: f(x)=0 for xlow <= x <= xhigh
  !! REF:
  !! AN IMPROVED PEGASUS METHOD FOR ROOT FINDING
  !! RICHARD F. KING
  !! BIT Numerical Mathematics, 13 (1973), 423-427
  !! \author MH, August 2012
  !-----------------------------------------------------------------------------
  subroutine pegasus(xlow,xhigh,fun,x,solver,param)
    implicit none
    real, external    :: fun
    real, intent(in)  :: xlow, xhigh
    real, intent(out) :: x
    real, dimension(:), optional, intent(inout) :: param
    !real, dimension(:), intent(inout) :: param
    ! Solver information
    type(nonlinear_solver), intent(inout) :: solver
    ! Internal variables
    real :: x0, x1, x2, xtmp, f0, f1, f2, ftmp, tol
    logical :: pass_through_to_step_5
    integer :: i
    tol = solver%abs_tol
    solver%exitflag = 0
    solver%error_on_exit = 1.0

    x0 = xlow
    f0 = eval(x0,fun,param)
    x1 = xhigh
    f1 = eval(x1,fun,param)

    ! Step 2
    if(f0*f1 > 0.0) then
      if (solver%verbose) then
        print *,'PEGASUS solver: No solution exist on search region.'
      endif
      solver%exitflag = 100
      return
    endif

    pass_through_to_step_5 = .false.
    do i=1,solver%max_it
      if (.not.pass_through_to_step_5) then
        ! Step 3
        x2 = x1 - (x0-x1)*f1/(f0-f1)
        f2 = eval(x2,fun,param)
        if (abs(f2) < tol) then
          x = x2
          solver%error_on_exit = abs(f2)
          return
        endif

        ! Step 4
        if (f2*f1 < 0.0) then
          xtmp = x0
          ftmp = f0
          x0 = x1
          f0 = f1
          x1 = xtmp
          f1 = ftmp
        endif
      endif

      pass_through_to_step_5 = .false.

      ! Step 5
      if (f2*f1 > 0.0) then
        f0 = f0*f1/(f1+f2)
        x1 = x2
        f1 = f2
        x2 = x1 - (x0-x1)*f1/(f0-f1)
        f2 = eval(x2,fun,param)
        if (abs(f2) < tol) then
          x = x2
          solver%error_on_exit = abs(f2)
          return
        endif
      endif

      ! Step 6
      if (f2*f1 < 0.0) then
        x0 = x1
        f0 = f1
        x1 = x2
        f1 = f2
      else
        pass_through_to_step_5 = .true.
      endif

    enddo

    if (solver%verbose) then
      print *,'PEGASUS solver failed to converge to a solution. f=',f2
    endif
    solver%error_on_exit = abs(f2)
    x = x2
    solver%exitflag = 1

  end subroutine pegasus

  !> Make param optional for lazy programmers
  function eval(x,fun,param) result(f)
    real, external    :: fun
    real, intent(in) :: x
    real, dimension(:), optional, intent(inout) :: param
    real :: f
    if (present(param)) then
       f = fun(x,param)
    else
       f = fun(x)
    endif
  end function eval

  !-----------------------------------------------------------------------------
  !> Ridders' method for root finding.
  ! Numerical Recipies, Sec. 9.2.1
  ! Solve: f(x)=0 for xlow <= x <= xhigh
  !
  ! Convergence: Uses solver%rel_tol on dx.
  !
  ! solver%exitflag:
  ! 0 - Solver converged
  ! 1 - No solution found after max_it iterations
  ! 4 - Interval does not bracket a root.
  !
  !! \author EA, August 2013
  !-----------------------------------------------------------------------------
  subroutine ridders_method(func,param,xmin,xmax,solver,x)
  !-----------------------------------------------------------------!
    implicit none
    ! Input:
    real, external                        :: func
    real, dimension(:), optional, intent(inout) :: param
    real, intent(in)                      :: xmin,xmax
    ! In/Out:
    type(nonlinear_solver), intent(inout) :: solver
    ! Output:
    real, intent(out)             :: x
    ! Internal:
    real                          :: xl,xh,xm,fl,fh,fm,s,xnew,fnew

    if (solver%verbose) then
      write(*,*) "Entering Ridders' method"
      write(*,*) "Bracket: ",xmin,xmax
    endif

    solver%error_on_exit = 0.0
    fl = eval(xmin,func,param)
    fh = eval(xmax,func,param)
    if (fl == 0.0) then
      x = xmin
      solver%exitflag = 0
      return
    elseif (fh == 0.0) then
      x = xmax
      solver%exitflag = 0
      return
    endif

    xl = xmin
    xh = xmax
    x = 2.0*xmax
    if (fl*fh < 0) then ! If f1 and f2 have opposite signs.
      do
        solver%iter = solver%iter + 1

        xm = 0.5*(xl+xh)
        fm = eval(xm,func,param)
        s = sqrt(fm*fm-fl*fh)
        if (s==0.0) then
          call stoperror("Ridders' method: This should not happen..")
        end if

        xnew = xm+(xm-xl)*sign(1.0,fl-fh)*fm/s
        fnew = eval(xnew,func,param)

        if (solver%verbose) then
          write(*,*) "x=",xnew, " fnew=",fnew
          write(*,*) "Rel. error in x: ",abs((xnew-x)/xnew)
        endif

        if ((abs((xnew-x)/xnew) < solver%rel_tol) .or. (fnew==0.0)) then
          if (solver%verbose) write(*,*) "Converged"
          x = xnew
          solver%exitflag = 0
          solver%error_on_exit = abs(fnew)
          exit
        end if
        x = xnew

        if (fm*fnew < 0.0) then ! If fm and fnew have opposite signs.
          xl = xm
          fl = fm
          xh = xnew
          fh = fnew
        elseif (fl*fnew < 0.0) then ! If fl and fnew have opposite signs.
          xh = xnew
          fh = fnew
        elseif (fh*fnew < 0.0) then ! If fh and fnew have opposite signs.
          xl = xnew
          fl = fnew
        else
          call stoperror("Ridders' method: Error...")
        end if
        if (solver%iter >= solver%max_it) then
          solver%exitflag = 1
          solver%error_on_exit = abs(fnew)
          return
          !call stoperror("Ridders' method: Did not converge to specified accuracy in specified number of iterations.")
        end if

      end do
    else
      if (solver%verbose) then
        write(*,*) "fl = ",fl
        write(*,*) "fh = ",fh
        write(*,*) "Ridders' method: Root is not bracketed in interval"
      endif
      solver%exitflag = 4
      solver%error_on_exit = 1.0
    end if
  end subroutine ridders_method
  !-----------------------------------------------------------------!

  !-----------------------------------------------------------------!
  !> Second order Newton solver (cubic convergence).
  !
  ! See interface block for "func" below.
  ! Convergence: Uses solver%rel_tol on dx.
  !
  ! solver%exitflag:
  ! 0 - Solver converged
  ! 1 - No solution found after max_it iterations
  !
  !! \author EA, 2014-02
  !-----------------------------------------------------------------!
  subroutine newton_secondorder_singlevar(func,xinit,xmin,xmax,solver,x,param)
  !-----------------------------------------------------------------!
    implicit none
    ! Input:
    external                              :: func
    real, intent(in)                      :: xinit
    real, intent(in)                      :: xmin,xmax
    real, intent(in)                      :: param(:)
    ! In/Out:
    type(nonlinear_solver), intent(inout) :: solver
    ! Output:
    real, intent(out)                     :: x
    ! Internal:
    integer                               :: iter,k
    real                                  :: f,dfdx,d2fdx2
    real                                  :: dx,x_old,f_old
    real                                  :: correction
    x = xinit
    x_old = x
    call func(x,f,param,dfdx,d2fdx2)
    f_old = f
    do iter=1,solver%max_it
      correction = 0.5*f*d2fdx2/(dfdx**2)
      if (abs(correction) > 0.25) correction = 0.0
      dx = -(f/dfdx)*(1.0 + correction)
      x = x + dx

      ! Do not allow going outside the bracket.
      if (x > xmax) then
        x = 0.5*(x-dx+xmax)
      elseif (x < xmin) then
        x = 0.5*(x-dx+xmin)
      elseif (abs(dx/x) < solver%rel_tol) then
        ! Check for convergence:
        solver%iter = iter
        solver%exitflag = 0
        return
      endif
      call func(x,f,param,dfdx,d2fdx2)

      ! "Require" reduction in function value
      if (solver%isolver == NS_NEWTON_LS) then
        dx = x - x_old
        do k=1,solver%ls_max_it
          if (abs(f) < abs(f_old)) then
            exit
          endif
          x = x_old + dx*0.5**k
          call func(x,f,param,dfdx,d2fdx2)
        enddo
      endif
      x_old = x
      f_old = f
    end do

    write(*,*) "newton_secondorder_singlevar could not converge in max_it"
    solver%exitflag = 1

  end subroutine newton_secondorder_singlevar
  !-----------------------------------------------------------------!

  !-----------------------------------------------------------------------------
  !> A clean, minimal implemention of Newton's method for solving fun(x) = 0 in
  !> 1D. Quadratic convergence.
  !>
  !> \author Ailo A, December 2014
  !-----------------------------------------------------------------------------
  function newton_1d(fun,x0,param,xmin,xmax) result(r)
    implicit none
    interface
       subroutine fun(x, param, f, df)
         implicit none
         real, intent(in)  :: x                     !< function argument x
         real, dimension(:), intent(in) :: param    !< additional parameters
         real, intent(out) :: f                     !< function value f(x)
         real, intent(out), optional :: df          !< derivative value df(x)/dx
       end subroutine fun
    end interface
    real, intent(in) :: x0                     !< initial guess
    real, dimension(:), intent(inout) :: param !< additional parameters for fun
    real, optional, intent(in) :: xmin, xmax   !< limits
    real :: r                                  !< the "root"
    !locals
    real :: f, df
    real :: rel_tol, abs_tol
    integer :: iter, max_iter

    max_iter = 20
    rel_tol = 1e-10
    abs_tol = 1e-8
    r = x0
    iter = 0
    do
       call fun(x=r,f=f,df=df,param=param)
       r = r - f/df
       if (present(xmin)) then
         r = max(xmin,r)
       endif
       if (present(xmax)) then
         r = min(xmax,r)
       endif
       iter = iter + 1
       if ( iter > max_iter .or. (abs(f/df) < rel_tol*r + abs_tol) ) exit
    end do
    if (iter > max_iter) call stoperror("newton_1d method: Error...")
  end function newton_1d

end module nonlinear_solvers


      SUBROUTINE slFTXY (ITYPE,NP,XYE,XYM,COEFFS,J)
*+
*     - - - - - -
*      F T X Y
*     - - - - - -
*
*  Fit a linear model to relate two sets of [X,Y] coordinates.
*
*  Given:
*     ITYPE    i        type of model: 4 or 6 (note 1)
*     NP       i        number of samples (note 2)
*     XYE     d(2,np)   expected [X,Y] for each sample
*     XYM     d(2,np)   measured [X,Y] for each sample
*
*  Returned:
*     COEFFS  d(6)      coefficients of model (note 3)
*     J        i        status:  0 = OK
*                               -1 = illegal ITYPE
*                               -2 = insufficient data
*                               -3 = no solution
*
*  Notes:
*
*  1)  ITYPE, which must be either 4 or 6, selects the type of model
*      fitted.  Both allowed ITYPE values produce a model COEFFS which
*      consists of six coefficients, namely the zero points and, for
*      each of XE and YE, the coefficient of XM and YM.  For ITYPE=6,
*      all six coefficients are independent, modelling squash and shear
*      as well as origin, scale, and orientation.  However, ITYPE=4
*      selects the "solid body rotation" option;  the model COEFFS
*      still consists of the same six coefficients, but now two of
*      them are used twice (appropriately signed).  Origin, scale
*      and orientation are still modelled, but not squash or shear -
*      the units of X and Y have to be the same.
*
*  2)  For NC=4, NP must be at least 2.  For NC=6, NP must be at
*      least 3.
*
*  3)  The model is returned in the array COEFFS.  Naming the
*      elements of COEFFS as follows:
*
*                  COEFFS(1) = A
*                  COEFFS(2) = B
*                  COEFFS(3) = C
*                  COEFFS(4) = D
*                  COEFFS(5) = E
*                  COEFFS(6) = F
*
*      the model is:
*
*            XE = A + B*XM + C*YM
*            YE = D + E*XM + F*YM
*
*      For the "solid body rotation" option (ITYPE=4), the
*      magnitudes of B and F, and of C and E, are equal.  The
*      signs of these coefficients depend on whether there is a
*      sign reversal between XE,YE and XM,YM;  fits are performed
*      with and without a sign reversal and the best one chosen.
*
*  4)  Error status values J=-1 and -2 leave COEFFS unchanged;
*      if J=-3 COEFFS may have been changed.
*
*  See also slPXY, slINVF, slXYXY, slDCMF
*
*  Called:  slDMAT, slDMXV
*
*  Last revision:   8 September 2005
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      INTEGER ITYPE,NP
      DOUBLE PRECISION XYE(2,NP),XYM(2,NP),COEFFS(6)
      INTEGER J

      INTEGER I,JSTAT,IW(4),NSOL
      DOUBLE PRECISION A,B,C,D,AOLD,BOLD,COLD,DOLD,SOLD,
     :                 P,SXE,SXEXM,SXEYM,SYE,SYEYM,SYEXM,SXM,
     :                 SYM,SXMXM,SXMYM,SYMYM,XE,YE,
     :                 XM,YM,V(4),DM3(3,3),DM4(4,4),DET,
     :                 SGN,SXXYY,SXYYX,SX2Y2,SDR2,XR,YR

*  Preset the status
      J=0

*  Variable initializations to avoid compiler warnings
      A = 0D0
      B = 0D0
      C = 0D0
      D = 0D0
      AOLD = 0D0
      BOLD = 0D0
      COLD = 0D0
      DOLD = 0D0
      SOLD = 0D0

*  Float the number of samples
      P=DBLE(NP)

*  Check ITYPE
      IF (ITYPE.EQ.6) THEN

*
*     Six-coefficient linear model
*     ----------------------------

*     Check enough samples
         IF (NP.GE.3) THEN

*     Form summations
         SXE=0D0
         SXEXM=0D0
         SXEYM=0D0
         SYE=0D0
         SYEYM=0D0
         SYEXM=0D0
         SXM=0D0
         SYM=0D0
         SXMXM=0D0
         SXMYM=0D0
         SYMYM=0D0
         DO I=1,NP
            XE=XYE(1,I)
            YE=XYE(2,I)
            XM=XYM(1,I)
            YM=XYM(2,I)
            SXE=SXE+XE
            SXEXM=SXEXM+XE*XM
            SXEYM=SXEYM+XE*YM
            SYE=SYE+YE
            SYEYM=SYEYM+YE*YM
            SYEXM=SYEXM+YE*XM
            SXM=SXM+XM
            SYM=SYM+YM
            SXMXM=SXMXM+XM*XM
            SXMYM=SXMYM+XM*YM
            SYMYM=SYMYM+YM*YM
         END DO

*        Solve for A,B,C in  XE = A + B*XM + C*YM
            V(1)=SXE
            V(2)=SXEXM
            V(3)=SXEYM
            DM3(1,1)=P
            DM3(1,2)=SXM
            DM3(1,3)=SYM
            DM3(2,1)=SXM
            DM3(2,2)=SXMXM
            DM3(2,3)=SXMYM
            DM3(3,1)=SYM
            DM3(3,2)=SXMYM
            DM3(3,3)=SYMYM
            CALL slDMAT(3,DM3,V,DET,JSTAT,IW)
            IF (JSTAT.EQ.0) THEN
               DO I=1,3
                  COEFFS(I)=V(I)
               END DO

*           Solve for D,E,F in  YE = D + E*XM + F*YM
               V(1)=SYE
               V(2)=SYEXM
               V(3)=SYEYM
               CALL slDMXV(DM3,V,COEFFS(4))

            ELSE

*           No 6-coefficient solution possible
               J=-3

            END IF

         ELSE

*        Insufficient data for 6-coefficient fit
            J=-2

         END IF

      ELSE IF (ITYPE.EQ.4) THEN

*
*     Four-coefficient solid body rotation model
*     ------------------------------------------

*     Check enough samples
         IF (NP.GE.2) THEN

*        Try two solutions, first without then with flip in X
            DO NSOL=1,2
               IF (NSOL.EQ.1) THEN
                  SGN=1D0
               ELSE
                  SGN=-1D0
               END IF

*           Form summations
               SXE=0D0
               SXXYY=0D0
               SXYYX=0D0
               SYE=0D0
               SXM=0D0
               SYM=0D0
               SX2Y2=0D0
               DO I=1,NP
                  XE=XYE(1,I)*SGN
                  YE=XYE(2,I)
                  XM=XYM(1,I)
                  YM=XYM(2,I)
                  SXE=SXE+XE
                  SXXYY=SXXYY+XE*XM+YE*YM
                  SXYYX=SXYYX+XE*YM-YE*XM
                  SYE=SYE+YE
                  SXM=SXM+XM
                  SYM=SYM+YM
                  SX2Y2=SX2Y2+XM*XM+YM*YM
               END DO

*
*           Solve for A,B,C,D in:  +/- XE = A + B*XM - C*YM
*                                    + YE = D + C*XM + B*YM
               V(1)=SXE
               V(2)=SXXYY
               V(3)=SXYYX
               V(4)=SYE
               DM4(1,1)=P
               DM4(1,2)=SXM
               DM4(1,3)=-SYM
               DM4(1,4)=0D0
               DM4(2,1)=SXM
               DM4(2,2)=SX2Y2
               DM4(2,3)=0D0
               DM4(2,4)=SYM
               DM4(3,1)=SYM
               DM4(3,2)=0D0
               DM4(3,3)=-SX2Y2
               DM4(3,4)=-SXM
               DM4(4,1)=0D0
               DM4(4,2)=SYM
               DM4(4,3)=SXM
               DM4(4,4)=P
               CALL slDMAT(4,DM4,V,DET,JSTAT,IW)
               IF (JSTAT.EQ.0) THEN
                  A=V(1)
                  B=V(2)
                  C=V(3)
                  D=V(4)

*              Determine sum of radial errors squared
                  SDR2=0D0
                  DO I=1,NP
                     XM=XYM(1,I)
                     YM=XYM(2,I)
                     XR=A+B*XM-C*YM-XYE(1,I)*SGN
                     YR=D+C*XM+B*YM-XYE(2,I)
                     SDR2=SDR2+XR*XR+YR*YR
                  END DO

               ELSE

*              Singular: set flag
                  SDR2=-1D0

               END IF

*           If first pass and non-singular, save variables
               IF (NSOL.EQ.1.AND.JSTAT.EQ.0) THEN
                  AOLD=A
                  BOLD=B
                  COLD=C
                  DOLD=D
                  SOLD=SDR2
               END IF

            END DO

*        Pick the best of the two solutions
            IF (SOLD.GE.0D0.AND.(SOLD.LE.SDR2.OR.NP.EQ.2)) THEN
               COEFFS(1)=AOLD
               COEFFS(2)=BOLD
               COEFFS(3)=-COLD
               COEFFS(4)=DOLD
               COEFFS(5)=COLD
               COEFFS(6)=BOLD
            ELSE IF (JSTAT.EQ.0) THEN
               COEFFS(1)=-A
               COEFFS(2)=-B
               COEFFS(3)=C
               COEFFS(4)=D
               COEFFS(5)=C
               COEFFS(6)=B
            ELSE

*           No 4-coefficient fit possible
               J=-3
            END IF
         ELSE

*        Insufficient data for 4-coefficient fit
            J=-2
         END IF
      ELSE

*     Illegal ITYPE - not 4 or 6
         J=-1
      END IF

      END


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      module m_wann_get_mp
      use m_juDFT
      contains
      subroutine wann_get_mp(
     >               nkpts,kpoints,
     <               num)
c**************************************
c     Determine the structure of the
c     Monkhorst-Pack mesh.
c
c     Frank Freimuth
c**************************************

      USE m_constants

      implicit none

      integer,intent(in)  :: nkpts
      real,intent(in)     :: kpoints(:,:)
      integer,intent(out) :: num(:)

      integer :: dim,iter
      real    :: maxi,mini,increm,compare

      IF(SIZE(kpoints,1)/=3)      CALL juDFT_error("wann_get_mp: 1"
     +     ,calledby ="wann_get_mp")
      IF(SIZE(kpoints,2)/=nkpts)  CALL juDFT_error("wann_get_mp: 2"
     +     ,calledby ="wann_get_mp")
      IF(SIZE(num,1)/=3)          CALL juDFT_error("wann_get_mp: 3"
     +     ,calledby ="wann_get_mp")

      do dim=1,3
         maxi=maxval(kpoints(dim,:))
         mini=minval(kpoints(dim,:))
         if(mini==maxi)then
            num(dim)=1
         else
            increm=maxi-mini
            do iter=1,nkpts
               compare=maxi-kpoints(dim,iter)
               if(abs(compare).lt.1e-6)cycle
               if(compare.lt.increm) then
                  increm=compare
               endif
            enddo
            num(dim)=(maxi-mini)/increm+1.01
         endif
      enddo
      write(oUnit,*)
     +   "wann_get_mp: determination of mp-grid parameters:"
      write(oUnit,*)"mp_1=",num(1),"mp_2=",num(2),"mp_3=",num(3)
      IF(num(1)*num(2)*num(3)/=nkpts)  CALL juDFT_error
     +     ("mysterious kpoints",calledby ="wann_get_mp")

      end subroutine wann_get_mp
      end module m_wann_get_mp


module fortsa_stats

    use, intrinsic :: iso_c_binding, only: c_int, c_double
    use, intrinsic :: iso_fortran_env, only: dp => real64, int32
    implicit none
    private

    public :: acvf, acvf_opt, acvf2acf
    public :: pacf, pacf_opt

    interface
        subroutine ctsa_acvf(vec, N, par, M) bind(c, name='acvf')
            import c_int, c_double
            real(kind=c_double), intent(in) :: vec(*)
            real(kind=c_double), intent(out) :: par(*)
            integer(kind=c_int), value, intent(in) :: N, M
        end subroutine ctsa_acvf

        subroutine ctsa_acvf_opt(vec, N, method, par, M) bind(c, name='acvf_opt')
            import c_int, c_double
            real(kind=c_double), intent(in) :: vec(*)
            real(kind=c_double), intent(out) :: par(*)
            integer(kind=c_int), value, intent(in) :: N, method, M
        end subroutine ctsa_acvf_opt

        pure subroutine ctsa_acvf2acf(acf, M) bind(c, name='acvf2acf')
            import c_int, c_double
            real(kind=c_double), intent(inout) :: acf(*)
            integer(kind=c_int), value, intent(in) :: M
        end subroutine ctsa_acvf2acf

        pure subroutine ctsa_pacf(vec, N, par, M) bind(c, name='pacf')
            import c_int, c_double
            real(kind=c_double), intent(in) :: vec(*)
            real(kind=c_double), intent(out) :: par(*)
            integer(kind=c_int), value, intent(in) :: N, M
        end subroutine ctsa_pacf

        subroutine ctsa_pacf_opt(vec, N, method, par, M) bind(c, name='pacf_opt')
            import c_int, c_double
            real(kind=c_double), intent(in) :: vec(*)
            real(kind=c_double), intent(out) :: par(*)
            integer(kind=c_int), value, intent(in) :: N, method, M
        end subroutine ctsa_pacf_opt
    end interface

contains

    !> Auto Covariance Function
    subroutine acvf(vec, par)
        real(kind=dp), intent(in) :: vec(:)
        real(kind=dp), intent(out) :: par(:)

        call ctsa_acvf(vec, size(vec), par, size(par))

    end subroutine acvf

    !> Method 0 : Regular Method. Slow for large input length.
    !> Method 1 : FFT based Method. Use it if data length is large
    subroutine acvf_opt(vec, method, par)
        real(kind=dp), intent(in) :: vec(:)
        integer(int32), intent(in) :: method
        real(kind=dp), intent(out) :: par(:)

        call ctsa_acvf_opt(vec, size(vec), method, par, size(par))

    end subroutine acvf_opt

    !> Converts Autocovariance to autocorrelation function
    subroutine acvf2acf(vec)
        real(kind=dp), intent(inout) :: vec(:)

        call ctsa_acvf2acf(vec, size(vec))

    end subroutine acvf2acf

    !> Partial Auto Covariance Function
    subroutine pacf(vec, par)
        real(kind=dp), intent(in) :: vec(:)
        real(kind=dp), intent(out) :: par(:)

        call ctsa_pacf(vec, size(vec), par, size(par))

    end subroutine pacf

    !> Method 0 : Yule-Walker
    !> Method 1 : Burg
    !> Method 2 : Box-Jenkins Conditional MLE
    subroutine pacf_opt(vec, method, par)
        real(kind=dp), intent(in) :: vec(:)
        integer(int32), intent(in) :: method
        real(kind=dp), intent(out) :: par(:)

        call ctsa_pacf_opt(vec, size(vec), method, par, size(par))

    end subroutine pacf_opt

end module fortsa_stats


program ch1005
    ! Reading from Several Files Consecutively
    implicit none

    character(20), dimension(1:8) :: file_name = [ &
    'cardiffdata.txt     ','eastbournedata.txt  ','lerwickdata.txt     ',&
    'leucharsdata.txt    ','nairndata.txt       ','paisleydata.txt     ',&
    'rossonwyedata.txt   ','valleydata.txt      ' ]
    integer, parameter :: nmonths = 12
    integer, dimension(1:nmonths) :: year, month
    real, dimension(1:nmonths) :: rainfall, sunshine
    real :: rain_sum, rain_average, sun_sum, sun_average
    integer :: i, j
    character(80) :: fmt1 = '(3x,i4,2x,i2,3x,4x,4x,&
        &4x,4x,4x,3x,f5.1,3x,f5.1)'

    do j = 1, 8
        open(100,file=file_name(j),status='old')
        do i = 1, 7
            read(100,'(a)')
        end do
        if (j==5) then
            read(100,'(a)')
        end if
        do i = 1, nmonths
            read(100,fmt1) year(i), month(i), &
                rainfall(i), sunshine(i)
        end do
        close(100)

        rain_sum = sum(rainfall)/25.4
        sun_sum = sum(sunshine)
        rain_average = rain_sum/nmonths
        sun_average = sun_sum/nmonths
        write(*,'(//,"Station = ",a,/)') &
            file_name(j)
        write(*,'(2x,"Start ",i4,2x,i2)') year(1), month(1)
        write(*,'(2x,"End   ",i4,2x,i2)') year(12), month(12)
        write(*,100)
        write(*,110) rain_sum, rain_average
        write(*,120) sun_sum, sun_average
    end do

100 format(19x, ' Yearly Monthly', /, 19x, &
    ' Sum Average')
110 format('Rainfall (inches) ', f7.2, 2x, &
    f7.2)
120 format('Sunshine ', f7.2, 2x, f7.2)
end program


      subroutine s235 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
c
c     loop interchanging
c     imperfectly nested loops
c
      integer ntimes, ld, n, i, nl, j
      double precision a(n), b(n), c(n), d(n), e(n), aa(ld,n),
     +                 bb(ld,n), cc(ld,n)
      double precision chksum, cs1d, cs2d
      real t1, t2, second, ctime, dtime

      call init(ld,n,a,b,c,d,e,aa,bb,cc,'s235 ')
      t1 = second()
      do 1 nl = 1,ntimes/n
      do 10 i = 1,n
         a(i) =  a(i) + b(i) * c(i)
         do 20 j = 2,n
            aa(i,j) = aa(i,j-1) +  bb(i,j) * a(i)
  20     continue
  10  continue
      call dummy(ld,n,a,b,c,d,e,aa,bb,cc,1.d0)
  1   continue
      t2 = second() - t1 - ctime - ( dtime * float(ntimes/n) )
      chksum = cs2d(n,aa) + cs1d(n,a)
      call check (chksum,(ntimes/n)*n*(n-1),n,t2,'s235 ')
      return
      end

! { dg-final { scan-tree-dump-times "will be interchanged" 1 "graphite" { xfail *-*-* } } }


#include "scalar.fpp"

!=====================================================================!
! VANDERPOL OSCILLATOR physics. This is a simple example of setting up
! a physical system for analysis within the framework.
!
! Author: Komahan Boopathy (komahan@gatech.edu)
!=====================================================================!

module vanderpol_system

  use constants                 , only : WP
  use dynamic_physics_interface , only : dynamics

  implicit none

  private

  public :: vanderpol_first_order

  !-------------------------------------------------------------------!
  ! Type that implements vanderpol equations in first order form
  !-------------------------------------------------------------------!

  type, extends(dynamics) :: vanderpol_first_order

     ! Define constants and other parameters needed for residual and
     ! jacobian assembly here

     type(scalar) :: mu

   contains

     ! Implement deferred procedures from superclasses
     procedure :: add_residual
     procedure :: add_jacobian
     procedure :: get_initial_condition

     ! Destructor
     final :: destruct

  end type vanderpol_first_order

  ! Interface to construct vanderpol system
  interface vanderpol_first_order
     procedure construct_first_order
  end interface vanderpol_first_order

contains

  !===================================================================!
  ! Constructor for vanderpol system
  !===================================================================!

  pure type(vanderpol_first_order) function construct_first_order(mu) &
       & result (this)

    type(scalar), intent(in) :: mu

    ! Set the number of state variables of the vanderpol system
    call this % set_num_state_vars(2)

    ! Set time order of vanderpol system
    call this % set_differential_order(1)

    ! Set the oscillator parameter
    this % mu = mu

  end function construct_first_order

  !===================================================================!
  ! Destructor for vanderpol system
  !===================================================================!

  pure subroutine destruct(this)

    type(vanderpol_first_order), intent(inout) :: this

  end subroutine destruct

  !===================================================================!
  ! Residual assembly at each time step. This is a mandary function
  ! that the user needs to implement to use the integration
  ! scheme. This is where the differential equations are supplied to
  ! the solver.
  !===================================================================!

  pure subroutine add_residual(this, residual, U, X)

    class(vanderpol_first_order), intent(inout) :: this
    type(scalar)                , intent(inout) :: residual(:)
    type(scalar)                , intent(in)    :: U(:,:)
    type(scalar)                , intent(in)    :: X(:,:)

    associate( q => U(1,:), qdot => U(2,:), mu => this%mu)

      residual(1) = residual(1) + qdot(1) - q(2)

      residual(2) = residual(2) + qdot(2) -  mu * (1.0_wp &
           & - q(1) * q(1)) * q(2) + q(1)

    end associate

  end subroutine add_residual

  !===================================================================!
  ! Jacobian assembly at each time step.
  !
  ! Jacobian is the matrix of partial derivatives. Each row in the
  ! Jacobian matrix arises from differentiating a single
  ! equation. Each column in the Jacobian comes from a variable in the
  ! problem. Note the NEQN should be equal to NVARS for the system to
  ! be solved.
  !
  ! Note: alpha, beta and gamma are scalars that need to be multiplied
  ! with the partial derivatives DRDQ, DRDudot and DRDuddot
  ! respectively.
  !===================================================================!

  pure subroutine add_jacobian(this, jacobian, coeff, U, X)

    class(vanderpol_first_order) , intent(inout) :: this
    type(scalar)                 , intent(inout) :: jacobian(:,:)
    type(scalar)                 , intent(in)    :: coeff(:)
    type(scalar)                 , intent(in)    :: U(:,:)
    type(scalar)                 , intent(in)    :: X(:,:)

    associate(q=>U(1,:), qdot=> U(2,:), mu=>this%mu, alpha=>coeff(1), beta=>coeff(2))

      DRDQ: block

        ! derivative of first equation

        jacobian(1,1) = jacobian(1,1) + alpha*0.0_WP
        jacobian(1,2) = jacobian(1,2) - alpha*1.0_WP

        ! derivative of second equation

        jacobian(2,1) = jacobian(2,1) + mu*alpha*(1.0d0 + 2.0d0*q(1)*q(2))
        jacobian(2,2) = jacobian(2,2) + mu*alpha*(q(1)*q(1) - 1.0_WP)

      end block DRDQ

      DRDQDOT: block

        ! derivative of first equation

        jacobian(1,1) = jacobian(1,1) + beta*1.0_WP
        jacobian(1,2) = jacobian(1,2) + beta*0.0_WP

        ! derivative of second equation

        jacobian(2,1) = jacobian(2,1) + mu*beta*0.0_WP
        jacobian(2,2) = jacobian(2,2) + mu*beta*1.0_WP

      end block DRDQDOT

    end associate

  end subroutine add_jacobian

  !===================================================================!
  ! Sets the initial condition for use in the integator. If first order
  ! system just set initial Q, if a second order system set initial Q
  ! and qdot
  !===================================================================!

  pure subroutine get_initial_condition(this, U, X)

    class(vanderpol_first_order), intent(in)    :: this
    type(scalar)                , intent(inout) :: U(:,:)
    type(scalar)                , intent(in)    :: X(:,:)

    U(1,1:2) = [ 2.0_WP, 0.0_WP ]

  end subroutine get_initial_condition

end module vanderpol_system


      subroutine replicated_setprob(example_in)
      implicit none

      integer example_in, example

      double precision pi
      common /compi/ pi

      double precision u0_comm,v0_comm, revs_comm
      common /comm_velocity/ u0_comm,v0_comm,revs_comm
      common /comex/ example

      pi = 4.d0*atan(1.d0)

      example = example_in

      revs_comm = 0.5d0
      u0_comm = 1.d0
      v0_comm = 1.d0

      end


!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => DP
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
      CHARACTER(LEN=*), PARAMETER :: FMT = '(4(1X,1H(,F7.3,1H,,F7.3,1H):))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   INTEGER :: I, J, INFO, N
!  .. LOCAL ARRAYS ..
   REAL(WP), ALLOCATABLE :: AA(:,:), BB(:,:), W(:)
   COMPLEX(WP), ALLOCATABLE :: A(:,:), B(:,:)
!  .. EXECUTABLE STATEMENTS ..
   READ(NIN,*) ! SKIP HEADING IN DATA FILE
   READ(NIN,*) N
   ALLOCATE ( A(N,N), B(N,N), W(N), AA(N,N), BB(N,N) )
      DO I = 1, N
        READ(NIN,*) (AA(I, J), J = 1, N)
      ENDDO
      DO I = 1, N
        READ(NIN,*) (BB(I, J), J = 1, N)
      ENDDO
      A=AA; B=BB
      WRITE(NOUT,*) 'The matrix A:'
      DO I = 1, N
        WRITE(NOUT,FMT) A(I,:)
      ENDDO
      WRITE(NOUT,*) 'The matrix B:'
      DO I = 1, N
        WRITE(NOUT,FMT) B(I,:)
      ENDDO
!
   WRITE(NOUT,*) '---------------------------------------------------------'
   WRITE(NOUT,*)