C       Calculate the initial guess of phase shift bwteen profile and template
C       and DM

      subroutine initialguess(prof,tmpl,nchan,nbins,shift_bg,eshift,
     +                        dDM_bg,edDM,sca,freq,D_0,coef)
      parameter (twopi=3.141592653589793*2)
      Integer nchan,nbins,mwt
      real*8 prof(nchan,nbins),tmpl(nchan,nbins),sca(nchan)
      real*8 shift_bg,eshift,dDM_bg,edDM,chisq,coef
      real*8 chan_prof(nbins),chan_tmpl(nbins),D_0,freq(nchan)
      real*8 buf_s,buf_es,buf_es2,scale,x(nchan),y(nchan),ey(nchan)

      do i=1,nchan
        do j=1,nbins
          chan_prof(j)=prof(i,j)
          chan_tmpl(j)=tmpl(i,j)
        end do
        call tmplmatch(chan_prof,chan_tmpl,nbins,buf_s,buf_es,buf_es2,
     +                 scale)
        if(buf_s.gt.twopi/2) then
          buf_s=buf_s-twopi
        end if
        sca(i)=scale
c       write(*,*)scale
        x(i)=D_0/freq(i)/freq(i)/nbins*twopi
        y(i)=buf_s
c       write(*,*)buf_s,freq(i)
        ey(i)=buf_es2
      end do

      mwt=1
      call fit(x,y,nchan,ey,mwt,shift_bg,dDM_bg,eshift,edDM,chisq,coef)

      return
      end

c     ****************************************************************
C     Calculate initial guess of phase shift when there is no DM fit
      subroutine initialguessnoDM(prof,tmpl,nchan,nbins,shift_bg,eshift,
     +     sca,wt)

      parameter (twopi=3.141592653589793*2)
      Integer nchan,nbins
      real*8 prof(nchan,nbins),tmpl(nchan,nbins),sca(nchan),wt(nchan)
      real*8 shift_bg,eshift,buf_s,buf_es,buf_es2
      real*8 chan_prof(nbins),chan_tmpl(nbins),scale,tot

c     Initial guess for scale
      do i=1,nchan
        do j=1,nbins
          chan_prof(j)=prof(i,j)
          chan_tmpl(j)=tmpl(i,j)
        end do
        call tmplmatch(chan_prof,chan_tmpl,nbins,buf_s,buf_es,buf_es2,
     +                 scale)
        sca(i)=scale
c       write(*,*)"Chan del (s):",buf_s/twopi*0.002946981889463*1.0d6,
c    +            buf_es/twopi*0.002946981889463*1.0d6
      end do

c     Add in frequency
      tot=0.0
      do i=1,nbins
         chan_prof(i)=0.0
         chan_tmpl(i)=0.0
      end do
      do j=1,nchan
         do i=1,nbins
            chan_prof(i)=chan_prof(i)+prof(j,i)*wt(j)
            chan_tmpl(i)=chan_tmpl(i)+tmpl(j,i)
         end do
         tot=tot+wt(j)
      end do
      do i=1,nbins
         chan_prof(i)=chan_prof(i)/tot
         chan_tmpl(i)=chan_tmpl(i)/nchan
      end do

c     Run 1D template matching
      call tmplmatch(chan_prof,chan_tmpl,nbins,buf_s,buf_es,buf_es2,
     +               scale)
      if(buf_s.gt.twopi/2) then
        buf_s=buf_s-twopi
      end if

      shift_bg=buf_s
      eshift=buf_es
      return
      end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!
!!!!   MIT License
!!!!
!!!!   ParaMonte: plain powerful parallel Monte Carlo library.
!!!!
!!!!   Copyright (C) 2012-present, The Computational Data Science Lab
!!!!
!!!!   This file is part of the ParaMonte library.
!!!!
!!!!   Permission is hereby granted, free of charge, to any person obtaining a
!!!!   copy of this software and associated documentation files (the "Software"),
!!!!   to deal in the Software without restriction, including without limitation
!!!!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!!!!   and/or sell copies of the Software, and to permit persons to whom the
!!!!   Software is furnished to do so, subject to the following conditions:
!!!!
!!!!   The above copyright notice and this permission notice shall be
!!!!   included in all copies or substantial portions of the Software.
!!!!
!!!!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
!!!!   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
!!!!   MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
!!!!   IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
!!!!   DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
!!!!   OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE
!!!!   OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
!!!!
!!!!   ACKNOWLEDGMENT
!!!!
!!!!   ParaMonte is an honor-ware and its currency is acknowledgment and citations.
!!!!   As per the ParaMonte library license agreement terms, if you use any parts of
!!!!   this library for any purposes, kindly acknowledge the use of ParaMonte in your
!!!!   work (education/research/industry/development/...) by citing the ParaMonte
!!!!   library as described on this page:
!!!!
!!!!       https://github.com/cdslaborg/paramonte/blob/master/ACKNOWLEDGMENT.md
!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module Matrix_mod

    implicit none

    character(*), parameter :: MODULE_NAME = "@Matrix_mod"

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

contains

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! ATTN: if nd=1, PosDefMat will not be touched, only sqrt(PosDefMat) will be output to Diagonal.
    ! ATTN: if Cholesky factorization fails, Diagonal(1) will be set to -1 to indicate error on return.
    ! Returns in the lower triangle of PosDefMat, the Cholesky factorization L of PosDefMat=L.L^T.
    ! On input, the upper upper triangle of PosDefMat should be given, which remains intact on output.
    pure subroutine getCholeskyFactor(nd,PosDefMat,Diagonal)
#if defined DLL_ENABLED && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getCholeskyFactor
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in)    :: nd
        real(RK)   , intent(inout) :: PosDefMat(nd,nd) ! Upper triangle + diagonal is input matrix, lower is output.
        real(RK)   , intent(out)   :: Diagonal(nd)
        real(RK)                   :: summ
        integer(IK)                :: i
        do i=1,nd
            summ = PosDefMat(i,i) - dot_product(PosDefMat(i,1:i-1),PosDefMat(i,1:i-1))
            if (summ <= 0._RK) then
                Diagonal(1) = -1._RK
                return
            end if
            Diagonal(i) = sqrt(summ)
            PosDefMat(i+1:nd,i) = ( PosDefMat(i,i+1:nd) - matmul(PosDefMat(i+1:nd,1:i-1),PosDefMat(i,1:i-1)) ) / Diagonal(i)
        end do
    end subroutine getCholeskyFactor

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! Solves the linear equation system of the form: PosDefMat.InputSolution = Intercept
    ! PosDefMat and Diagonal are the output of subroutine getCholeskyFactor (i.g., only the lower triangle of PosDefMat is used).
    subroutine solveLinearPosDefSystem(nd,PosDefMat,Diagonal,Intercept,InputSolution)
#if defined DLL_ENABLED && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: solveLinearPosDefSystem
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in)    :: nd
        real(RK)   , intent(in)    :: PosDefMat(nd,nd),Diagonal(nd),Intercept(nd)
        real(RK)   , intent(inout) :: InputSolution(nd)
        integer(IK)                :: i
        do i=1,nd
            InputSolution(i) = ( Intercept(i) - dot_product(PosDefMat(i,1:i-1),InputSolution(1:i-1)) ) / Diagonal(i)
        end do
        do i = nd,1,-1
            InputSolution(i) = ( InputSolution(i) - dot_product(PosDefMat(i+1:nd,i),InputSolution(i+1:nd)) ) / Diagonal(i)
        end do
    end subroutine solveLinearPosDefSystem

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! ATTN: Do not call this routine when nd = 1. There is no need to call this routine when nd = 1.
    ! This code returns the inverse matrix of a symmetric-positive-definite input matrix.
    ! which is given in the upper triangle of MatInvMat.
    ! On output MatInvMat is completely overwritten by in the inverse of the matrix.
    ! Also returns: determinant of the inverse matrix.
    ! Amir Shahmoradi, Apr 21, 2017, 1:54 AM, ICES, UT Austin
    pure subroutine getInvPosDefMatSqrtDet(nd,MatInvMat,sqrtDetInvPosDefMat)
#if defined DLL_ENABLED && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getInvPosDefMatSqrtDet
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in)    :: nd
        real(RK)   , intent(inout) :: MatInvMat(nd,nd)           ! input: upper half is covariance matrix, output: inverse matrix
        real(RK)   , intent(out)   :: sqrtDetInvPosDefMat        ! determinant of the inverse matrix
        real(RK)                   :: CholeskyLower(nd,nd)       ! Cholesky factor
        real(RK)                   :: Diagonal(nd)               ! diagonal terms of the inverse matrix
        real(RK)                   :: summ
        integer(IK)                :: i,j,k
        if (nd==1_IK) then
            MatInvMat = 1._RK / MatInvMat
            sqrtDetInvPosDefMat = MatInvMat(1,1)
            return
        end if
        do j=1,nd
            do i=1,j
                CholeskyLower(i,j) = MatInvMat(i,j)
            end do
        end do
        call getCholeskyFactor(nd,CholeskyLower,Diagonal)
        if (Diagonal(1)<0._RK) then
            sqrtDetInvPosDefMat = -1._RK
            return
        end if
        sqrtDetInvPosDefMat = 1._RK / product(Diagonal)
        do i = 1,nd
            CholeskyLower(i,i) = 1._RK / Diagonal(i)
            do j = i+1,nd
                summ = 0._RK
                do k = i,j-1
                    summ = summ - CholeskyLower(j,k) * CholeskyLower(k,i)
                end do
                CholeskyLower(j,i) = summ / Diagonal(j)
            end do
        end do
        do i = 1,nd
            do j = i,nd
                MatInvMat(j,i) = dot_product(CholeskyLower(j:nd,j),CholeskyLower(j:nd,i))
            end do
            MatInvMat(i,i:nd) = MatInvMat(i:nd,i)
        end do
  end subroutine getInvPosDefMatSqrtDet

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! ATTN: There is no need to call this routine when nd = 1. For nd==1: InvMatFromCholFac = 1._RK / Diagonal(1)**2
    ! Returns the inverse of a matrix whose Cholesky Lower triangle is given in the lower part of CholeskyLower,
    ! and its diagonal elements in Diagonal.
    pure function getInvMatFromCholFac(nd,CholeskyLower,Diagonal) result(InvMatFromCholFac)
#if defined DLL_ENABLED && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getInvMatFromCholFac
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in) :: nd
        real(RK)   , intent(in) :: CholeskyLower(nd,nd),Diagonal(nd)
        real(RK)                :: InvMatFromCholFac(nd,nd)
        real(RK)                :: summ
        integer(IK)             :: i,j,k
        if (nd==1_IK) then
            InvMatFromCholFac(1,1) = 1._RK / Diagonal(1)**2
            return
        end if
        InvMatFromCholFac = 0._RK
        do j=1,nd-1
            do i=j+1,nd
                InvMatFromCholFac(i,j) = CholeskyLower(i,j)
            end do
        end do
        do i = 1,nd
            InvMatFromCholFac(i,i) = 1._RK / Diagonal(i)
            do j = i+1,nd
                summ = 0._RK
                do k = i,j-1
                    summ = summ - InvMatFromCholFac(j,k) * InvMatFromCholFac(k,i)
                end do
                InvMatFromCholFac(j,i) = summ / Diagonal(j)
            end do
        end do
        do i = 1,nd
            do j = i,nd
                InvMatFromCholFac(j,i) = dot_product(InvMatFromCholFac(j:nd,j),InvMatFromCholFac(j:nd,i))
                InvMatFromCholFac(i,j) = InvMatFromCholFac(j,i)
            end do
            !InvMatFromCholFac(i,i:nd) = InvMatFromCholFac(i:nd,i)
        end do
    end function getInvMatFromCholFac

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! ATTN: Do not call this routine when nd = 1. Results may be wrong. There is no need to call this routine when nd = 1.
    ! exact same thing as subroutine getInvPosDefMatSqrtDet, but returns the result as a function.
    ! NOTE: according to my timing tests, compare_InvMatRoutines_1(),
    ! the function version seems to be 15-30% faster than the subroutine version above.
    ! In order to preserve the purity of the function, if an error occurs, for example,
    ! when the input matrix is not positive definite, then the first element of the output positive-definite inverse matrix
    ! will be set to -1._RK to indicate an error occurrence.
    ! On input, only the upper half of PosDefMat needs to be given.
    ! Amir Shahmoradi, Apr 8, 2017, 1:54 PM, ICES, UT
    pure function getInvPosDefMat(nd,PosDefMat) result(InvPosDefMat)
#if defined DLL_ENABLED && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getInvPosDefMat
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in) :: nd
        real(RK)   , intent(in) :: PosDefMat(nd,nd)
        real(RK)                :: InvPosDefMat(nd,nd), CholeskyLower(nd,nd)
        real(RK)                :: Diagonal(nd)
        real(RK)                :: summ
        integer(IK)             :: i,j,k
       !if (nd==1) then
       !    InvPosDefMat(1) = sqrt(PosDefMat(1))
       !    return
       !end if
        do j=1,nd
            do i=1,j
                CholeskyLower(i,j) = PosDefMat(i,j)
            end do
        end do
        call getCholeskyFactor(nd,CholeskyLower,Diagonal)
        if (Diagonal(1)<0._RK) InvPosDefMat(1,1) = -1._RK   ! error occurred: getCholeskyFactor() failed in getInvPosDefMat()
        do i = 1,nd
            CholeskyLower(i,i) = 1._RK / Diagonal(i)
            do j = i+1,nd
                summ = 0._RK
                do k = i,j-1
                    summ = summ - CholeskyLower(j,k) * CholeskyLower(k,i)
                end do
                CholeskyLower(j,i) = summ / Diagonal(j)
            end do
        end do
        do i = 1,nd
            InvPosDefMat(i,i) = dot_product(CholeskyLower(j:nd,j),CholeskyLower(j:nd,i))
            do j = i+1,nd
                InvPosDefMat(j,i) = dot_product(CholeskyLower(j:nd,j),CholeskyLower(j:nd,i))
                InvPosDefMat(i,j) = InvPosDefMat(j,i)
            end do
        end do
  end function getInvPosDefMat

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! ATTN: Do not call this routine when nd = 1. Results may be wrong. There is no need to call this routine when nd = 1.
    ! This code returns the inverse matrix InverseMatrix of a n*n input matrix LU, and its determinant, using LU factorization.
    ! NOTE: according to my timing tests, compare_InvMatRoutines_1(),
    ! the function version of this code below seems to be 15-30% faster than this subroutine version.
    ! Amir Shahmoradi, Oct 18, 2009, 1:54 AM, MTU
    subroutine getInvMatDet(n,LU,InverseMatrix,detInvMat)
#if defined DLL_ENABLED && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getInvMatDet
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in)    :: n
        real(RK)   , intent(inout) :: LU(n,n)     ! on input it is the matrix, on output it is LU decomposition
        real(RK)   , intent(out)   :: InverseMatrix(n,n)
        real(RK)   , intent(out)   :: detInvMat   ! determinant of the inverse matrix
        integer(IK)                :: i,j,Permutation(n)
        do i = 1,n
            do j = 1,n
                InverseMatrix(i,j) = 0._RK
            end do
            InverseMatrix(i,i) = 1._RK
        end do
        call getLU(n,LU,Permutation,detInvMat)
        do j = 1,n
            detInvMat = detInvMat * LU(j,j)
            call solveLinearSystem(n,LU,Permutation,InverseMatrix(1:n,j))
        end do
        detInvMat = 1._RK/detInvMat
  end subroutine getInvMatDet

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! ATTN: Do not call this routine when nd = 1. Results may be wrong. There is no need to call this routine when nd = 1.
    ! exact same thing as subroutine getInvMatDet, but returns the result as a function.
    ! NOTE: according to my timing tests, compare_InvMatRoutines_1(),
    ! the function version seems to be 15-30% faster than the subroutine version above.
    ! Amir Shahmoradi, Apr 8, 2017, 1:54 PM, MTU
    function getInvMat(n,S)
#if defined DLL_ENABLED && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getInvMat
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in) :: n
        real(RK)   , intent(in) :: S(n,n)
        real(RK)                :: getInvMat(n,n),DummyMat(n,n)
        integer(IK)             :: i,j,Permutation(n)
        real(RK)                :: parity
        do i = 1,n
            do j = 1,n
                getInvMat(i,j) = 0._RK
            end do
            getInvMat(i,i) = 1._RK
        end do
        DummyMat = S
        call getLU(n,DummyMat,Permutation,parity)
        do j = 1,n
            call solveLinearSystem(n,DummyMat,Permutation,getInvMat(1:n,j))
        end do
    end function getInvMat

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! Solves the set of n linear equations Array.X = InputSolution. Here A is input, not as the matrix A but
    ! rather as its LU decomposition, determined by the routine getLU().
    ! Permutation is input as the permutation vector returned by getLU().
    ! InputSolution(1:n) is input as the right-hand side vector,
    ! and returns with the solution vector X.
    ! Array, nd, and Permutation are not modiffied by this routine and,
    ! can be left in place for successive calls with different right-hand sides InputSolution.
    ! This routine takes into account the possibility that InputSolution will begin with many zero elements,
    ! so it is efficient for use in matrix inversion.
    ! Amir Shahmoradi, Oct 18, 2009, 1:54 PM, MTU
    subroutine solveLinearSystem(nd,Array,Permutation,InputSolution)
#if defined DLL_ENABLED && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: solveLinearSystem
#endif
        use Constants_mod, only: RK, IK
        integer(IK), intent(in)    :: nd
        integer(IK), intent(in)    :: Permutation(nd)
        real(RK)   , intent(in)    :: Array(nd,nd)
        real(RK)   , intent(inout) :: InputSolution(nd)
        integer(IK)                :: i,ii
        real(RK)                   :: summ
        ii = 0
        do i=1,nd
            summ = InputSolution(Permutation(i))
            InputSolution(Permutation(i)) = InputSolution(i)
            if (ii /= 0) then
                summ = summ - dot_product( Array(i,ii:i-1) , InputSolution(ii:i-1) )
            else if (summ /= 0._RK) then
                ii = i
            end if
            InputSolution(i) = summ
        end do
        do i = nd,1,-1
            InputSolution(i) = ( InputSolution(i) - dot_product( Array(i,i+1:nd) , InputSolution(i+1:nd)) ) / Array(i,i)
        end do
    end subroutine solveLinearSystem

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! Returns the LU decomposition of the input matrix Array(nd,nd).
    ! Permutation(1:n) is an output vector that records the row permutation effected by the partial pivoting
    ! Parity is output as +-1 depending on whether the number of row interchanges was even or odd, respectively.
    ! This routine is used in combination with solveLinearSystem to solve linear equations or invert a matrix.
    ! Amir Shahmoradi, Apr 21, 2017, 1:43 PM, ICES, UT
    subroutine getLU(n,Array,Permutation,parity) !,errorMessage)
#if defined DLL_ENABLED && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getLU
#endif
        use Constants_mod, only: RK, IK
        use, intrinsic :: iso_fortran_env, only: output_unit
        !use Misc  , only: abortProgram
        integer(IK), intent(in)    :: n
        integer(IK), intent(out)   :: Permutation(n)
        real(RK)   , intent(inout) :: Array(n,n)
        real(RK)   , intent(out)   :: parity
        real(RK)   , parameter     :: TINY = 1.e-20_RK
        real(RK)                   :: aamax,dum,summ,vv(n)
        integer(IK)                :: i,imax,j,k
        parity = 1._RK
        do i = 1,n
            aamax = 0._RK
            do j=1,n
                if ( abs(Array(i,j)) > aamax ) aamax = abs( Array(i,j) )
            end do
            if (aamax == 0._RK) then
                write(*,*) 'Statistics@getLU() failed. Singular matrix detected.'
                stop
                !call abortProgram( output_unit , 1 , 1 , 'Statistics@getLU() failed. Singular matrix detected.' )
            end if
            vv(i) = 1._RK/aamax
        end do
        do j=1,n
            do i=1,j-1
                summ = Array(i,j)
                do k=1,i-1
                    summ = summ - Array(i,k)*Array(k,j)
                end do
                Array(i,j) = summ
            end do
            aamax = 0._RK
            do i = j, n
                summ = Array(i,j)
                do k = 1, j-1
                    summ = summ - Array(i,k)*Array(k,j)
                end do
                Array(i,j) = summ
                dum = vv(i) * abs(summ)
                if (dum >= aamax) then
                    imax = i
                    aamax = dum
                end if
            end do
            if (j /= imax)then
                do k=1,n
                    dum = Array(imax,k)
                    Array(imax,k) = Array(j,k)
                    Array(j,k) = dum
                end do
                parity = - parity
                vv(imax) = vv(j)
            end if
            Permutation(j) = imax
            if (Array(j,j) == 0._RK) Array(j,j) = TINY
            if (j /= n) then
                dum = 1._RK / Array(j,j)
                do i = j+1,n
                    Array(i,j) = Array(i,j) * dum
                end do
            endif
        end do
  end subroutine getLU

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! subroutine to find product of two matrices
    ! Product of two matrices is defined by c(i,j) = a(i,1)*b(1,j) + a(i,2)*b(2,j)+........+a(i,n)*b(n,j)
    ! Amir Shahmoradi, Oct 20, 2009, 10:56 PM, MTU
    subroutine multiplyMatrix(A,rowsA,colsA,B,rowsB,colsB,C)
#if defined DLL_ENABLED && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: multiplyMatrix
#endif
        use Constants_mod, only: RK, IK
        use, intrinsic :: iso_fortran_env, only: output_unit
        !use Misc  , only: abortProgram
        implicit none
        integer(IK), intent(in)  :: rowsA, colsA, rowsB, colsB !Matrix Dimensions
        real(RK)   , intent(in)  :: A(rowsA,colsA)
        real(RK)   , intent(in)  :: B(rowsB,colsB)
        real(RK)   , intent(out) :: C(rowsA,colsB)
        integer(IK)              :: i,j,k,rowsC,colsC !Counters
        if (colsA /= rowsB) then
            write(*,*) 'Matrix@multiplyMatrix() failed. dimensions of matrices do not match.'
            stop
            !call abortProgram( output_unit , 1 , 1 , 'Statistics@multiplyMatrix() failed. dimensions of matrices do not match.' )
        else
            rowsC = rowsA
            colsC = colsB
        end if
        ! Initialize product matrix to 0
        do i = 1, rowsC
            do j = 1, colsC
                C(i,j) = 0._RK
            end do
        end do
        ! Find product as per above formula
        do i = 1, rowsA
            do j = 1, colsB
                do k = 1, colsA
                    C(i,j) = C(i,j) + A(i,k)*B(k,j)
                end do
            end do
        end do
    end subroutine multiplyMatrix

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! Returns the determinant of a given nd*nd matrix InputMat, using LU factorization.
    ! Amir Shahmoradi, Oct 18, 2009, 4:10 PM, MTU
    function getDeterminant(nd,InputMat)
#if defined DLL_ENABLED && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getDeterminant
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in) :: nd
        real(RK)   , intent(in) :: InputMat(nd,nd)
        real(RK)                :: DummyMat(nd,nd)
        real(RK)                :: getDeterminant
        integer(IK)             :: Permutation(nd)
        integer(IK)             :: j
        DummyMat = InputMat
        call getLU(nd,DummyMat,Permutation,getDeterminant) !    This returns getDeterminant as +-1.
        do j=1,nd
            getDeterminant = getDeterminant*DummyMat(j,j)
        end do
    end function getDeterminant

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! Returns the determinant of a given positive-definite nd*nd matrix PosDefMat using Cholesky factorization.
    ! Amir Shahmoradi, Apr 21, 2017, 4:10 PM, ICES, UT
    function getSqrtDetPosDefMat(nd,PosDefMat)
#if defined DLL_ENABLED && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getSqrtDetPosDefMat
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in) :: nd
        real(RK)   , intent(in) :: PosDefMat(nd,nd)
        real(RK)                :: Diagonal(nd),DummyMat(nd,nd)
        real(RK)                :: getSqrtDetPosDefMat
        integer(IK)             :: i,j
        do j=1,nd
            do i=1,j
                DummyMat(i,j) = PosDefMat(i,j)
            end do
        end do
        call getCholeskyFactor(nd,DummyMat,Diagonal)
        if (Diagonal(1)<0._RK) then
            getSqrtDetPosDefMat = -1._RK
            return
        end if
        getSqrtDetPosDefMat = product(Diagonal)
    end function getSqrtDetPosDefMat

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! ATTN: if Cholesky factorization fails, logSqrtDetPosDefMat will be set to -1 to indicate error on return.
    ! Returns in the lower triangle of PosDefMat, the Cholesky factorization L of PosDefMat=L.L^T.
    ! On input, the upper upper triangle of PosDefMat should be given, which remains intact on output.
    pure subroutine getLogSqrtDetPosDefMat(nd,PosDefMat,logSqrtDetPosDefMat,failed)
#if defined DLL_ENABLED && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getLogSqrtDetPosDefMat
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in)     :: nd
        real(RK)   , intent(inout)  :: PosDefMat(nd,nd) ! Upper triangle + diagonal is input matrix, lower is output.
        real(RK)   , intent(out)    :: logSqrtDetPosDefMat
        logical    , intent(out)    :: failed
        real(RK)                    :: Diagonal(nd)
        real(RK)                    :: summ
        integer(IK)                 :: i
        failed = .false.
        do i=1,nd
            summ = PosDefMat(i,i) - dot_product(PosDefMat(i,1:i-1),PosDefMat(i,1:i-1))
            if (summ <= 0._RK) then
                failed = .true.
                return
            end if
            Diagonal(i) = sqrt(summ)
            PosDefMat(i+1:nd,i) = ( PosDefMat(i,i+1:nd) - matmul(PosDefMat(i+1:nd,1:i-1),PosDefMat(i,1:i-1)) ) / Diagonal(i)
        end do
        logSqrtDetPosDefMat = sum(log(Diagonal))
    end subroutine getLogSqrtDetPosDefMat

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! ATTN: Do not call this routine when nd = 1. Results may be wrong. There is no need to call this routine when nd = 1.
    ! Returns False value for isPosDef, if the Cholesky decomposition fails (i.e. matrix is not positive definite),
    ! otherwise isPosDef=true
    pure logical function isPosDef(nd,ArrayIn)
#if defined DLL_ENABLED && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: isPosDef
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in) :: nd
        real(RK)   , intent(in) :: ArrayIn(nd,nd)
        real(RK)                :: Array(nd,nd),p(nd)
        real(RK)                :: dummySum
        integer(IK)             :: i,j,k
        isPosDef = .true.
        Array = ArrayIn
        do i = 1,nd
            do j = i,nd
                dummySum = Array(i,j)
                do k = i-1,1,-1
                    dummySum = dummySum - Array(i,k) * Array(j,k)
                end do
                if(i==j)then
                    if(dummySum<=0._RK) then
                        isPosDef = .false.
                        return
                    end if
                    p(i) = sqrt(dummySum)
                else
                    Array(j,i)=dummySum/p(i)
                endif
            end do
        end do
    end function isPosDef

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function getOuterProd(Array1,Array2)
#if defined DLL_ENABLED && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getOuterProd
#endif
        use Constants_mod, only: RK, IK
        real(RK), intent(in) :: Array1(:),Array2(:)
        real(RK)             :: getOuterProd(size(Array1),size(Array2))
        getOuterProd = spread(Array1,dim=2,ncopies=size(Array2)) * spread(Array2,dim=1,ncopies=size(Array1))
    end function getOuterProd

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! returns an ordered matrix of the input matrix, by rearranging the columns corresponding to ColIndx to into the corresponding
    ! columns in ColIndxMap, while keeping the rest of the matrix structure intact.
    ! such that if it is positive-definite, it remains positive-definite.
    ! Since input matrix is symmetric, only the upper triangle of the input matrix will be used,
    ! and only the upper triangle of the output matrix will be computed.
    ! example:
    ! 11.0    12.0    13.0    14.0    15.0
    !  0.0    22.0    23.0    24.0    25.0
    !  0.0     0.0    33.0    34.0    35.0
    !  0.0     0.0     0.0    44.0    45.0
    !  0.0 *******     0.0     0.0    55.0
    ! goes to the following by a ColIndx=[4], ColIndxMap=[5]
    ! 11.0    12.0    13.0    15.0    14.0
    !  0.0    22.0    23.0    25.0    24.0
    !  0.0     0.0    33.0    35.0    34.0
    !  0.0     0.0     0.0    55.0    45.0
    !  0.0     0.0     0.0     0.0    44.0
    pure function sortPosDefMat(rank,PosDefMatUpper,lenColIndx,ColIndx,ColIndxMap) result(SortedPosDefMatUpper)
#if defined DLL_ENABLED && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: sortPosDefMat
#endif
        use Constants_mod, only: RK, IK
        integer(IK), intent(in) :: rank, lenColIndx, ColIndx(lenColIndx), ColIndxMap(lenColIndx)
        real(RK), intent(in)    :: PosDefMatUpper(rank,rank)
        real(RK)                :: SortedPosDefMatUpper(rank,rank)
        integer(IK)             :: iRow, iCol, iRowNew, iColNew, i
        loopIndx: do i = 1, lenColIndx
            do iCol = 1, rank
                iColNew = iCol
                if (iColNew==ColIndx(i)) then
                    iColNew = ColIndxMap(i)
                elseif (iColNew==ColIndxMap(i)) then
                    iColNew = ColIndx(i)
                end if
                do iRow = 1, iCol
                    iRowNew = iRow
                    if (iRowNew==ColIndx(i)) then
                        iRowNew = ColIndxMap(i)
                    elseif (iRowNew==ColIndxMap(i)) then
                        iRowNew = ColIndx(i)
                    end if
                    if (iRowNew>iColNew) then
                        SortedPosDefMatUpper(iRow,iCol) = PosDefMatUpper(iColNew,iRowNew)
                    else
                        SortedPosDefMatUpper(iRow,iCol) = PosDefMatUpper(iRowNew,iColNew)
                    end if
                end do
            end do
        end do loopIndx
    end function sortPosDefMat

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    pure subroutine symmetrizeUpperSquareMatrix(nd,UpperSquareMatrix)
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK) , intent(in)    :: nd
        real(RK)    , intent(inout) :: UpperSquareMatrix(nd,nd)
        integer(IK)                 :: i, j
        do j = 1, nd
            do i = 1,j-1
                UpperSquareMatrix(j,i) = UpperSquareMatrix(i,j)
            end do
        end do
    end subroutine symmetrizeUpperSquareMatrix

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! Note: on input, the full matrix PosDefMat must be given.
    ! returns the the Regression Coefficient Matrix, whose dimension is rankS11 by rankS22, as well as optionally the
    ! Schur complement of the S22 block of rank rankS22 of the input matrix PosDefMat of rank rankPDM.
    !  For example, if
    ! PosDefMat = | S11 S12 |
    !             | S21 S22 |
    ! then, the Regression Coefficient Matrix given S22 is: S12 * S22^(-1), whose rank is rankS11 by rankS22.
    ! The Schur complement of S22 is: SchurComplement = S11 - S12 * S22^(-1) * S21, whose rank is rankS11 by rankS11.
    ! For clarity, note that the rank of rankS11 + rankS22 = rankPDM.
    pure subroutine getRegresCoef(rankPDM,rankS11,rankS22,PosDefMat,RegresCoefMat,SchurComplement)
    !subroutine getRegresCoef(rankPDM,rankS11,rankS22,PosDefMat,RegresCoefMat,SchurComplement)
#if defined DLL_ENABLED && !defined CFI_ENABLED
        !DEC$ ATTRIBUTES DLLEXPORT :: getRegresCoef
#endif
        use Constants_mod, only: RK, IK
        implicit none
        integer(IK), intent(in)             :: rankPDM, rankS11, rankS22
        real(RK), intent(in)                :: PosDefMat(rankPDM,rankPDM)
        real(RK), intent(out)               :: RegresCoefMat(rankS11,rankS22)
        real(RK), intent(out), optional     :: SchurComplement(rankS11,rankS11)
        real(RK)                            :: InvS22(rankS22,rankS22), S22(rankS22,rankS22)
        integer(IK)                         :: startS22
        startS22 = rankS11 + 1
        S22 = PosDefMat(startS22:rankPDM,startS22:rankPDM)
        if (rankS22==1) then
            InvS22(1,1) = 1._RK/S22(1,1)
        else
            InvS22 = getInvPosDefMat(rankS22,S22)
        end if
        if (InvS22(1,1)<0._RK) then
            RegresCoefMat(1,1) = -1._RK
            return
        end if
        RegresCoefMat = matmul( PosDefMat(1:rankS11,startS22:rankPDM) , InvS22 )
        if (present(SchurComplement)) then
            SchurComplement = PosDefMat(1:rankS11,1:rankS11) - matmul( RegresCoefMat , PosDefMat(startS22:rankPDM,1:rankS11) )
        end if
    end subroutine getRegresCoef

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

end module Matrix_mod


program test_filter
    use fplus_filter
    implicit none

    ! local variables
    integer :: i, f
    real (kind=8) :: pi

    ! array for test-data
    integer, parameter :: n = 10000
    real (kind=8), dimension(n) :: tdata

    ! fill the array with data
    print*, "4th Order Butterworth filter with cutoff periods 100 and 200:"
    pi = ACOS(-1.)
    do f = 1, 100
        do i = 1, n
            tdata(i) = sin(pi/2*i/real(f))
        end do
        ! perform the filtering
        call BWBPASS(tdata,n,100.0_8,200.0_8,2)
        print*, "Period: ", f*4, "Sum: ", sum(abs(tdata))
    end do

end program


      module phys_constants

      real(kind=8), parameter :: h=6.626d-27,k=1.38d-16, &
       c=2.99792458d10,e=4.8032d-10,G=6.67d-8, &
       m=9.10938188d-28,mp=1.67262158d-24,pi=acos(-1d0),c2=c*c,sigb=5.6704d-5, &
       msun=1.998d33, sigt=6.6523d-25

      contains

        subroutine phys_constants_dummy()
        end subroutine phys_constants_dummy

      end module


module x
!Solve for x i.e. we are solving x = ( A^(-1) )*b

use inputs
use ab
implicit none

contains

subroutine T0(B0,q,T,cutoff_inf)
!^{0}T

implicit none

    !Lapack parameters.
    integer, parameter :: n = ss
    integer, parameter :: nrhs = 1
    integer, parameter :: lda = n
    integer, parameter :: ldb = n
    integer, parameter :: lwork = n
    integer :: info
    real, dimension(lwork) :: work
    integer, dimension(n) :: ipiv

	!q = |q|.
	!cutoff_inf = Cutoff for [2q,inf] integral.
	!T = Isospin
	!B0 = Right hand side of Ax=b. Then it gets replaced by the solution vector ^{0}T.
	real(8), intent(in) :: q,cutoff_inf
	integer, intent(in) :: T
	complex, dimension(ldb,nrhs), intent(out) :: B0

	!c1 = Counter
	!A0 = The matrix in the equation Ax=b.
	integer :: c1
	complex, dimension(:,:), allocatable :: A0

	allocate( A0(lda,n) )

	!Build the 0^A matrix
	call build_A(A0,q,0.0d0,T,VLAMBDA0,cutoff_inf)

	!Compute 1 - ^{0}A i.e. "^{0}B" in T matrix report.
	A0 = -A0
	do c1 = 1,n

		A0(c1,c1) = 1.0 + A0(c1,c1)

	enddo

	!Build right hand side vector in the equation Ax=b.
	call build_V(B0,q,T,V0,cutoff_inf)

	!Call to lapack to solve Ax=b using LU-factorization. The solution is written into B0.
	call cgesv(n,nrhs,A0,lda,ipiv,B0,ldb,info)

	deallocate(A0)

end subroutine

subroutine T_12_6(B12,B6,q,T)
!^{12}T,T_6

implicit none

  	!Lapack parameters.
    integer, parameter :: n = 2*ss
    integer, parameter :: nrhs = 1
    integer, parameter :: lda = n
    integer, parameter :: ldb = n
    integer, parameter :: lwork = n
    integer :: info
    real, dimension(lwork) :: work
    integer, dimension(n) :: ipiv

	!q = |q|
	!T = Isospin
	!B12,B6 = Solution vector ^{12}T,T_6.
	real(8), intent(in) :: q
	integer, intent(in) :: T
	complex, dimension(ss), intent(out) :: B12,B6

	!c1,c2 = Counters
	!Ann = The A matrix in the equation Ax=b.
	!Vnn = The right hand side (b matrix) in the equation Ax=b.
	!A11...A22 = Matrix entries in Ann.
	!VV1...VV2 = Vector entries in Vnn.
	integer :: c1,c2
	complex, dimension(:,:), allocatable :: Ann
	complex, dimension(:), allocatable :: Vnn
	complex, dimension(:,:), allocatable :: A11
	complex, dimension(:,:), allocatable :: A12
	complex, dimension(:,:), allocatable :: A21
	complex, dimension(:,:), allocatable :: A22
	complex, dimension(:), allocatable :: VV1
    complex, dimension(:), allocatable :: VV2

	allocate( Ann(lda,n) )
	allocate( Vnn(ldb) )

	!Build A11 and put it in Ann
	allocate( A11(ss,ss) )
	call build_A(A11,q,0.0d0,T,VLAMBDA12,cutoff_inf)
	A11 = -A11
	do c1 = 1,ss

		A11(c1,c1) = 1.0 + A11(c1,c1)

	enddo
	Ann(1:ss,1:ss) = A11
	deallocate(A11)

	!Build A12 and put it in Ann
    allocate( A12(ss,ss) )
	call build_A(A12,q,0.0d0,T,VLAMBDA_5,cutoff_inf)
    Ann( 1:ss, (ss + 1):2*ss ) = -4.0d0*A12
    deallocate(A12)

	!Build A21 and put it in Ann
    allocate( A21(ss,ss) )
	call build_A(A21,q,0.0d0,T,VLAMBDA_6,cutoff_inf)
    Ann( (ss + 1):2*ss, 1:ss ) = -A21
    deallocate(A21)

	!Build A22 and put it in Ann
    allocate( A22(ss,ss) )
	call build_A(A22,q,0.0d0,T,VLAMBDA1,cutoff_inf)
    A22 = -A22
    do c2 = 1,ss

        A22(c2,c2) = 1.0 + A22(c2,c2)

    enddo
	Ann( (ss + 1):2*ss, (ss + 1):2*ss ) = A22
    deallocate(A22)

	!Build VV1 and put it in Vnn
	allocate( VV1(ss) )
	call build_V(VV1,q,T,V12,cutoff_inf)
	Vnn(1:ss) = VV1
	deallocate(VV1)

	!Build VV2 and put it in Vnn
	allocate( VV2(ss) )
	call build_V(VV2,q,T,V_6,cutoff_inf)
   	Vnn( (ss + 1):2*ss) = VV2
   	deallocate(VV2)

	!Call to lapack to solve Ax=b using LU-factorization. The solution is written into Vnn which is then written into B12,B6.
	call cgesv(n,nrhs,Ann,lda,ipiv,Vnn,ldb,info)
	B12 = Vnn(1:ss)
	B6 = Vnn( (ss + 1):2*ss )

	deallocate(Ann)
	deallocate(Vnn)

end subroutine

subroutine T_3_4_5(B3,B4,B5,q,T)
!T_3,T_4,T_5

implicit none

  	!Lapack parameters.
    integer, parameter :: n = 3*ss
    integer, parameter :: nrhs = 1
    integer, parameter :: lda = n
    integer, parameter :: ldb = n
    integer, parameter :: lwork = n
    integer :: info
    real, dimension(lwork) :: work
    integer, dimension(n) :: ipiv

	!q = |q|
	!T = Isospin
	!B3,B4,B5 = Solution vector T_3,T_4,T_5.
	real(8), intent(in) :: q
	integer, intent(in) :: T
	complex, dimension(ss), intent(out) :: B3,B4,B5

	!c1,c2 = Counters
	!Ann = The A matrix in the equation Ax=b.
	!Vnn = The right hand side (b matrix) in the equation Ax=b.
	!A11...A33 = Matrix entries in Ann.
	!VV1,VV2,VV3 = Vector entries in Vnn.
	integer :: c1,c2
	complex, dimension(:,:), allocatable :: Ann
	complex, dimension(:), allocatable :: Vnn
	complex, dimension(:,:), allocatable :: A11
	complex, dimension(:,:), allocatable :: A12
	complex, dimension(:,:), allocatable :: A13
	complex, dimension(:,:), allocatable :: A21
	complex, dimension(:,:), allocatable :: A22
	complex, dimension(:,:), allocatable :: A23
	complex, dimension(:,:), allocatable :: A31
	complex, dimension(:,:), allocatable :: A32
	complex, dimension(:,:), allocatable :: A33
	complex, dimension(:), allocatable :: VV1
    complex, dimension(:), allocatable :: VV2
	complex, dimension(:), allocatable :: VV3

	allocate( Ann(lda,n) )
	allocate( Vnn(ldb) )

	!Build A11 and put it in Ann
	allocate( A11(ss,ss) )
	call build_A(A11,q,1.0d0,T,VLAMBDA_3,cutoff_inf)
	A11 = -A11
	do c1 = 1,ss

		A11(c1,c1) = 1.0 + A11(c1,c1)

	enddo
	Ann(1:ss,1:ss) = A11
	deallocate(A11)

	!Build A12 and put it in Ann
	allocate( A12(ss,ss) )
	call build_A(A12,q,1.0d0,T,VLAMBDA_4,cutoff_inf)
	A12 = -A12
	Ann(1:ss,(ss+1):2*ss) = A12
	deallocate(A12)

	!Build A13 and put it in Ann
	allocate( A13(ss,ss) )
	call build_A(A13,q,1.0d0,T,VLAMBDA_6,cutoff_inf)
	A13 = -2.0d0*A13
	Ann(1:ss,(2*ss+1):3*ss) = A13
	deallocate(A13)

	!Build A21 and put it in Ann
	allocate( A21(ss,ss) )
	call build_A(A21,q,-1.0d0,T,VLAMBDA_4,cutoff_inf)
	A21 = -A21
	Ann((ss+1):2*ss,1:ss) = A21
	deallocate(A21)

	!Build A22 and put it in Ann
	allocate( A22(ss,ss) )
	call build_A(A22,q,-1.0d0,T,VLAMBDA_3,cutoff_inf)
	A22 = -A22
	do c1 = 1,ss

		A22(c1,c1) = 1.0 + A22(c1,c1)

	enddo
	Ann((ss+1):2*ss,(ss+1):2*ss) = A22
	deallocate(A22)

	!Build A23 and put it in Ann
	allocate( A23(ss,ss) )
	call build_A(A23,q,-1.0d0,T,VLAMBDA_6,cutoff_inf)
	A23 = 2.0d0*A23
	Ann((ss+1):2*ss,(2*ss+1):3*ss) = A23
	deallocate(A23)

	!Build A31 and put it in Ann
	allocate( A31(ss,ss) )
	call build_A(A31,q,1.0d0,T,VLAMBDA_5,cutoff_inf)
	A31 = -A31
	Ann((2*ss+1):3*ss,1:ss) = A31
	deallocate(A31)

	!Build A32 and put it in Ann
	allocate( A32(ss,ss) )
	call build_A(A32,q,-1.0d0,T,VLAMBDA_5,cutoff_inf)
	Ann((2*ss+1):3*ss,(ss+1):2*ss) = A32
	deallocate(A32)

	!Build A33 and put it in Ann
	allocate( A33(ss,ss) )
	call build_A(A33,q,1.0d0,T,VLAMBDA12,cutoff_inf)
	A33 = -A33
	do c1 = 1,ss

		A33(c1,c1) = 1.0 + A33(c1,c1)

	enddo
	Ann((2*ss+1):3*ss,(2*ss+1):3*ss) = A33
	deallocate(A33)

	!Build VV1 and put it in Vnn
	allocate( VV1(ss) )
	call build_V(VV1,q,T,V_3,cutoff_inf)
	Vnn(1:ss) = VV1
	deallocate(VV1)

	!Build VV2 and put it in Vnn
	allocate( VV2(ss) )
	call build_V(VV2,q,T,V_4,cutoff_inf)
	Vnn((ss+1):2*ss) = VV2
	deallocate(VV2)

	!Build VV3 and put it in Vnn
	allocate( VV3(ss) )
	call build_V(VV3,q,T,V_5,cutoff_inf)
	Vnn((2*ss+1):3*ss) = VV3
	deallocate(VV3)

	!Call to lapack to solve Ax=b using LU-factorization. The solution is written into Vnn which is then written into B3,B4,B5.
	call cgesv(n,nrhs,Ann,lda,ipiv,Vnn,ldb,info)
	B3 = Vnn(1:ss)
	B4 = Vnn((ss+1):2*ss)
	B5 = Vnn((2*ss+1):3*ss)

	deallocate(Ann)
	deallocate(Vnn)

end subroutine

end module


c.......................................................................
c
c  routine instrument  stuffs the instrumental profile array; this
c                      routine called once
c  routine phi         computes the relative instrumental response
c                      (assumes a Gaussian)
c
c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c..
c..
c..
      subroutine          instrument(m,wcen,flag)
c..
c..
c..given the instrumental profile sigma in velocity units
c..
c..these profiles are loaded in wrap-around order for the convolution
c..zero spatial information is the first index
c
c  flag = 0 ; call for communicating instrumetal parameters
c  flag = 1 ; call for setting up convolution
c
c.......................................................................
      include             'convspec.h'
      include             'const.dek'
      integer             i,m,iplus,iminus,np2,flag
      parameter           (np2 = 17)
      double precision    dv,xdv,norm,phi,pixpres,wcen
      integer             pwrsof2(np2)
c
c
      data pwrsof2 /16,32,64,128,256,512,1024,2048,4096,8192,
     &              16384,32768,65536,131072,262144,524288,
     &              1048576 /
c
c
c
c
c  compute the instrumental resolution in velocity units [km/s]
c  sigma in km/s given by FWHM/2.35

       profile = ckms/(2.35*R_fac)
c
c
c  dv is the velocity sampling of the pixels km/s/pixel...
c  the number of pixels per resolution element =  profile/dv
c

      dv = dwave/wcen * ckms
      pixpres = 2.35 * profile/dv
      hdv = dv/resfac
      nresponse  = 2*int(conwindo*profile/hdv) + 1
c
c
c  now stuff the response function in wrap around order
c
      response(1) = phi(0.0d0,profile)
      norm        = response(1)
      do 11 i=1,int(nresponse/2)
       xdv              = real(i)*hdv
       iplus            = i + 1
       iminus           = nresponse - (i-1)
       response(iplus)  = phi(xdv,profile)
       response(iminus) = response(iplus)
       norm = norm + response(iplus) + response(iminus)
 11   continue
c
c  for the convolution integral, the response function
c  needs to be normalized or flux is not conserved...
c  unit width is used because data are discretized by
c  pixel indices in the convolution
      do 13 i=1,nresponse
       response(i) = response(i)/norm
 13   continue
c
c
c  compute the length of the convolution functions..
c  NCONDAT and NFFT; do a table search on the powers
c  of 2; this ensures the smallest padding of the
c  CONVDATA array in routine convolve
c
      ncondat = int(resfac)*(m-1) - 1
      nfft   = ncondat + (nresponse-1)/2 + 1
      do 15 i=1,np2
       if (nfft.le.pwrsof2(i)) then
        nfft = pwrsof2(i)
        GOTO 17
       end if
 15   continue

c
c  this is seen only if we exceed the powers of 2 table
      write(STDOUT,*) ' NRESPONSE = ',nresponse
      write(STDOUT,*) ' M         = ',m
      write(STDOUT,*) ' NCONDAT   = ',ncondat
      write(STDOUT,*) ' NFFT      = ',nfft
      write(STDOUT,*) ' NFFT MAX  = ',maxcon
      stop ' ERROR:(instrument): NFFT not defined? too big?'
c
 17   if (nfft.gt.maxcon) then
       stop ' ERROR:(instrument): nfft > maxcon'
      end if
c
c
      if (flag.eq.1) then
        write(STDOUT,'(a,f8.0)')
     @  ' Spectrograph R     [lam/dlam] =',R_fac
        write(STDOUT,'(a,f8.3)')
     @  ' Instrumental Sigma     [km/s] =',profile
       write(STDOUT,'(a,f8.3)')
     @  ' Pixel Resolution       [km/s] =',dv
       write(STDOUT,'(a,f8.3)')
     @ ' Pix / Res Elem         [FWHM] =',pixpres
       write(STDOUT,'(a,f8.3)')
     @ ' Response Widths       [sigma] =',conwindo
       write(STDOUT,'(a,f8.3)')
     @ ' Convolution Res       [1/pix] =',resfac
       write(STDOUT,'(a,i5)')
     @ ' Response Length         [pix] =',nresponse
       write(STDOUT,'(a,i7)')
     @ ' Convolution Pixels      [pix] =',nfft
      end if
c
c
      return
c
      end
c
c:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c
c
c
      double precision function phi(dv,width)
c
c
c    given the sigma in velocity units this routine computes the
c    relative Gaussian value of the instrumental profile.
c    called by routine instrument iteratively
c.......................................................................
c
C      implicit none
      include             'convspec.h'
      double precision     dv,z,width
c
c   dv is value at which the instrumental response is to be evaluated
c
      z   = dv/width
      phi = dexp(-(z**2)/2.0d0)
c
      return
      end
c
c  eof
c.......................................................................


      subroutine gen_G_comp(kpt,iflag)

*************************************************************************
*** Written by Lin-Wang Wang, 2001
*************************************************************************
**  copyright (c) 2003, The Regents of the University of California,
**  through Lawrence Berkeley National Laboratory (subject to receipt of any
**  required approvals from the U.S. Dept. of Energy).  All rights reserved.
*************************************************************************

***   calculates gkk_n, wg_n, length squared and weight factor for
***   g vectors on my node also calculates index matrices
***   wg(g): smooth cutoff truncation used in d3fft_comp.f

      use data
      use load_data
      use fft_data

      implicit double precision (a-h,o-z)

      include 'mpif.h'
      include 'param.escan_real'

c      real*8 ALI(3,3)     ! defined in param.escan_real

      integer fmin
      integer jcol_hf
      integer kpt
      data ifirst/0/
      save ifirst

*****************************************
*     *  \sum_i AL(i,j1)*ALI(i,j2)= \delta_j1,j2
*     *  2*pi*ALI(i,j) is the jth G vector unit in (i)x,y,z components
*****************************************

***********************************
*     select the G points within the Ecut
***********************************
      pi=4*datan(1.d0)
      nh1=(n1+1)/2+1

      ngcount=0
      ngc_in=0

*********************************************
***   ngcount=1 correspond to G=0
***   This special point is used in other subroutines
*********************************************

      iorg = 0
      jcol = 0
      ncol = 0
      ngcol=0
      ngcol0=0
      ngtotnod(:,kpt)=0
      jjcol = 0
      jjnode = 0

      do 10 k3=1,n3
	  k1=k3-1
          if(k1.gt.n3/2) k1=k1-n3
         do 10 j3=1,n2
	    j1=j3-1
	    if(j1.gt.n2/2) j1=j1-n2

	    jcol=jcol+1
            icc = 0
            do 5 i3=1,n1

	    i1=i3-1
	    if(i1.gt.n1/2) i1=i1-n1

       akkx=2*pi*(ALI(1,1)*i1+ALI(1,2)*j1+ALI(1,3)*k1)-akx(kpt)
       akky=2*pi*(ALI(2,1)*i1+ALI(2,2)*j1+ALI(2,3)*k1)-aky(kpt)
       akkz=2*pi*(ALI(3,1)*i1+ALI(3,2)*j1+ALI(3,3)*k1)-akz(kpt)

       akk=0.5d0*(akkx**2+akky**2+akkz**2)

               if(akk.gt.Ecut) goto 5

               ngcol(jcol)=ngcol(jcol)+1
	       ngcount=ngcount+1

 5          continue            ! i3

c     throw away cols with no g vecs
            if(ngcol(jcol).eq.0) then
	       jcol=jcol-1
            else
c     list y and z position of cols
               ngycol(jcol) = j3
               ngzcol(jcol) = k3
           endif

 10      continue               ! j3,k3

c     total number of g vec
         ng(kpt)=ngcount
cccc jcol=1, corresponds to ngycol(1)=1,ngzcol(1)=1,
cccc i.e, the zero points.
cccccccccccccccccccccccccccccccccccccccccccccc
c
c     check  Ecut is contained in box n1*n2*n3
c     by counting g vectors in box twice the size
c
      if(iflag.eq.0) then

         ngcount = 0
         do k3= 1,n3*2
            do j3= 1,n2*2
               do i3= 1,n1*2

                  i1=i3-1
                  if(i1.gt.n1) i1=i1-2*n1
                  j1=j3-1
                  if(j1.gt.n2) j1=j1-2*n2
                  k1=k3-1
                  if(k1.gt.n3) k1=k1-2*n3

       akkx=2*pi*(ALI(1,1)*i1+ALI(1,2)*j1+ALI(1,3)*k1)-akx(kpt)
       akky=2*pi*(ALI(2,1)*i1+ALI(2,2)*j1+ALI(2,3)*k1)-aky(kpt)
       akkz=2*pi*(ALI(3,1)*i1+ALI(3,2)*j1+ALI(3,3)*k1)-akz(kpt)

       akk=0.5d0*(akkx**2+akky**2+akkz**2)

                  if(akk.gt.Ecut) goto 15

                  ngcount = ngcount + 1

 15               continue

               enddo
            enddo
         enddo

         if(ngcount.ne.ng(kpt).and.inode.eq.1) then
            write(*,*) " Ecut not contained in grid n1*n2*n3",
     &    ngcount,ng(kpt)
            stop
         endif
       endif   ! iflag=0
cccccccccccccccccccccccccccccccccccccccccccccc

c
c     sort columns using ngcol in ascending order of length
c     the first coloumn is not sorted (not changed, so use jcol-1)
c
         call heapsort(ngcol(2),
     & 	 jcol-1,ngycol(2),ngzcol(2),ngcol0(2))
c
ccccccccc ngcol0 not defined and not used
c     Distribute cols. between the nodes starting with longest
c     new column given to node with least g vectors
c     and construct info. for column distr. for ffts etc.
c

         ig = 0
         icol = 0

         do jp=jcol,1,-1

            jnode=fmin(ngtotnod(1,kpt),nnodes)
            if(ngcol(jp).eq.0) jnode = mod(jp,nnodes)+1
            ngy=ngycol(jp)
            ngz=ngzcol(jp)
            jjnode(ngy,ngz)=jnode
            ncol(jnode) = ncol(jnode) + 1
            iycol(ncol(jnode),jnode) = ngy
            izcol(ncol(jnode),jnode) = ngz
            jjcol(ngy,ngz) = ncol(jnode)
            ngtotnod(jnode,kpt) = ngtotnod(jnode,kpt) + ngcol(jp)

c
c     set up local info for each node
c
            if(jnode.eq.inode) then

               icol = icol + 1

               do 200 ii = 1,n1

                  i1=ii-1
                  if(i1.gt.n1/2) i1=i1-n1
                  j1=ngy-1
                  if(j1.gt.n2/2) j1=j1-n2
                  k1=ngz-1
                  if(k1.gt.n3/2) k1=k1-n3

       akkx=2*pi*(ALI(1,1)*i1+ALI(1,2)*j1+ALI(1,3)*k1)-akx(kpt)
       akky=2*pi*(ALI(2,1)*i1+ALI(2,2)*j1+ALI(2,3)*k1)-aky(kpt)
       akkz=2*pi*(ALI(3,1)*i1+ALI(3,2)*j1+ALI(3,3)*k1)-akz(kpt)

       akk=0.5d0*(akkx**2+akky**2+akkz**2)

                  if(akk.gt.Ecut) goto 200

                  ig = 1 + ig
                  n2p_n(ig) = ngy
                  n3p_n(ig) = ngz
                  n1p_n(ig) = ii
                  gkk_n(ig,kpt) = akk
                  gkx_n(ig,kpt) = akkx
                  gky_n(ig,kpt) = akky
                  gkz_n(ig,kpt) = akkz

                  if(iflag.eq.0) then      ! wg_n need not be calc. again for iflag>0.
                  if(akk.lt.Ecut*Smth) then
                     wg_n(ig,kpt)=1.d0
                     ngc_in=ngc_in+1
                  else
                     x=(akk-Ecut*Smth)/((1-Smth)*Ecut)*pi
                     wg_n(ig,kpt)=(dcos(x)+1.d0)*0.5d0
                  endif
                  endif

c     store node number and location of origin

200           continue

            endif               ! jnode.eq.inode

        enddo      ! do jp

c     number of g vectors on my processor = ng_n

         ng_n = ig

	 if(ng_n.ne.ngtotnod(inode,kpt)) then
	 write(6,*) "ng_n.ne.ngtotnod, stop", ng_n, ngtotnod(inode,kpt)
	 call mpi_abort(MPI_COMM_WORLD,ierr)
	 endif

c
c     write out load balancing info
c
         if(inode_tot.eq.1.and.iflag.eq.0.and.ifirst.eq.0) then
            write(*,*) " load balancing of the first kpt"
            write(*,*) "kpt, pe.  g's. cols. "
            do i = 1,nnodes
               write(*,*) i,ngtotnod(i,kpt),ncol(i)
            enddo
         endif

         if(ifirst.eq.0) ifirst=1

         return
         end


module ripple3d
use f90_kind

type ripple_params_type
! Parametrisation of the field ripple
! Parametrisation and parameters for analytic rippple correction provided by R. Dux
  real(rkind)               :: A0, A1, A2
  real(rkind)               :: B0, B1, B2
  real(rkind)               :: C0, C1, C2
  real(rkind)               :: D0, D1, D2
  real(rkind)               :: E0, E1, K0, K1
  real(rkind)               :: Btf0, R0, R_min, R_max
  integer(ikind)            :: periods
end type ripple_params_type
! Uncomment this type for use separate from the electron cyclotron forward model
type grad_type
  real(rkind)               :: dR, dphi, dz
end type grad_type
type(ripple_params_type)           :: ripple_params
public :: init_ripple, get_ripple, get_ripple_w_grad
private :: ripple_params

contains
  subroutine init_ripple(R0, Btf0)
    implicit none
    real(rkind), intent(in)           :: R0, Btf0
    ! Btf0 vacuum toroidal magnetic field at R0
    if(abs(Btf0) > 100.d0 .or. abs(Btf0) < 20.d-3 .or. R0 < 0.d0) then
      print*, "Nonsensical Btf0 or R0 in init_ripple in mod_ripple3d.f90"
      print*, "R0 [m], Btf0 [T]", R0, Btf0
      stop "Input error in init_ripple in mod_ripple3d.f90"
    end if
    ripple_params%R_max = 2.25d0 ! If R >  R_max the ripple will be ignored
    ! Routine not tested for HFS -> TODO
    ripple_params%R_min = 1.7d0 ! If R <  R_min_boundary the ripple will be ignored
    ripple_params%periods = 16 ! Symmetry of the machine
    ripple_params%R0 = R0; ripple_params%Btf0 = Btf0
    ripple_params%A0 = -21.959; ripple_params%A1 = 4.653; ripple_params%A2 = 1.747
    ripple_params%B0 = 7.891; ripple_params%B1 = -1.070; ripple_params%B2 = -0.860
    ripple_params%C0 = -23.315; ripple_params%C1 = 5.024; ripple_params%C2 = 0.699
    ripple_params%D0 = 8.196; ripple_params%D1 = -1.362; ripple_params%D2 = -0.367
    ripple_params%E0 = -19.539; ripple_params%E1 = 3.905;
    ripple_params%K0 = 6.199; ripple_params%K1 = -0.767
    ! Uncomment if you wish to test the gradients
!    call validate_ripple_grad()
!    stop "validated ripple"
  end subroutine init_ripple

  subroutine get_ripple(R_vec, B_ripple)
    USE f90_kind
    use constants, only : pi
    implicit none
    real(rkind), dimension(:)  , intent(in)   :: R_vec ! R, psi, z; psi in range of [0, 2 N pi[
    real(rkind), dimension(:)  , intent(out)  :: B_ripple
    real(rkind) :: Btf0, psi
    if(R_vec(1) < ripple_params%R_min .or. R_vec(1) > ripple_params%R_max) then
      B_ripple(:) = 0.d0
      return
    end if
    Btf0 = ripple_params%Btf0 / R_vec(1) * ripple_params%R0
    ! 16 coils at ASDEX Upgrade, hence we have also 16 periods in the ripple function when going once around the torus
    psi = R_vec(2) * 16.d0
    B_ripple(1) = Btf0*exp(ripple_params%C0 + ripple_params%C1*R_vec(3)**2 + ripple_params%C2*R_vec(3)**4 + &
      R_vec(1)*(ripple_params%D0 + ripple_params%D1*R_vec(3)**2 + ripple_params%D2*R_vec(3)**4))*Sin(psi)
    B_ripple(2) = Btf0*exp(ripple_params%A0 + ripple_params%A1*R_vec(3)**2 + ripple_params%A2*R_vec(3)**4 + &
                    R_vec(1)*(ripple_params%B0 + ripple_params%B1*R_vec(3)**2 + ripple_params%B2*R_vec(3)**4))*Cos(psi)
    B_ripple(3) = Btf0*exp(ripple_params%E0 + ripple_params%E1*R_vec(3)**2 + R_vec(1)*(ripple_params%K0 + &
                  ripple_params%K1*R_vec(3)**2))*R_vec(3)*Sin(psi)
  end subroutine get_ripple

  subroutine get_ripple_w_grad(R_vec, B_ripple, grad_B_r_ripple, grad_B_t_ripple, grad_B_z_ripple)
    USE f90_kind
    ! Comment the following line for standalone usage
    ! use fmece_global_params,        only: grad_type
    use constants, only : pi
    implicit none
    real(rkind), dimension(:)  , intent(in)   :: R_vec ! R, psi, z; psi in range of [0, 2 N pi[
    real(rkind), dimension(:)  , intent(out)  :: B_ripple
    type(grad_type), intent(out)              :: grad_B_r_ripple, grad_B_t_ripple, grad_B_z_ripple
    real(rkind)                               :: Btf0, psi
    if(R_vec(1) < ripple_params%R_min .or. R_vec(1) > ripple_params%R_max) then
      B_ripple(:) = 0.d0
      grad_B_r_ripple%dR = 0.d0
      grad_B_r_ripple%dphi = 0.d0
      grad_B_r_ripple%dz = 0.d0
      grad_B_t_ripple%dR = 0.d0
      grad_B_t_ripple%dphi = 0.d0
      grad_B_t_ripple%dz = 0.d0
      grad_B_z_ripple%dR = 0.d0
      grad_B_z_ripple%dphi = 0.d0
      grad_B_z_ripple%dz = 0.d0
      return
    end if
    Btf0 = ripple_params%Btf0 / R_vec(1) * ripple_params%R0
    ! 16 coils at ASDEX Upgrade, hence we have also 16 periods in the ripple function when going once around the torus
    psi = R_vec(2) * 16.d0
    B_ripple(1) = Btf0*exp(ripple_params%C0 + ripple_params%C1*R_vec(3)**2 + ripple_params%C2*R_vec(3)**4 + &
      R_vec(1)*(ripple_params%D0 + ripple_params%D1*R_vec(3)**2 + ripple_params%D2*R_vec(3)**4))*Sin(psi)
    B_ripple(2) = Btf0*exp(ripple_params%A0 + ripple_params%A1*R_vec(3)**2 + ripple_params%A2*R_vec(3)**4 + &
                    R_vec(1)*(ripple_params%B0 + ripple_params%B1*R_vec(3)**2 + ripple_params%B2*R_vec(3)**4))*Cos(psi)
    B_ripple(3) = Btf0*exp(ripple_params%E0 + ripple_params%E1*R_vec(3)**2 + R_vec(1)*(ripple_params%K0 + &
                  ripple_params%K1*R_vec(3)**2))*R_vec(3)*Sin(psi)
    grad_B_r_ripple%dR =   Btf0*exp(ripple_params%C0 + ripple_params%C1*R_vec(3)**2 + ripple_params%C2*R_vec(3)**4 + &
                           R_vec(1)*(ripple_params%D0 + ripple_params%D1*R_vec(3)**2 + ripple_params%D2*R_vec(3)**4)) * &
                           (ripple_params%D0 + ripple_params%D1*R_vec(3)**2 + ripple_params%D2*R_vec(3)**4)*Sin(psi)
    grad_B_r_ripple%dR = grad_B_r_ripple%dR - B_ripple(1) / R_vec(1)
    grad_B_r_ripple%dphi = Btf0*exp(ripple_params%C0 + ripple_params%C1*R_vec(3)**2 + ripple_params%C2*R_vec(3)**4 + &
                           R_vec(1)*(ripple_params%D0 + ripple_params%D1*R_vec(3)**2 + ripple_params%D2*R_vec(3)**4))*Cos(psi)
    grad_B_r_ripple%dphi = grad_B_r_ripple%dphi* 16.d0
    grad_B_r_ripple%dz = Btf0*exp(ripple_params%C0 + ripple_params%C1*R_vec(3)**2 + ripple_params%C2*R_vec(3)**4 + &
                         R_vec(1)*(ripple_params%D0 + ripple_params%D1*R_vec(3)**2 + ripple_params%D2*R_vec(3)**4))* &
                         (2*ripple_params%C1*R_vec(3) + 4*ripple_params%C2*R_vec(3)**3 + R_vec(1)*(2*ripple_params%D1*R_vec(3) + &
                         4*ripple_params%D2*R_vec(3)**3))*Sin(psi)
    grad_B_t_ripple%dR = Btf0*exp(ripple_params%A0 + ripple_params%A1*R_vec(3)**2 + ripple_params%A2*R_vec(3)**4 + &
                         R_vec(1)*(ripple_params%B0 + ripple_params%B1*R_vec(3)**2 + ripple_params%B2*R_vec(3)**4))* &
                         (ripple_params%B0 + ripple_params%B1*R_vec(3)**2 + ripple_params%B2*R_vec(3)**4)*Cos(psi)
    grad_B_t_ripple%dR = grad_B_t_ripple%dR - B_ripple(2) / R_vec(1)
    grad_B_t_ripple%dphi =-(Btf0*exp(ripple_params%A0 + ripple_params%A1*R_vec(3)**2 + ripple_params%A2*R_vec(3)**4 + &
                          R_vec(1)*(ripple_params%B0 + ripple_params%B1*R_vec(3)**2 + ripple_params%B2*R_vec(3)**4))*Sin(psi))
    grad_B_t_ripple%dphi = grad_B_t_ripple%dphi* 16.d0
    grad_B_t_ripple%dz =  Btf0*exp(ripple_params%A0 + ripple_params%A1*R_vec(3)**2 + ripple_params%A2*R_vec(3)**4 + &
                          R_vec(1)*(ripple_params%B0 + ripple_params%B1*R_vec(3)**2 + ripple_params%B2*R_vec(3)**4))* &
                          (2*ripple_params%A1*R_vec(3) + 4*ripple_params%A2*R_vec(3)**3 + R_vec(1)*(2*ripple_params%B1*R_vec(3) + &
                          4*ripple_params%B2*R_vec(3)**3))*Cos(psi)
    grad_B_z_ripple%dR = Btf0*exp(ripple_params%E0 + ripple_params%E1*R_vec(3)**2 + &
                         R_vec(1)*(ripple_params%K0 + ripple_params%K1*R_vec(3)**2))*R_vec(3)* &
                         (ripple_params%K0 + ripple_params%K1*R_vec(3)**2)*Sin(psi)
    grad_B_z_ripple%dR = grad_B_z_ripple%dR - B_ripple(3) / R_vec(1)
    grad_B_z_ripple%dphi = Btf0*exp(ripple_params%E0 + ripple_params%E1*R_vec(3)**2 + R_vec(1)*(ripple_params%K0 + &
                           ripple_params%K1*R_vec(3)**2))*R_vec(3)*Cos(psi)
    grad_B_z_ripple%dphi = grad_B_z_ripple%dphi* 16.d0
    grad_B_z_ripple%dz = Btf0*exp(ripple_params%E0 + ripple_params%E1 * R_vec(3)**2 + R_vec(1)*(ripple_params%K0 + &
                         ripple_params%K1*R_vec(3)**2))*Sin(psi) + &
                         Btf0*exp(ripple_params%E0 + ripple_params%E1 * R_vec(3)**2 + R_vec(1)*(ripple_params%K0 + &
                         ripple_params%K1*R_vec(3)**2))*R_vec(3)*(2*ripple_params%E1*R_vec(3) + &
                         2*ripple_params%K1*R_vec(1)*R_vec(3))* Sin(psi)
  end subroutine get_ripple_w_grad
!
! To validate the gradient of the ripple the following routine calculates the finite differences
! Uncomment if you wish to test the gradients
  subroutine validate_ripple_grad()
  use f90_kind
  !use fmece_global_params,        only: grad_type
  use constants, only: pi
  implicit none
  real(rkind), dimension(3)                 :: R_vec, B_ripple
  real(rkind), dimension(4,3)               :: B_w_ripple_aux
  real(rkind), dimension(4,3)               :: aux_R
  type(grad_type)                           :: grad_B_r_ripple, grad_B_t_ripple, grad_B_z_ripple
  real(rkind)                               :: R0, Btf0, h_x
  integer(ikind)                            :: i, j
  Btf0 = - 2.5d0
  R0 = 1.67d0
  R_vec(1) = 2.130
  R_vec(2) = (16.d0 - 8.5d0) * 22.5 / 180.0 * pi
  R_vec(3) = 0.035d0
  h_x = 1.d-4
  call get_ripple_w_grad(R_vec, B_ripple, grad_B_r_ripple, grad_B_t_ripple, grad_B_z_ripple)
    do i =1,3
      do j = 1 , 4
        aux_R(j,:) = R_vec(:)
        if(j < 3) aux_R(j,i) = R_vec(i) + (3 - j) * h_x !aux_x(1) = x + 2*h, aux_2(2) = x + h
        if(j >= 3) aux_R(j,i) = R_vec(i) + (2 - j) * h_x !aux_x(3) = x - h, aux_2(4) = x - 2*h
        call get_ripple(aux_R(j,:), B_w_ripple_aux(j,:))
      end do
      if(i == 1) then
        print*, "dBr_rip/dR ana", grad_B_r_ripple%dR
      else if(i == 2) then
        print*, "dBr_rip/dphi ana", grad_B_r_ripple%dphi
      else
        print*, "dBr_rip/dz ana", grad_B_r_ripple%dz
      end if
      print*, "dBr_rip/dR num fwd. :", (B_w_ripple_aux(2,1) - B_ripple(1))/h_x
      print*, "dBr_rip/dR num ctr. :" , (-B_w_ripple_aux(1,1) + 8.d0 *  B_w_ripple_aux(2,1) - &
                          8.d0 *  B_w_ripple_aux(3,1) +  B_w_ripple_aux(4,1)) / (12.d0 *h_x)
      if(i == 1) then
        print*, "dBt_rip/dR ana", grad_B_t_ripple%dR
      else if(i == 2) then
        print*, "dBt_rip/dphi ana", grad_B_t_ripple%dphi
      else
        print*, "dBt_rip/dz ana", grad_B_t_ripple%dz
      end if
      print*, "dBt_rip/dR num fwd. :", (B_w_ripple_aux(2,2) - B_ripple(2))/h_x
      print*, "dBt_rip/dR num ctr. :" , (-B_w_ripple_aux(1,2) + 8.d0 *  B_w_ripple_aux(2,2) - &
                          8.d0 *  B_w_ripple_aux(3,2) +  B_w_ripple_aux(4,2)) / (12.d0 *h_x)
      if(i == 1) then
        print*, "dBz_rip/dR ana", grad_B_z_ripple%dR
      else if(i == 2) then
        print*, "dBz_rip/dphi ana", grad_B_z_ripple%dphi
      else
        print*, "dBz_rip/dz ana", grad_B_z_ripple%dz
      end if
      print*, "dBz_rip/dR num fwd. :", (B_w_ripple_aux(2,3) - B_ripple(3))/h_x
      print*, "dBz_rip/dR num ctr. :" , (-B_w_ripple_aux(1,3) + 8.d0 *  B_w_ripple_aux(2,3) - &
                          8.d0 *  B_w_ripple_aux(3,3) +  B_w_ripple_aux(4,3)) / (12.d0 *h_x)
      !h_x = 1.d-4
    end do
!    stop "ok?"
  end subroutine validate_ripple_grad

  end module ripple3d


      subroutine gdavie(acflgc,actwlc,adh,al10,fxi,narn1,narn2,nstmax,
     $ omega,sigmam,xbrwlc,zchsq2)
c
c     This subroutine computes activity coefficients of aqueous species
c     using the Davies (1961) equation. The activity of water is
c     computed from an expression that was derived from the Davies
c     equation using thermodynamic consistency relations.
c
c     This subroutine is called by:
c
c        EQLIBG/gcoeff.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       adh    = Debye-Huckel A(gamma) parameter
c       omega  = water constant; ~55.51.
c       sigmam = sum of solute molalities
c       xbrwlc = log mole fraction of water
c       fxi    = the ionic strength (the 2nd-order electrostatic
c                  moment function I)
c       zchsq2 = one-half the charge squared array
c
c     Principal output:
c
c       acflgc = array of log activity coefficients
c       actwlc = log activity of water
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer nstmax
c
      integer narn1,narn2
c
      real*8 acflgc(nstmax),zchsq2(nstmax)
      real*8 actwlc,adh,al10,fxi,omega,sigmam,xbrwlc
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer ns
c
      real*8 factor,fxisqt,sga,sgx,xxp1
c
c-----------------------------------------------------------------------
c
      fxisqt = sqrt(fxi)
      xxp1 = 1. + fxisqt
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Compute log lambda(w).
c
      sgx = (3./(fxisqt**3))*( xxp1 - (1./xxp1) - 2.*log(xxp1) )
      sga = sigmam/al10
      actwlc = ( -sga + 2.*adh*(fxi**1.5)*sgx/3.
     $ - 0.2*adh*fxi*fxi )/omega
      acflgc(narn1) = actwlc - xbrwlc
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Compute log gamma(i).
c
      factor = (fxisqt/xxp1) - 0.2*fxi
      factor = -2*adh*factor
      do ns = narn1 + 1,narn2
        acflgc(ns) = zchsq2(ns)*factor
      enddo
c
      end


C######################################################################|
      module calculate_hot_tail_population
C----------------------------------------------------------------------|
C     This module is used to calculate the hot-tail population.
C
C     Functions and subroutine:
C       - hot_tail_density
C       - set_Te
C       - set_ne
C       - EVDF_modified_Maxwellian
C       - tau
C       - v_c
C       - v_th
C       - print_hot_tail_info
C
C     Function arguments:
C       - time: time after onset of TQ (s)
C       - t_de: electron temperature decay time scale (s)
C       - ne:   electron density at time `time` (m**-3)
C       - ne_i: electron density at onset of TQ (m**-3)
C       - ne_f: electron density at end of TQ (m**-3)
C       - T:    electron temperature at time `time` (eV)
C       - T_i:  electron temperature at onset of TQ (eV)
C       - T_f:  electron temperature at end of TQ (eV)
C       - Epar: parallel electric field at time `time` (V/m)
C       - v:    electron velocity (m/s)
C
C----------------------------------------------------------------------|
      use double
      use physical_constants, only :
     >  e, epsilon_0, m_e, pi
      use file_io, only :
     >  store_real_arr
      use Coulomb_logarithms, only :
     >  ln_Lambda_0
      use collision_frequencies, only :
     >  nu_ee

      implicit none

      private

      public ::
     >  hot_tail_density,
     >  EVDF_modified_Maxwellian,
     >  tau,
     >  v_c,
     >  v_th

        ! ----- Parameters --------------------------------------------|
      integer, parameter ::
     >  n_eval_start= 200,              ! start # of integrand evaluatns
     >  n_eval_max  = 100000000         ! max # of integrand evaluations

      real(kind=dp) ::
     >  EVDF_min_val= 1.e-100_dp,       ! to calc. up. integration bound
     >  iter_acc    = 1.0e-8_dp         ! target accuracy of iterations

      contains

C======================================================================|
      real(kind=dp) function hot_tail_density(time, t_dec, Epar, T, T_i,
     >  T_f, ne, ne_i, ne_f, verbose, store_result, un) result(n_ht)
C----------------------------------------------------------------------|
C     Evaluates the density of hot-tail runaway electron according to
C     the model by H M Smith and E Verwichte. Phys. Plasmas 15, 072502
C     (2008), equations (9), (17), (18).
C
C     Input:
C       time:       time after onset of TQ (s)
C       t_dec:      time scale of exponential Te decay (s)
C       Epar:       parallel electric field at time `time` (V/m)
C       **T:        electron temperature at time `time` (eV)
C       **T_i:      electron temperature at onset of TQ (eV)
C       **T_f:      electron temperature at end of TQ (eV)
C       **ne:       electron density at time `time` (m**-3)
C       **ne_i:     electron density at onset of TQ (m**-3)
C       **ne_f:     electron density at end of TQ (m**-3)
C       **verbose:  write intermediate data to screen
C       **store_re: store results in text file
C       **un:       unit number of opened file to store results in
C     ** = optional
C     Note, that at least two values of T, T_i, or T_f are required!
C     Note, that at least one value of ne, ne_i or ne_f is required!
C
C     Output:
C       n_ht:      density of hot-tail runaway electrons (m**-3)
C
C----------------------------------------------------------------------|
        ! ----- Function arguments ------------------------------------|
      integer, intent(in), optional ::
     >  un

      logical, intent(in), optional ::
     >  verbose, store_result

      real(kind=dp), intent(in) ::
     >  time, t_dec, Epar
      real(kind=dp), intent(in), optional ::
     >  T, T_i, T_f, ne, ne_i, ne_f

        ! ----- Local variables ---------------------------------------|
      character(len=20) ::
     >  frmt

      integer ::
     >  i, my_un, n_eval

      logical ::
     >  verbos, store_results

      real(kind=dp) ::
     >  dv, int_bound_upp, int_bound_low, n_e, n_ef, n_ei, n_ht_old,
     >  tau_t, T_e, T_ef, T_ei, v, v_th0, weight

C----------------------------------------------------------------------|
C     Initialize hot-tail density
C----------------------------------------------------------------------|
      n_ht = 0._dp

C----------------------------------------------------------------------|
C     Check input
C----------------------------------------------------------------------|
        ! ----- Electron temperature ----------------------------------|
      T_e  = 0._dp;     if (present(T   )) T_e  = T
      T_ei = 0._dp;     if (present(T_i )) T_ei = T_i
      T_ef = 0._dp;     if (present(T_f )) T_ef = T_f

      call set_Te(time, t_dec, T_e, T_ei, T_ef)

        ! ----- Electron density --------------------------------------|
      n_e  = 0._dp;     if (present(ne  )) n_e  = ne
      n_ei = 0._dp;     if (present(ne_i)) n_ei = ne_i
      n_ef = 0._dp;     if (present(ne_f)) n_ef = ne_f

      call set_ne(time, t_dec, n_e, n_ei, n_ef)

        ! ----- Flags -------------------------------------------------|
      verbos = .false.; if (present(verbose)) verbos = verbose
      store_results = .false.
        if (present(store_result)) store_results = store_result
      my_un = 0;       if (present(un)) my_un = un

C----------------------------------------------------------------------|
C     Determine integration bounds, normalized to thermal velocity
C----------------------------------------------------------------------|
      tau_t = tau(time, t_dec, n_ei, n_ef, T_i)
      v_th0 = v_th(T_i)

      int_bound_low = v_c(n_e, T, Epar)/v_th0
      int_bound_upp =
     >  (sqrt((-log(EVDF_min_val))**3) - 3*tau_t)**(1._dp/3._dp)

      if (int_bound_upp .le. int_bound_low) return

C----------------------------------------------------------------------|
C     Print calculation parameters
C----------------------------------------------------------------------|
      call print_hot_tail_info(verbose=verbos,
     >  args= ( /time, t_dec, Epar, T_i, T, n_ei, n_e, n_ef, v_th0,
     >      v_c(n_e, T, Epar), tau_t, int_bound_low, int_bound_upp /))

C----------------------------------------------------------------------|
C     Perform numerical integration using Kepler's rule
C----------------------------------------------------------------------|
        ! Set densities such that loop is executed
      n_ht     = 1._dp
      n_ht_old = 2._dp

        ! Initial number of integrand evaluations
        ! Has to be even to have uneven number of points
      n_eval = n_eval_start

        ! ----- Iteratively integrate ---------------------------------|
      do while (abs((n_ht - n_ht_old)/n_ht_old) .gt. iter_acc
     >      .and. n_eval .le. n_eval_max)

            ! Store previous result
        n_ht_old = n_ht

            ! Integration step size
        dv = 1._dp/n_eval*(int_bound_upp - int_bound_low)

            ! Integrand is zero for v = int_bound_low
        n_ht = 0._dp
        do i=1,n_eval
                ! Weights for integrand
            if (i.lt.n_eval) then
                weight = 2._dp**(1+mod(i,2))
            else
                weight = 1._dp
            endif

            v = i*dv + int_bound_low
            n_ht = n_ht + weight*(v**2 - int_bound_low**2)
     >          * exp(-(v**3 + 3*tau_t)**(2._dp/3._dp))
        enddo
            ! Apply pre-factors
        n_ht = 4*n_ei/sqrt(pi)*dv/3*n_ht

            ! Write iteration step to screen
        call print_hot_tail_info(verbose=verbos,
     >      args = (/ 1+log(1._dp*n_eval/n_eval_start)/log(2._dp),
     >          n_ht, abs(n_ht/n_ht_old-1.), real(n_eval, kind=dp) /))

            ! Increase number of integrand evaluations
        n_eval = 2*n_eval
      enddo

C----------------------------------------------------------------------|
C     Store results if requested
C----------------------------------------------------------------------|
      if (store_results .and. my_un.gt.0) then
        call store_real_arr(my_un, (/ time, n_ht, ne, T, Epar,
     >      v_c(ne, T, Epar)/v_th0, tau_t /))
      endif

      return
      end function hot_tail_density
C======================================================================|

C======================================================================|
      subroutine set_Te(t, t_dec, y, y_i, y_f)
C----------------------------------------------------------------------|
C     Ensures the electron temperature has the correct format to
C     calculate the hot-tail density.
C----------------------------------------------------------------------|
        ! ----- Subroutine arguments ----------------------------------|
      real(kind=dp), intent(in) ::
     >  t, t_dec

      real(kind=dp), intent(inout) ::
     >  y, y_i, y_f

C----------------------------------------------------------------------|
C     Check different cases
C----------------------------------------------------------------------|
        ! Everything provided: return
      if (y.gt.0._dp .and. y_i.gt.0._dp) then
        return

        ! Initial and final value provided: calculate value at `t`
      else if (y.le.0._dp .and. y_i.gt.0._dp .and. y_f.gt.0._dp) then
        y = (y_i - y_f)*exp(-t/t_dec) + y_f

        ! Value at `t` and final value provided: calculate initial value
      else if (y.gt.0._dp .and. y_i.le.0._dp .and. y_f.gt.0._dp) then
        y_i = (y - y_f*(1._dp - exp(-t/t_dec)))*exp(t/t_dec)

        ! Otherwise, cannot set required quantities `y` and `y_i` and
        ! calculation cannot be performed
      else
        write(*,'(a)') 'ERROR: Insufficient electron temperature ' //
     >      'data provided to perform calculation of hot-tail ' //
     >      'density. STOP calculation.'
        stop

      endif

      return
      end subroutine set_Te
C======================================================================|

C======================================================================|
      subroutine set_ne(t, t_dec, y, y_i, y_f)
C----------------------------------------------------------------------|
C     Ensures the electron density has the correct format to calculate
C     the hot-tail density.
C----------------------------------------------------------------------|
        ! ----- Parameters --------------------------------------------|
      real(kind=dp), parameter ::
     >  y_def = 1.e19_dp

        ! ----- Subroutine arguments ----------------------------------|
      real(kind=dp), intent(in) ::
     >  t, t_dec

      real(kind=dp), intent(inout) ::
     >  y, y_i, y_f

C----------------------------------------------------------------------|
C     Check different cases
C----------------------------------------------------------------------|
        ! Everything provided: return
      if (y.gt.0._dp .and. y_i.gt.0._dp .and. y_f.gt.0._dp) then
        return

        ! Initial and final value provided: calculate value at `t`
      else if (y.le.0._dp .and. y_i.gt.0._dp .and. y_f.gt.0._dp) then
        y = (y_i - y_f)*exp(-t/t_dec) + y_f

        ! Initial and value at `t` provided: calculate final value
      else if (y.gt.0._dp .and. y_i.gt.0._dp .and. y_f.le.0._dp) then
        y_f = (y - y_i*exp(-t/t_dec))/(1._dp - exp(-t/t_dec))

        ! Value at `t` and final value provided: calculate initial value
      else if (y.gt.0._dp .and. y_i.le.0._dp .and. y_f.gt.0._dp) then
        y_i = (y - y_f*(1._dp - exp(-t/t_dec)))*exp(t/t_dec)

        ! Only one value provided: Set for all values
      else if (y.gt.0._dp .or. y_i.gt.0._dp .or. y_f.gt.0._dp) then
        y   = max(y, y_i, y_f)
        y_i = y
        y_f = y

        ! Nothing provided: WARNING
      else if (y.le.0._dp .and. y_i.le.0._dp .and. y_f.le.0._dp) then
        write(*,'(a,es12.4,a)') 'WARNING: No values for electron ' //
     >      'density provided for calculation of hot-tail density! ' //
     >      'Will use default density of ne=', y_def,' m**-3.'
        y   = y_def
        y_i = y_def
        y_f = y_def

      endif

      return
      end subroutine set_ne
C======================================================================|

C======================================================================|
      real(kind=dp) function EVDF_modified_Maxwellian(v, ne, v_th, tau)
     >  result(distr_func)
C----------------------------------------------------------------------|
C     Calculates the value of the Maxwellian electron velocity
C     distribution function at velocity `v` for electron density `ne`,
C     thermal velocity `v_th` and parameter `tau`, where the argument
C     of the exponential has been modified. Reduces to a standard
C     Maxwellian for tau=0. For details, see H.M. Smith and E.
C     Verwichte. Phys. Plasmas 15, 072502 (2008), especially eq. (9).
C
C     Input
C       v:          electron velocity where distribution function is
C                   to be evaluated (m/s)
C       ne:         electron density (m**-3)
C       v_th:       thermal electron velocity (m/s)
C       tau:        parameter of temporal delay
C
C     Output:
C       distr_func: magnitude of the electron distribution function
C
C----------------------------------------------------------------------|
          ! ----- Function arguments ----------------------------------|
      real(kind=dp), intent(in) ::
     >  v, ne, v_th, tau

C----------------------------------------------------------------------|
      distr_func = ne*exp(-((v/v_th)**3 + 3*tau)**(2._dp/3._dp))
     >  /(sqrt(pi)*v_th)**3

      return
      end function EVDF_modified_Maxwellian
C======================================================================|

C======================================================================|
      real(kind=dp) function tau(time, t_char, ne_i, ne_f, T_i)
C----------------------------------------------------------------------|
C     Calculates the parameter tau of temporal delay. For details, see
C     H.M. Smith and E. Verwichte. Phys. Plasmas 15, 072502 (2008).
C
C     Input:
C       time:       time since onset of TQ (s)
C       ne:         electron density at time `time` (m**-3)
C       t_char:     characteristic time scale of TQ (s)
C       ne_i:       electron density at onset of TQ (m**-3)
C       ne_f:       electron density at end of TQ (m**-3)
C       T_i:        electron temperature at onset of TQ (eV)
C
C     Output:
C       tau:        parameter of temporal delay
C
C----------------------------------------------------------------------|
          ! ----- Function arguments ----------------------------------|
      real(kind=dp), intent(in) ::
     >  time, t_char, ne_i, ne_f, T_i

C----------------------------------------------------------------------|
      if (time .lt. 2*t_char) then
        tau = time**2/4/t_char
      else if (time .ge. 2*t_char) then
        tau = time - t_char
      endif

      tau = tau*nu_ee(ne_i, T_i)*ne_f/ne_i

      return
      end function tau
C======================================================================|

C======================================================================|
      real(kind=dp) function v_c(ne, T, Epar)
C----------------------------------------------------------------------|
C     Calculates the critical velocity for electron runaway. See e.g.
C     H.M. Smith and Epar. Verwichte. Phys. Plasmas 15, 072502 (2008).
C
C     Input:
C       ne:         electron density (m**-3)
C       T:          electron temperature (eV)
C       Epar:       parallel electric field (V/m)
C
C     Output:
C       v_th:       thermal electron velocity (m/s)
C
C----------------------------------------------------------------------|
          ! ----- Function arguments ----------------------------------|
      real(kind=dp), intent(in) ::
     >  ne, T, Epar

C----------------------------------------------------------------------|
      v_c = sqrt(e**3/(4*pi*epsilon_0**2*m_e)
     >  *ne*ln_Lambda_0(ne, T)/Epar)

      return
      end function v_c
C======================================================================|

C======================================================================|
      real(kind=dp) function v_th(T)
C----------------------------------------------------------------------|
C     Calculates the thermal electron velocity v_th = sqrt(2*T/m_e).
C
C     Input:
C       T:          electron temperature (eV)
C
C     Output:
C       v_th:       thermal electron velocity (m/s)
C
C----------------------------------------------------------------------|
          ! ----- Function arguments ----------------------------------|
      real(kind=dp), intent(in) ::
     >  T
C----------------------------------------------------------------------|
      v_th = sqrt(2*T*e/m_e)

      return
      end function v_th
C======================================================================|

C======================================================================|
      subroutine print_hot_tail_info(args, verbose)
C----------------------------------------------------------------------|
C     Prints information on hot-tail calculations to the screen. If the
C     array `args` contains 13 elements, the calculation paramters are
C     printed. If `args` contains 4 elements, the density at the current
C     iteration step is printed.
C----------------------------------------------------------------------|
        ! ----- Parameters --------------------------------------------|
      character(len=10), parameter ::
     >  frmt = '(a,3e12.4)'

        ! ----- Subroutine arguments ----------------------------------|
      logical, intent(in), optional ::
     >  verbose

      real(kind=dp), dimension(:), intent(in) ::
     >  args

        ! ----- Local variables ---------------------------------------|
      logical ::
     >  verbos

C----------------------------------------------------------------------|
C     Determine print flag `verbose`
C----------------------------------------------------------------------|
      verbos=.true.; if(present(verbose)) verbos=verbose
      if (.not. verbos) return

C----------------------------------------------------------------------|
C     Print overview of calculation parameters
C----------------------------------------------------------------------|
      if ((size(args) .eq. 13) .and. verbos) then
        write(*,*) ''
        write(*,'(2a)') 'Perform numerical integration for the ',
     >  'following set of parameters:'
        write(*,frmt) 'Time (s):                  ', args(1)
        write(*,frmt) 'Decay time (s):            ', args(2)
        write(*,frmt) 'Epar (V/m):                ', args(3)
        write(*,frmt) 'Te (ini, `t`) (eV):        ', args(4), args(5)
        write(*,frmt) 'ne (ini, `t`, fin) (m**-3):', args(6), args(7),
     >      args(8)
        write(*,frmt) 'Velocities (vth, vc) (m/s):', args(9), args(10)
        write(*,frmt) 'Temporal parameter tau:    ', args(11)
        write(*,frmt) 'Integration bounds (v_th): ', args(12), args(13)
        write(*,frmt) ''
        write(*,'(a)') ' Step, Density (m**-3), Rel. Difference, # eval'
        write(*,'(a)') ' -----------------------------'

C----------------------------------------------------------------------|
C     Print current iteration step
C----------------------------------------------------------------------|
      else if ((size(args) .eq. 4) .and. verbos) then
        write(*,'(a,i0.3,2e17.8,i9)') ' #', int(args(1)), args(2),
     >      args(3), int(args(4))

      endif

      return
      end subroutine print_hot_tail_info
C======================================================================|

      end module calculate_hot_tail_population
C######################################################################|


!> \file sort_test.f90
!! \brief
!! @author Innocent Souopgui
!!
!<
PROGRAM SORT
USE cs_tools
USE debug_tools
USE general_tools

  INTEGER, PARAMETER :: ip_n = 100,&
                        ip_m = 10
  INTEGER, DIMENSION(ip_m) :: ida_vec

  CALL init_all()
  CALL random_indexes(ida_vec, ip_n)
  CALL debug(ida_vec, 'Before sorting: ')
  CALL select_sort(ida_vec)
  CALL debug(ida_vec, 'After  sorting: ')

  CALL finalize_all()
CONTAINS

  SUBROUTINE init_all()
    !CALL init_fftw()
    CALL init_cs_tools()
  END SUBROUTINE init_all

  SUBROUTINE finalize_all()
    !CALL finalize_fftw()
    CALL finalize_cs_tools()
  END SUBROUTINE finalize_all
END PROGRAM SORT


MODULE NEWTON_MOD
IMPLICIT NONE
PUBLIC :: F, FP
CONTAINS
!==============================================================================
FUNCTION F(X,URef,RefHt,HubHt) RESULT (Y)
USE NWTC_Library
REAL(ReKi), INTENT(IN) :: X
!REAL(ReKi), INTENT(IN) :: V_10
REAL(ReKi), INTENT(IN) :: URef
REAL(ReKi), INTENT(IN) :: RefHt
REAL(ReKi), INTENT(IN) :: HubHt
REAL(ReKi)             :: Y
REAL(ReKi)             :: C_1
REAL(ReKi)             :: C_2
REAL(ReKi)             :: D_1
REAL(ReKi)             :: D_2
REAL(ReKi)             :: D_3
REAL(ReKi)             :: D_4

IF ( EqualRealNos( RefHt, 10.0_ReKi ) ) THEN
   C_1=1.0-0.41*0.06*LOG(600.0/3600.0)
   C_2=0.41*0.06*0.043*LOG(600.0/3600.0)
   Y=C_1*X-C_2*X*X-URef
ELSEIF ( EqualRealNos( RefHt, HubHt) )  THEN
   D_1=1.0-0.41*0.06*LOG(600.0/3600.0)*(RefHt/10.0)**(-0.22)
   D_2=0.41*0.06*0.043*LOG(600.0/3600.0)*(RefHt/10.0)**(-0.22)
   D_3=D_1*0.0573*LOG(RefHt/10.0)
   D_4=D_2*0.0573*LOG(RefHt/10.0)
   Y=D_1*X-D_2*X*X+D_3*X*(1.0+0.15*X)**0.5-D_4*X*X*(1.0+0.15*X)**0.5-URef
ELSE
   Y = -9999999
ENDIF

END FUNCTION F
!==============================================================================
FUNCTION FP(X,URef,RefHt,HubHt) RESULT (Y)
USE NWTC_Library
REAL(ReKi), INTENT(IN) :: X
REAL(ReKi), INTENT(IN) :: URef
REAL(ReKi), INTENT(IN) :: RefHt
REAL(ReKi), INTENT(IN) :: HubHt
REAL(ReKi)             :: Y
REAL(ReKi)             :: C_1
REAL(ReKi)             :: C_2
REAL(ReKi)             :: D_1
REAL(ReKi)             :: D_2
REAL(ReKi)             :: D_3
REAL(ReKi)             :: D_4

IF ( EqualRealNos( RefHt, 10.0_ReKi ) ) THEN
   C_1 = 1.0-0.41*0.06*LOG(600.0/3600.0)
   C_2 = 0.41*0.06*0.043*LOG(600.0/3600.0)
   Y   = C_1-2.0*C_2*X
ELSEIF ( EqualRealNos( RefHt, HubHt) )  THEN
   C_1 = 1.0 - 0.41  * 0.06 * LOG(600.0/3600.0)
   C_2 = 0.41 * 0.06*0.043  * LOG(600.0/3600.0)
   D_1 = 1.0-0.41*0.06*LOG(600.0/3600.0)*(RefHt/10.0)**(-0.22)
   D_2 = 0.41*0.06*0.043*LOG(600.0/3600.0)*(RefHt/10.0)**(-0.22)
   D_3 = D_1*0.0573*LOG(RefHt/10.0)
   D_4 = D_2*0.0573*LOG(RefHt/10.0)
   Y   = D_1-2.0*D_2*X+D_3*((1.0+0.15*X)**0.5+0.15*X/2.0/(1.0+0.15*X)**0.5)  &
         -D_4*(2.0*X*(1.0+0.15*X)**0.5+0.15*X*X/2.0/(1.0+0.15*X)**0.5)
ELSE
   Y = -9999999
ENDIF

END FUNCTION FP
!==============================================================================
END MODULE NEWTON_MOD

SUBROUTINE ROOT_SEARCHING(X0,X,URef,RefHt,HubHt)
USE NEWTON_MOD
USE NWTC_Library
IMPLICIT NONE

REAL(ReKi), PARAMETER     :: TOL=1.0E-5

REAL(ReKi), INTENT(IN   ) :: URef
REAL(ReKi), INTENT(IN   ) :: RefHt
REAL(ReKi), INTENT(IN   ) :: HubHt
REAL(ReKi), INTENT(IN   ) :: X0
REAL(ReKi), INTENT(  OUT) :: X

X=X0
DO  ! bjj: I'd like this better if there were absolutely no way to have an infinite loop here...
   X = X - F(X,URef,RefHt,HubHt) / FP(X,URef,RefHt,HubHt)
   IF (ABS(F(X,URef,RefHt,HubHt)) < TOL) THEN
      EXIT
   END IF

END DO
END SUBROUTINE ROOT_SEARCHING


      function rednor(n,binf,bsup,x,epsx,g)
c     Copyright INRIA
      implicit double precision (a-h,o-z)
      dimension binf(n),bsup(n),x(n),epsx(n),g(n)
      rednor=0.0d+0
      do 1 i=1,n
      aa=g(i)
      if(x(i)-binf(i).le.epsx(i))aa=min(0.0d+0,aa)
      if(bsup(i)-x(i).le.epsx(i))aa=max(0.0d+0,aa)
1     rednor=rednor + aa**2
      rednor=sqrt(rednor)
      end


!=====================================================
SUBROUTINE poi2d(hx,hy,mx,my,                         &
     xmin,xmax,ymin,ymax,                             &
     x,y,ix,iy,dx,dy,ierr)
! Creates Pointers for eva2d
!
! Input:  hx, hy              increment in x and y
!         mx, my              standard (0) or periodic (1) spline
!         xmin, xmax          Minimum and maximum x
!         ymin, ymax          Minimum and maximum y
!         x, y                x and y values for spline avaluation
! Output: spval               evaluated function value
!         ix, iy              pointer into the spline array spl
!         dx, dy              distance from x(ix) and y(iy)
!         ierr                error (> 0)

  USE neo_precision

  IMPLICIT NONE

  REAL(kind=dp),                       INTENT(in)  :: hx, hy
  INTEGER,                             INTENT(in)  :: mx, my
  REAL(kind=dp),                       INTENT(in)  :: xmin, xmax, ymin, ymax
  REAL(kind=dp),                       INTENT(in)  :: x, y

  INTEGER,                             INTENT(out) :: ix, iy
  REAL(kind=dp),                       INTENT(out) :: dx, dy
  INTEGER,                             INTENT(out) :: ierr

  REAL(kind=dp)                                    :: dxx, x1, dyy, y1
  REAL(kind=dp)                                    :: dxmax, dymax

  ierr = 0

  dxx = x-xmin
  IF (mx .EQ. 0) THEN
     IF (dxx .LT. ZERO) THEN
        ierr = 1
        RETURN
     END IF
     IF (x .GT. xmax) THEN
        ierr = 2
        RETURN
     END IF
  ELSE
     dxmax = xmax - xmin
     IF(dxx .LT. ZERO) THEN
        dxx = dxx+(1+INT(abs(dxx/dxmax)))*dxmax
     ELSE IF(dxx .GT. dxmax) THEN
        dxx = dxx-(INT(abs(dxx/dxmax)))*dxmax
     END IF
  END IF
  x1 = dxx/hx
  ix = INT(x1)
  dx = hx*(x1-ix)
  ix = ix+1

  dyy = y-ymin
  IF (my .EQ. 0) THEN
     IF (dyy .LT. ZERO) THEN
        ierr = 3
        RETURN
     END IF
     IF (y .GT. ymax) THEN
        ierr = 4
        RETURN
     END IF
  ELSE
     dymax = ymax - ymin
     IF(dyy .LT. ZERO) THEN
        dyy = dyy+(1+INT(abs(dyy/dymax)))*dymax
     ELSE IF(dyy .GT. dymax) THEN
        dyy = dyy-(INT(abs(dyy/dymax)))*dymax
     END IF
  END IF
  y1 = dyy/hy
  iy = INT(y1)
  dy = hy*(y1-iy)
  iy = iy+1

  RETURN
END SUBROUTINE poi2d