      subroutine runP_0000i(i1,Gr,S0000i,N0)
      implicit none
      include 'TRconstants.f'
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,i1,m,n,np
      parameter(np=3)
      double precision Gr(np,np)
      double complex S0000i(np,-2:0),bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gr(n,m)*Dv(dzziii(z3(n,m,i1))+N0,ep)
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=4d0*Dv(dzzzzi(i1)+N0,ep-1)

c--- note: we have simplified the recursion relation by using DD (5.9)
c--- so that S0000i = 2C00i(0)+2*m0sq*D00i
      Dv(dzzzzi(i1)+N0,ep)=
     . (pole
     . +S0000i(i1,ep)
     . -bit)/16d0
      enddo

      return
      end


!
! Copyright (C) 2001-2009 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
subroutine slater (rs, ex, vx)
  !-----------------------------------------------------------------------
  !        Slater exchange with alpha=2/3
  !
  USE kinds, ONLY : DP
  implicit none
  real(DP) :: rs, ex, vx
  real(DP), parameter  :: f= -0.687247939924714d0, alpha = 2.0d0/3.0d0
  ! f = -9/8*(3/2pi)^(2/3)
  !
  ex = f * alpha / rs
  vx = 4.d0 / 3.d0 * f * alpha / rs
  !
  return
end subroutine slater
subroutine pz (rs, iflag, ec, vc)
  !-----------------------------------------------------------------------
  !     LDA parameterization from Monte Carlo data
  !     iflag=1: J.P. Perdew and A. Zunger, PRB 23, 5048 (1981)
  !     iflag=2: G. Ortiz and P. Ballone, PRB 50, 1391 (1994)
  !
  USE kinds, ONLY : DP
  implicit none
  real(DP) :: rs, ec, vc
  integer :: iflag
  !
  real(DP) :: a (2), b (2), c (2), d (2), gc (2), b1 (2), b2 (2)
  real(DP) :: lnrs, rs12, ox, dox
  !
  data a / 0.0311d0, 0.031091d0 /, b / -0.048d0, -0.046644d0 /, &
       c / 0.0020d0, 0.00419d0 /, d / -0.0116d0, -0.00983d0 /
  data gc / -0.1423d0, -0.103756d0 /, b1 / 1.0529d0, 0.56371d0 /, &
       b2 / 0.3334d0, 0.27358d0 /
  !
  if (rs.lt.1.0d0) then
     ! high density formula
     lnrs = log (rs)
     ec = a (iflag) * lnrs + b (iflag) + c (iflag) * rs * lnrs + d ( &
          iflag) * rs
     vc = a (iflag) * lnrs + (b (iflag) - a (iflag) / 3.d0) + 2.d0 / &
          3.d0 * c (iflag) * rs * lnrs + (2.d0 * d (iflag) - c (iflag) ) &
          / 3.d0 * rs
  else
     ! interpolation formula
     rs12 = sqrt (rs)
     ox = 1.d0 + b1 (iflag) * rs12 + b2 (iflag) * rs
     dox = 1.d0 + 7.d0 / 6.d0 * b1 (iflag) * rs12 + 4.d0 / 3.d0 * &
          b2 (iflag) * rs
     ec = gc (iflag) / ox
     vc = ec * dox / ox
  endif
  !
  return
end subroutine pz
!
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
subroutine pw (rs, iflag, ec, vc)
  !-----------------------------------------------------------------------
  !     iflag=1: J.P. Perdew and Y. Wang, PRB 45, 13244 (1992)
  !     iflag=2: G. Ortiz and P. Ballone, PRB 50, 1391 (1994)
  !
  USE kinds, ONLY : DP
  implicit none
  real(DP) :: rs, ec, vc
  integer :: iflag
  !
  real(DP) :: a, b1, b2, c0, c1, c2, c3, d0, d1
  parameter (a = 0.031091d0, b1 = 7.5957d0, b2 = 3.5876d0, c0 = a, &
       c1 = 0.046644d0, c2 = 0.00664d0, c3 = 0.01043d0, d0 = 0.4335d0, &
       d1 = 1.4408d0)
  real(DP) :: lnrs, rs12, rs32, rs2, om, dom, olog
  real(DP) :: a1 (2), b3 (2), b4 (2)
  data a1 / 0.21370d0, 0.026481d0 /, b3 / 1.6382d0, -0.46647d0 /, &
       b4 / 0.49294d0, 0.13354d0 /
  !
  ! high- and low-density formulae implemented but not used in PW case
  ! (reason: inconsistencies in PBE/PW91 functionals)
  !
  if (rs.lt.1d0.and.iflag.eq.2) then
     ! high density formula
     lnrs = log (rs)
     ec = c0 * lnrs - c1 + c2 * rs * lnrs - c3 * rs
     vc = c0 * lnrs - (c1 + c0 / 3.d0) + 2.d0 / 3.d0 * c2 * rs * &
          lnrs - (2.d0 * c3 + c2) / 3.d0 * rs
  elseif (rs.gt.100.d0.and.iflag.eq.2) then
     ! low density formula
     ec = - d0 / rs + d1 / rs**1.5d0
     vc = - 4.d0 / 3.d0 * d0 / rs + 1.5d0 * d1 / rs**1.5d0
  else
     ! interpolation formula
     rs12 = sqrt (rs)
     rs32 = rs * rs12
     rs2 = rs**2
     om = 2.d0 * a * (b1 * rs12 + b2 * rs + b3 (iflag) * rs32 + b4 ( &
          iflag) * rs2)
     dom = 2.d0 * a * (0.5d0 * b1 * rs12 + b2 * rs + 1.5d0 * b3 ( &
          iflag) * rs32 + 2.d0 * b4 (iflag) * rs2)
     olog = log (1.d0 + 1.0d0 / om)
     ec = - 2.d0 * a * (1.d0 + a1 (iflag) * rs) * olog
     vc = - 2.d0 * a * (1.d0 + 2.d0 / 3.d0 * a1 (iflag) * rs) &
          * olog - 2.d0 / 3.d0 * a * (1.d0 + a1 (iflag) * rs) * dom / &
          (om * (om + 1.d0) )
  endif
  !
  return
end subroutine pw
!
!---------------------------------------------------------------
subroutine pbex (rho, grho, iflag, sx, v1x, v2x)
  !---------------------------------------------------------------
  !
  ! PBE exchange (without Slater exchange):
  ! iflag=1  J.P.Perdew, K.Burke, M.Ernzerhof, PRL 77, 3865 (1996)
  ! iflag=2  "revised' PBE: Y. Zhang et al., PRL 80, 890 (1998)
  ! iflag=3  PBEsol: J.P.Perdew et al., PRL 100, 136406 (2008)
  !
  USE kinds, ONLY : DP
  USE constants, ONLY : pi
  implicit none
  real(DP) :: rho, grho, sx, v1x, v2x
  ! input: charge and squared gradient
  ! output: energy
  ! output: potential
  integer :: iflag
  ! local variables
  real(DP) :: kf, agrho, s1, s2, ds, dsg, exunif, fx
  ! (3*pi2*|rho|)^(1/3)
  ! |grho|
  ! |grho|/(2*kf*|rho|)
  ! s^2
  ! n*ds/dn
  ! n*ds/d(gn)
  ! exchange energy LDA part
  ! exchange energy gradient part
  real(DP) :: dxunif, dfx, f1, f2, f3, dfx1
  ! numerical coefficients (NB: c2=(3 pi^2)^(1/3) )
  real(DP) :: third, c1, c2, c5
  parameter (third = 1.d0 / 3.d0, c1 = 0.75d0 / pi , &
       c2 = 3.093667726280136d0, c5 = 4.d0 * third)
  ! parameters of the functional
  real(DP) :: k (3), mu(3)
  data k / 0.804d0, 1.2450D0, 0.804d0 /, &
       mu/ 0.21951d0, 0.21951d0, 0.12345679012345679012d0  /
  !
  agrho = sqrt (grho)
  kf = c2 * rho**third
  dsg = 0.5d0 / kf
  s1 = agrho * dsg / rho
  s2 = s1 * s1
  ds = - c5 * s1
  !
  !   Energy
  !
  f1 = s2 * mu(iflag) / k (iflag)
  f2 = 1.d0 + f1
  f3 = k (iflag) / f2
  fx = k (iflag) - f3
  exunif = - c1 * kf
  sx = exunif * fx
  !
  !   Potential
  !
  dxunif = exunif * third
  dfx1 = f2 * f2
  dfx = 2.d0 * mu(iflag) * s1 / dfx1
  v1x = sx + dxunif * fx + exunif * dfx * ds
  v2x = exunif * dfx * dsg / agrho

  sx = sx * rho
  return
end subroutine pbex
!
!---------------------------------------------------------------
subroutine pbec (rho, grho, iflag, sc, v1c, v2c)
  !---------------------------------------------------------------
  !
  ! PBE correlation (without LDA part)
  ! iflag=1: J.P.Perdew, K.Burke, M.Ernzerhof, PRL 77, 3865 (1996).
  ! iflag=2: J.P.Perdew et al., PRL 100, 136406 (2008).
  !
  USE kinds, ONLY : DP
  implicit none
  integer, intent(in) :: iflag
  real(DP) :: rho, grho, sc, v1c, v2c
  real(DP) :: ga, be (2)
  parameter (ga = 0.031091d0)
  data be / 0.066725d0, 0.046d0 /
  real(DP) :: third, pi34, xkf, xks
  parameter (third = 1.d0 / 3.d0, pi34 = 0.6203504908994d0)
  parameter (xkf = 1.919158292677513d0, xks = 1.128379167095513d0)
  ! pi34=(3/4pi)^(1/3), xkf=(9 pi/4)^(1/3), xks= sqrt(4/pi)
  real(DP) :: kf, ks, rs, ec, vc, t, expe, af, bf, y, xy, qy
  real(DP) :: s1, h0, dh0, ddh0
  !
  rs = pi34 / rho**third
  call pw (rs, 1, ec, vc)
  kf = xkf / rs
  ks = xks * sqrt (kf)
  t = sqrt (grho) / (2.d0 * ks * rho)
  expe = exp ( - ec / ga)
  af = be(iflag) / ga * (1.d0 / (expe-1.d0) )
  bf = expe * (vc - ec)
  y = af * t * t
  xy = (1.d0 + y) / (1.d0 + y + y * y)
  qy = y * y * (2.d0 + y) / (1.d0 + y + y * y) **2
  s1 = 1.d0 + be(iflag) / ga * t * t * xy
  h0 = ga * log (s1)
  dh0 = be(iflag) * t * t / s1 * ( - 7.d0 / 3.d0 * xy - qy * (af * bf / &
       be(iflag)-7.d0 / 3.d0) )
  ddh0 = be(iflag) / (2.d0 * ks * ks * rho) * (xy - qy) / s1
  sc = rho * h0
  v1c = h0 + dh0
  v2c = ddh0
  !
  return
end subroutine pbec
!
!-----------------------------------------------------------------------
function dpz (rs, iflg)
  !-----------------------------------------------------------------------
  !  derivative of the correlation potential with respect to local density
  !  Perdew and Zunger parameterization of the Ceperley-Alder functional
  !
  use kinds, only: DP
  USE constants, ONLY: pi, fpi
  !
  implicit none
  !
  real(DP), intent (in) :: rs
  integer, intent(in) :: iflg
  real(DP) :: dpz
  !
  !  local variables
  !  a,b,c,d,gc,b1,b2 are the parameters defining the functional
  !
  real(DP), parameter :: a = 0.0311d0, b = -0.048d0, c = 0.0020d0, &
       d = -0.0116d0, gc = -0.1423d0, b1 = 1.0529d0, b2 = 0.3334d0,&
       a1 = 7.0d0 * b1 / 6.d0, a2 = 4.d0 * b2 / 3.d0
  real(DP) :: x, den, dmx, dmrs
  !
  !
  if (iflg == 1) then
     dmrs = a / rs + 2.d0 / 3.d0 * c * (log (rs) + 1.d0) + &
          (2.d0 * d-c) / 3.d0
  else
     x = sqrt (rs)
     den = 1.d0 + x * (b1 + x * b2)
     dmx = gc * ( (a1 + 2.d0 * a2 * x) * den - 2.d0 * (b1 + 2.d0 * &
          b2 * x) * (1.d0 + x * (a1 + x * a2) ) ) / den**3
     dmrs = 0.5d0 * dmx / x
  endif
  !
  dpz = - fpi * rs**4.d0 / 9.d0 * dmrs
  return
  !
end function dpz


MODULE bsetalter

  use globvars
  use Ham
  use alarrays
  use outputs

!***********************************************************************************!
!*
!*         Basis Set alteration module Module
!*
!*   Contains subroutines for:
!*
!*      1) Relocating the wavefunction on a static grid
!*      2) Leaking the basis set, used for large q values in the Hennon-Heiles model
!*      3) Cloning subroutine, which increases the basis set, used mainly for the
!*              spin boson model
!*      4) Retriving cloning information from previous calculations when using the
!*              AIMC-MCE propagation system
!*
!***********************************************************************************!

contains

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

  subroutine reloc_basis(bsnew, bsold, x) ! Relocation for MCEv1 or MCEv2 after cloning

    implicit none

    type(basisfn), dimension(:), allocatable, intent(inout) :: bsnew   ! This is the new basis set
    type(basisfn), dimension(:), allocatable, intent(inout) :: bsold   ! This is the previous basis set.
    integer, intent(in) :: x

    complex(kind=8), dimension (:,:), allocatable :: ovrlp_mat
    complex(kind=8), dimension (:), allocatable :: cnew, dnew
    complex(kind=8) :: sumamps
    integer :: j, k, r, ierr, nbfnew, nbfold

    if (errorflag .ne. 0) return

    nbfnew = size(bsnew)
    nbfold = size(bsold)

    if (method=="MCEv1") then
      do j=1,nbfold
        sumamps = (0.0d0, 0.0d0)
        do r=1,npes
          sumamps = sumamps + dconjg(bsold(j)%a_pes(r))*bsold(j)%a_pes(r)
        end do
        bsold(j)%D_big = cdsqrt(sumamps)
        do r=1,npes
          bsold(j)%d_pes(r) = bsold(j)%d_pes(r)/bsold(j)%D_big
          bsold(j)%a_pes(r) = bsold(j)%d_pes(r) * cdexp (i*bsold(j)%s_pes(r))
        end do
      end do
      do j=1,nbfnew
        sumamps = (0.0d0, 0.0d0)
        do r=1,npes
          sumamps = sumamps + dconjg(bsnew(j)%a_pes(r))*bsnew(j)%a_pes(r)
        end do
        bsnew(j)%D_big = cdsqrt(sumamps)
        do r=1,npes
          bsnew(j)%d_pes(r) = bsnew(j)%d_pes(r)/bsnew(j)%D_big
          bsnew(j)%a_pes(r) = bsnew(j)%d_pes(r) * cdexp (i*bsnew(j)%s_pes(r))
        end do
      end do
    end if

    allocate (cnew(nbfnew), stat=ierr)
    if (ierr==0) allocate (ovrlp_mat(nbfnew,nbfold), stat=ierr)
    if (ierr/=0) then
      write (0,"(a)") "Error in allocating temporary z values for reprojection subroutine"
      errorflag=1
      return
    end if

    ! Ovrlp_mat is the overlap with the initial wavepacket
    do j=1,nbfold
      do k=1,nbfnew
        cnew(k) = (0.0d0, 0.0d0)
        sumamps = (0.0d0, 0.0d0)
        do r=1,npes
          sumamps = sumamps + dconjg(bsnew(k)%a_pes(r))*bsold(j)%a_pes(r)
        end do
        ovrlp_mat(k,j) = ovrlpij(bsnew(k)%z(:), bsold(j)%z(:)) * sumamps
      end do
    end do

    do r=1,npes
      cnew(:) = matmul(ovrlp_mat,bsold(:)%D_big)
    end do

    deallocate(ovrlp_mat, stat=ierr)
    if (ierr==0) allocate (ovrlp_mat(nbfnew,nbfnew), stat=ierr)
    if (ierr/=0) then
      write (0,"(a,a)") "Error in de- and re-allocation of first overlap matrix in reprojection subroutine"
      errorflag = 1
      return
    end if

    ovrlp_mat = ovrlpphimat(bsnew)

    allocate (dnew(nbfnew), stat=ierr)
    if (ierr/=0) then
      write (0,"(a,a)") "Error in allocation of dnew in reprojection subroutine"
      errorflag=1
      return
    end if

    do r=1,npes
      call lineq(ovrlp_mat, cnew, dnew)
    end do

    deallocate(ovrlp_mat, stat=ierr)
    if (ierr/=0) then
      write (0,"(a,a)") "Error in deallocation of input overlap"
      errorflag=1
      return
    end if

    do k=1,nbfnew
      bsnew(k)%D_big = dnew(k)
    end do

    if (method=="MCEv1") then
      do j=1,nbfnew
        do r=1,npes
          bsnew(j)%d_pes(r) = bsnew(j)%d_pes(r)*bsnew(j)%D_big
          bsnew(j)%a_pes(r) = bsnew(j)%d_pes(r) * cdexp (i*bsnew(j)%s_pes(r))
        end do
        bsnew(j)%D_big = (1.0d0,0.0d0)
      end do
      do j=1,nbfold
        do r=1,npes
          bsold(j)%d_pes(r) = bsold(j)%d_pes(r)*bsold(j)%D_big
          bsold(j)%a_pes(r) = bsold(j)%d_pes(r) * cdexp (i*bsold(j)%s_pes(r))
        end do
        bsold(j)%D_big = (1.0d0,0.0d0)
      end do
    end if

    deallocate(dnew, stat=ierr)
    if (ierr/=0) then
      write (0,"(a)"),"Error deallocating dnew arrays in reloc"
      errorflag = 1
      return
    end if

    return

  end subroutine reloc_basis

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

  subroutine cloning(bs,nbf,x,time,clone, clonenum, reps)

    !!NOTE: Cloning is only set up for 2 PESs. This needs to be generalised!

    implicit none

    type(basisfn), dimension(:), allocatable, intent(inout) :: bs
    type(basisfn), dimension(:), allocatable :: bsnew
    real(kind=8), intent(in) :: time
    integer, dimension(:), allocatable, intent(inout) :: clone, clonenum
    integer, intent (inout) :: nbf
    integer, intent (in) :: x, reps
    complex(kind=8), dimension (:), allocatable :: dz
    real(kind=8), dimension (:), allocatable :: dummy_arr, length, phi
    real(kind=8) :: brforce, normar, sumamps, p, q, pqsqrd, deltaprob, phaseval, dist
    integer, dimension(:), allocatable :: clonehere, clonecopy, clonecopy2
    integer :: k, m, j, n, nbfnew, ierr, r, s, clonetype, dummy1, dummy2
    character(LEN=3)::rep

    if (errorflag==1) return

    if ((cloneflg=="YES").or.(cloneflg=="QSC").or.((cloneflg=="BLIND+").and.(x.ne.0))) then
      clonetype = 1 ! 1=conditional cloning, 2=blind cloning
    else if ((cloneflg=="BLIND").or.((cloneflg=="BLIND+").and.(x.eq.0))) then
      clonetype = 2
    else
      write (0,"(2a)") "Cloneflg is invalid. Should be 'YES', 'BLIND' or 'BLIND+', but was ", cloneflg
      errorflag = 1
      return
    end if

    allocate (clonehere(nbf), stat=ierr)
    if (ierr==0) allocate(clonecopy(nbf), stat=ierr)
    if (ierr==0) allocate(clonecopy2(nbf), stat=ierr)
    if (ierr/=0) then
      write (0,"(a)") "Error allocating the clonehere array"
      errorflag = 1
      return
    end if

    if (npes.ne.2) then
      write(6,*) "Error. Cloning currently only valid for npes=2"
      errorflag = 1
      return
    end if

    do k=1,nbf
      if (clone(k).lt.x-clonefreq) clone(k)=0
      clonehere(k) = 0
    end do

    ! Build the map of which trajectories to clone, done on the basis function by basis function level (clonetype=1),
    ! or the entire basis set at once (clonetype=2)

    if (clonetype==1) then
      do k=1,nbf
        normar = 0.0d0
        do r=1,npes
          normar = normar + dconjg(bs(k)%a_pes(r))*bs(k)%a_pes(r)
        end do
        !!!!! The line below needs changing to acount for multiple PESs
        brforce = ((abs(bs(k)%a_pes(1)*bs(k)%a_pes(2))**2.0)/(normar**2.0))
        if ((brforce.gt.thresh).and.(clone(k)==0).and.(clonenum(k).lt.clonemax)) then
          clone(k) = x
          clonehere(k) = 1
        end if
        clonecopy(k) = clone(k)
        clonecopy2(k) = clonenum(k)
      end do
    else if (clonetype==2) then
      if (mod(x,clonefreq)==0) then
        do k=1,nbf
          if (clonenum(k).lt.clonemax) then
            clone(k) = x
            clonehere(k) = 1
          end if
        end do
      end if
      do k=1,nbf
        clonecopy(k) = clone(k)
        clonecopy2(k) = clonenum(k)
      end do

    end if

    ! build new sized clone mapping arrays to use for next itteration

    nbfnew = nbf + sum(clonehere(:))

    deallocate (clone, stat=ierr)
    if (ierr==0) deallocate (clonenum, stat=ierr)
    if (ierr==0) allocate (clone(nbfnew), stat=ierr)
    if (ierr==0) allocate (clonenum(nbfnew), stat=ierr)
    if (ierr/=0) then
      write (0,"(a)") "Error in de- and re-allocation of clone arrays"
      errorflag = 1
      return
    end if
    do k=1,nbf
      clone(k) = clonecopy(k)
      clonenum(k) = clonecopy2(k)
    end do
    deallocate(clonecopy, stat=ierr)
    if (ierr==0) deallocate(clonecopy2, stat=ierr)
    if (ierr/=0) then
      write(0,"(a)") "Error deallocating the cloning copy arrays"
      errorflag = 1
      return
    end if

    ! Actual cloning section

    if (nbfnew/=nbf) then

      call allocbs(bsnew, nbfnew)

      j=1

      write(rep,"(i3.3)") reps
      open(unit=47756,file="Clonetrack-"//trim(rep)//".out",status="old",access="append",iostat=ierr)

      allocate (dz(ndim), stat=ierr)
      if (ierr/=0) then
        write(0,'(a)') "Error in allocating dz array for MCEv1 cloning/relocation"
        errorflag = 1
        return
      end if

      if (cloneflg=="QSC") then
        clonetype = 3
      else if (method=="MCEv2") then
        clonetype = 1
      else if (method=="MCEv1") then
        clonetype = 2
      end if

      do k=1,nbf

        if (clonehere(k) == 1) then
          clone(k) = x
          clone(nbf+j) = x
          clonenum(k) = clonenum(k) + 1
          clonenum(nbf+j) = clonenum(k)

          if (clonetype==1) then

            ! First child trajectory
            bsnew(k)%D_big = bs(k)%D_big * abs(bs(k)%a_pes(in_pes))
            bsnew(k)%d_pes(in_pes) = bs(k)%d_pes(in_pes)/abs(bs(k)%a_pes(in_pes))
            do r=1,npes
              if (r.ne.in_pes) then
                bsnew(k)%d_pes(r) = (0.0d0,0.0d0)
              end if
              bsnew(k)%s_pes(r) = bs(k)%s_pes(r)
              bsnew(k)%a_pes(r) = bsnew(k)%d_pes(r) * cdexp(i*bsnew(k)%s_pes(r))
            end do
            do m=1,ndim
              bsnew(k)%z(m) = bs(k)%z(m)
            end do

            ! Second child trajectory
            bsnew(nbf+j)%D_big = bs(k)%D_big * sqrt(1.-(dconjg(bs(k)%a_pes(in_pes))*bs(k)%a_pes(in_pes)))
            bsnew(nbf+j)%d_pes(in_pes) = (0.0d0,0.0d0)
            do r=1,npes
              if (r.ne.in_pes) then
                if (x.eq.0) then
                  bsnew(nbf+j)%d_pes(r) = (1.0d0,0.0d0)
                else
                  bsnew(nbf+j)%d_pes(r) = bs(k)%d_pes(r)/&
                                  sqrt(1.-(dconjg(bs(k)%a_pes(in_pes))*bs(k)%a_pes(in_pes)))
                end if
              end if
              bsnew(nbf+j)%s_pes(r) = bs(k)%s_pes(r)
              bsnew(nbf+j)%a_pes(r) = bsnew(nbf+j)%d_pes(r) * cdexp(i*bsnew(nbf+j)%s_pes(r))
            end do
            do m=1,ndim
              bsnew(nbf+j)%z(m) = bs(k)%z(m)
            end do

          else if (clonetype==2) then

            !!!!!!!!!!NOTE!!!!!!!!!!!

            !This is only half of the MCEv1 cloning procedure. After cloning occurs,
            !the reloc_basis subroutine is called to recalculate the amplitudes.
            ! Checking that the reloc function works as expected would be a good place to start

            ! First child trajectory
            bsnew(k)%D_big = bs(k)%D_big
            bsnew(k)%d_pes(in_pes) = bs(k)%d_pes(in_pes)
            do m=1,ndim
              dz(m)=cmplx(ZBQLNOR(dble(bs(k)%z(m)),sqrt(0.5d0)),ZBQLNOR(dimag(bs(k)%z(m)),sqrt(0.5)))
            end do
            do r=1,npes
              if (r.ne.in_pes) then
                bsnew(k)%d_pes(r) = (0.0d0,0.0d0)
              end if
              bsnew(k)%s_pes(r) = bs(k)%s_pes(r)
              bsnew(k)%a_pes(r) = bsnew(k)%d_pes(r) * cdexp(i*bsnew(k)%s_pes(r))
            end do
            do m=1,ndim
              bsnew(k)%z(m) = bs(k)%z(m) - dz(m)
            end do

            ! Second child trajectory
            bsnew(nbf+j)%D_big = bs(k)%D_big
            bsnew(nbf+j)%d_pes(in_pes) = (0.0d0,0.0d0)
            do r=1,npes
              if (r.ne.in_pes) then
                if (x.eq.0) then
                  bsnew(nbf+j)%d_pes(r) = (1.0d0,0.0d0)
                else
                  bsnew(nbf+j)%d_pes(r) = bs(k)%d_pes(r)
                end if
              end if
              bsnew(nbf+j)%s_pes(r) = bs(k)%s_pes(r)
              bsnew(nbf+j)%a_pes(r) = bsnew(nbf+j)%d_pes(r) * cdexp(i*bsnew(nbf+j)%s_pes(r))
            end do
            do m=1,ndim
              bsnew(nbf+j)%z(m) = bs(k)%z(m) + dz(m)
            end do

          else if (clonetype==3) then

          !!CCS circular distribution of amplitudes - generalised to n potential energy surfaces

          allocate(length(npes),phi(npes))

          !First Child Trajectory

          do r=1,npes
            dummy1 = 0
            do while (dummy1 .eq. 0)
              call random_number(length(r))
              call random_number(phi(r))
              phi(r) = phi(r) * 2.0d0 * pirl
              if (r == 1) then
                dummy1 = 1
              else
                do s = 1,r-1
                  !!!! Check that the amplitude values would be sufficiently separated
                  !!!! in the complex plane. This does not seem very efficient however.
                  dist = 0.0d0
                  dist = (length(r)*dcos(phi(r))-length(s)*dcos(phi(s)))**2
                  dist = dist + (length(r)*dsin(phi(r))-length(s)*dsin(phi(s)))**2
                  dist = sqrt(dist)
                  if (dist > qsce) then
                    dummy1 = 1
                  end if
                  !!!! Below checks no two amplitudes would stimulate cloning.
                  !!!! Valid for 2 PESs, but the calculations would change for a more general case
                  !!!! since the cloning is not stimulated by only a single pair of PES components
                  if (dummy1 == 0) then
                    dist = (length(r)**2)*(length(s)**2)/(length(r)**2)+(length(s)**2)
                    if (dist > thresh) then
                      dummy1 = 1
                    end if
                  end if
                end do
              end if
            end do
          end do

          do r=1,npes
            bsnew(k)%a_pes(r) = cmplx(length(r)*dcos(phi(r)),length(r)*dsin(phi(r)),kind=8)
          end do

          !Second Child Trajectory

          do r=1,npes
            s = npes - (r-1)
            if (r .le. (npes/2.)) then
              bsnew(nbf+j)%a_pes(r) = cmplx(length(s)*dcos(phi(s)),(-1.0d0)*length(s)*dsin(phi(s)),kind=8)
            else
              bsnew(nbf+j)%a_pes(r) = cmplx((-1.0d0)*length(s)*dcos(phi(s)),length(s)*dsin(phi(s)),kind=8)
            end if
            if ((mod(npes,2)==1).and.(r==int(floor(real(npes)/2.))+1)) then
              bsnew(nbf+j)%a_pes(r) = cmplx(0.0d0*dcos(phi(r)),0.0d0*dsin(phi(r)),kind=8)
            end if
          end do

          deallocate (length, phi)

          do m=1,ndim
            bsnew(k)%z(m) = bs(k)%z(m)
            bsnew(nbf+j)%z(m) = bs(k)%z(m)
          end do
          do r= 1,npes
            bsnew(k)%s_pes(r) = bs(k)%s_pes(r)
            bsnew(k)%d_pes(r) = bsnew(k)%a_pes(r) * cdexp(-i*bsnew(k)%s_pes(r))
            bsnew(nbf+j)%s_pes(r) = bs(k)%s_pes(r)
            bsnew(nbf+j)%d_pes(r) = bsnew(nbf+j)%a_pes(r) * cdexp(-i*bsnew(nbf+j)%s_pes(r))
          end do

!          !!OAB circular distribution amplitudes

!            dummy1 = 0
!            do while (dummy1.eq.0)
!              dummy2 = 0
!              do while(dummy2.eq.0)
!                call random_number(p)
!                call random_number(q)
!                pqsqrd = (p**2)+(q**2)
!                if (pqsqrd <1) then
!                  dummy2 = 1
!                end if
!              end do
!              p = p/sqrt(pqsqrd)
!              q = q/sqrt(pqsqrd)
!              deltaprob = abs((p**2)-(q**2))
!              if (deltaprob > qsce) then
!                dummy1 = 1
!              end if
!            end do
!            call random_number(phaseval)
!            phaseval = phaseval * 2.0d0 * pirl
!
!            !Assign First child trajectory a'1
!            bsnew(k)%a_pes(1) = cmplx(p,0.0d0,kind=8)
!            !Assign First child trajectory a'2
!            bsnew(k)%a_pes(2) = cmplx(q*dcos(phaseval),q*dsin(phaseval),kind=8)
!            !Assign Second child trajectory to be orthogonal a"1
!            bsnew(nbf+j)%a_pes(1)= cmplx(q*dcos(phaseval),-1.0d0*q*dsin(phaseval),kind=8)
!            !Assign Second child trajectory to be orthogonal a"2
!            bsnew(nbf+j)%a_pes(2)= cmplx(-p,0.0d0,kind=8)
!
!            do m=1,ndim
!              bsnew(k)%z(m) = bs(k)%z(m)
!              bsnew(nbf+j)%z(m) = bs(k)%z(m)
!            end do
!            do r= 1,npes
!              bsnew(k)%s_pes(r) = bs(k)%s_pes(r)
!              bsnew(k)%d_pes(r) = bsnew(k)%a_pes(r) * cdexp(-i*bsnew(k)%s_pes(r))
!              bsnew(nbf+j)%s_pes(r) = bs(k)%s_pes(r)
!              bsnew(nbf+j)%d_pes(r) = bsnew(nbf+j)%a_pes(r) * cdexp(-i*bsnew(nbf+j)%s_pes(r))
!            end do

!            !!CCS square distribution of amplitudes

!            do r=1,npes
!              !First child trajectory
!              sumamps = 0.0d0
!              q = q * 2.0 - 1.0     ! possibly try modifying the range to enforce close to pes amplitudes
!              p = p * 2.0 - 1.0
!              bsnew(k)%d_pes(r) = cmplx(q,p,kind=8)
!              sumamps = sumamps + dsqrt(dble(cmplx(q,p,kind=8) * cmplx(q,-1.0*p,kind=8)))
!            end do
!            do r=1,npes
!              bsnew(k)%d_pes(r) = bsnew(k)%d_pes(r) / sumamps
!              bsnew(k)%s_pes(r) = bs(k)%s_pes(r)
!              bsnew(k)%a_pes(r) = bsnew(k)%d_pes(r) * cdexp(i*bsnew(k)%s_pes(r))
!            end do
!            do m=1,ndim
!              bsnew(k)%z(m) = bs(k)%z(m)
!            end do
!
!            !Second child trajectory
!            sumamps = 0.0d0
!            do r=1,npes
!              call random_number(q)
!              call random_number(p)
!              q = q * 2.0 - 1.0     ! possibly try modifying the range to enforce close to pes amplitudes
!              p = p * 2.0 - 1.0
!              bsnew(nbf+j)%d_pes(r) = cmplx(q,p,kind=8)
!              sumamps = sumamps + dsqrt(dble(cmplx(q,p,kind=8) * cmplx(q,-1.0*p,kind=8)))
!            end do
!            do r=1,npes
!              bsnew(nbf+j)%d_pes(r) = bsnew(nbf+j)%d_pes(r) / sumamps
!              bsnew(nbf+j)%s_pes(r) = bs(k)%s_pes(r)
!              bsnew(nbf+j)%a_pes(r) = bsnew(nbf+j)%d_pes(r) * cdexp(i*bsnew(nbf+j)%s_pes(r))
!            end do
!            do m=1,ndim
!              bsnew(nbf+j)%z(m) = bs(k)%z(m)
!            end do

            !Modifications to capital D amplitudes

            bsnew(k)%D_big = bs(k)%D_big * (bsnew(nbf+j)%a_pes(2)*bs(k)%a_pes(1)-bsnew(nbf+j)%a_pes(1)*bs(k)%a_pes(2))
            bsnew(nbf+j)%D_big = bs(k)%D_big * (bsnew(k)%a_pes(1)*bs(k)%a_pes(2)-bsnew(k)%a_pes(2)*bs(k)%a_pes(1))

            bsnew(k)%D_big = bsnew(k)%D_big/&
                    (bsnew(k)%a_pes(1)*bsnew(nbf+j)%a_pes(2)-bsnew(k)%a_pes(2)*bsnew(nbf+j)%a_pes(1))
            bsnew(nbf+j)%D_big = bsnew(nbf+j)%D_big/&
                    (bsnew(k)%a_pes(1)*bsnew(nbf+j)%a_pes(2)-bsnew(k)%a_pes(2)*bsnew(nbf+j)%a_pes(1))

          end if

          write(47756,"(3i5,2es25.17e3)") x, k, nbf+j, abs(bs(k)%a_pes(in_pes)), sqrt(1.-((abs(bs(k)%a_pes(in_pes))**2.0d0)))
          j = j+1

        else

          bsnew(k)%D_big = bs(k)%D_big
          do r=1,npes
            bsnew(k)%d_pes(r) = bs(k)%d_pes(r)
            bsnew(k)%s_pes(r) = bs(k)%s_pes(r)
            bsnew(k)%a_pes(r) = bsnew(k)%d_pes(r) * cdexp(i*bsnew(k)%s_pes(r))
          end do
          do m=1,ndim
            bsnew(k)%z(m) = bs(k)%z(m)
          end do

        end if

      end do

      close (47756)

      if (method=="MCEv1") call reloc_basis(bsnew, bs, x)

      call deallocbs(bs)
      call allocbs(bs, nbfnew)

      do k=1,nbfnew
        bs(k)%D_big = bsnew(k)%D_big
        do r=1,npes
          bs(k)%a_pes(r) = bsnew(k)%a_pes(r)
          bs(k)%d_pes(r) = bsnew(k)%d_pes(r)
          bs(k)%s_pes(r) = bsnew(k)%s_pes(r)
        end do
        do m=1,ndim
          bs(k)%z(m) = bsnew(k)%z(m)
        end do
      end do

      call deallocbs(bsnew)

      n = nbfnew-nbf

      write (6,"(i0,a,i0,a,i0)") sum(clonehere(:)), " bfs cloned in step ", x, &
            ". nbf now = ", nbfnew

      nbf = nbfnew

    end if

    deallocate(clonehere, stat=ierr)
    if (ierr/=0) then
      write(0,"(a)") "Error deallocating the clone-here array"
      errorflag = 1
      return
    end if

  end subroutine cloning

!***********************************************************************************!
end module bsetalter


      subroutine newvel(k,beta,den,dt)
*
*
*       determine new velocities of two interacting objects after encounter
*       -------------------------------------------------------------------
*       M. HENON 1971, Astrophysics and Space Science Vol. 14, 151
*       ----------------------------------------------------------
*
*
      include 'common.h'
*
*
      real*8 vr1,vr2,vtx1,vtx2,vty1,vty2,beta,wx,wy,
     &       wz,w,wx1,wy1,wz1,wx2,wy2,wz2,wp,psi,sinpsi,cospsi,
     &       sbeta,cbeta,wnx,wny,wnz,vnx1,vnx2,vny1,vny2,sm1,sm2,
     &       sm12,sm112,sm212,den,dt
*
      real*4 ran2
*
      integer k,im1,im2
*
      common /chesc/ sm12,sm112,sm212,w,wx,wy,wz,wx1,wy1,wz1,wx2,
     &               wy2,wz2,vtx1,vtx2,vty1,vty2,vr1,vr2,
     &               sinpsi,cospsi
*
*
      im1 = iname(k)
      im2 = iname(k+1)
*
      sm1 = body(im1)
      sm2 = body(im2)
      sm12 = sm1 + sm2
      sm112 = sm1/sm12
      sm212 = sm2/sm12
      vr1 = vr(im1)
      vr2 = vr(im2)
*
      vtx1 = vt(im1)
      vtx2 = vt(im2)*cosfi
      vty1 = 0.0d0
      vty2 = vt(im2)*sinfi
*
      wx = vtx2 - vtx1
      wy = vty2 - vty1
      wz = vr2 - vr1
      wp = wx*wx + wy*wy
      w = wp + wz*wz
      w = sqrt(w)
      wp = sqrt(wp)
*
      wx1 = wy*w/wp
      wy1 = -wx*w/wp
      wz1 = 0.0d0
      wx2 = -wx*wz/wp
      wy2 = -wy*wz/wp
      wz2 = wp
*
      psi = twopi*ran2(irun)
      sinpsi = sin(psi)
      cospsi = cos(psi)
      sbeta = sin(beta)
      cbeta = cos(beta)
*
      wnx = wx*cbeta + wx1*sbeta*cospsi + wx2*sbeta*sinpsi
      wny = wy*cbeta + wy1*sbeta*cospsi + wy2*sbeta*sinpsi
      wnz = wz*cbeta + wz1*sbeta*cospsi + wz2*sbeta*sinpsi
*
      vnx1 = vtx1 - sm212*(wnx - wx)
      vnx2 = vtx2 + sm112*(wnx - wx)
      vny1 = vty1 - sm212*(wny - wy)
      vny2 = vty2 + sm112*(wny - wy)
      vrn1 = vr1 - sm212*(wnz - wz)
      vrn2 = vr2 + sm112*(wnz - wz)
      vtn1 = sqrt(vnx1*vnx1 + vny1*vny1)
      vtn2 = sqrt(vnx2*vnx2 + vny2*vny2)
c
c      write(6,*) 'k,im1,im2,vrn1,vtn1,vrn2,vtn2 = ',k,im1,im2,vrn1,
c     &            vtn1,vrn2,vtn2

*
*     check for the true escapers. Method suggested by D.C. Heggie - 1996
*     do not check for tidaly limited clouster
*
cChanged for M67:
c      if(imodel.ne.3) call checke(k,dt,den)
c      if(imodel.ne.3.and.imodel.ne.4) call checke(k,dt,den)
cNext change recommended by mig 25/8/9
      if(imodel.lt.3) call checke(k,dt,den)
*
      return
*
      end
*
*
*
*


!*==cpstf2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CPSTF2 computes the Cholesky factorization with complete pivoting of complex Hermitian positive semidefinite matrix.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CPSTF2 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )
!
!       .. Scalar Arguments ..
!       REAL               TOL
!       INTEGER            INFO, LDA, N, RANK
!       CHARACTER          UPLO
!       ..
!       .. Array Arguments ..
!       COMPLEX            A( LDA, * )
!       REAL               WORK( 2*N )
!       INTEGER            PIV( N )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CPSTF2 computes the Cholesky factorization with complete
!> pivoting of a complex Hermitian positive semidefinite matrix A.
!>
!> The factorization has the form
!>    P**T * A * P = U**H * U ,  if UPLO = 'U',
!>    P**T * A * P = L  * L**H,  if UPLO = 'L',
!> where U is an upper triangular matrix and L is lower triangular, and
!> P is stored as vector PIV.
!>
!> This algorithm does not attempt to check that A is positive
!> semidefinite. This version of the algorithm calls level 2 BLAS.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          n by n upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading n by n lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>
!>          On exit, if INFO = 0, the factor U or L from the Cholesky
!>          factorization as above.
!> \endverbatim
!>
!> \param[out] PIV
!> \verbatim
!>          PIV is INTEGER array, dimension (N)
!>          PIV is such that the nonzero entries are P( PIV(K), K ) = 1.
!> \endverbatim
!>
!> \param[out] RANK
!> \verbatim
!>          RANK is INTEGER
!>          The rank of A given by the number of steps the algorithm
!>          completed.
!> \endverbatim
!>
!> \param[in] TOL
!> \verbatim
!>          TOL is REAL
!>          User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )
!>          will be used. The algorithm terminates at the (K-1)st step
!>          if the pivot <= TOL.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is REAL array, dimension (2*N)
!>          Work space.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          < 0: If INFO = -K, the K-th argument had an illegal value,
!>          = 0: algorithm completed successfully, and
!>          > 0: the matrix A is either rank deficient with computed rank
!>               as returned in RANK, or is not positive semidefinite. See
!>               Section 7 of LAPACK Working Note #161 for further
!>               information.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexOTHERcomputational
!
!  =====================================================================
      SUBROUTINE CPSTF2(Uplo,N,A,Lda,Piv,Rank,Tol,Work,Info)
      IMPLICIT NONE
!*--CPSTF2146
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      REAL Tol
      INTEGER Info , Lda , N , Rank
      CHARACTER Uplo
!     ..
!     .. Array Arguments ..
      COMPLEX A(Lda,*)
      REAL Work(2*N)
      INTEGER Piv(N)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ONE , ZERO
      PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
      COMPLEX CONE
      PARAMETER (CONE=(1.0E+0,0.0E+0))
!     ..
!     .. Local Scalars ..
      COMPLEX ctemp
      REAL ajj , sstop , stemp
      INTEGER i , itemp , j , pvt
      LOGICAL upper
!     ..
!     .. External Functions ..
      REAL SLAMCH
      LOGICAL LSAME , SISNAN
      EXTERNAL SLAMCH , LSAME , SISNAN
!     ..
!     .. External Subroutines ..
      EXTERNAL CGEMV , CLACGV , CSSCAL , CSWAP , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC CONJG , MAX , REAL , SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      Info = 0
      upper = LSAME(Uplo,'U')
      IF ( .NOT.upper .AND. .NOT.LSAME(Uplo,'L') ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -4
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('CPSTF2',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) RETURN
!
!     Initialize PIV
!
      DO i = 1 , N
         Piv(i) = i
      ENDDO
!
!     Compute stopping value
!
      DO i = 1 , N
         Work(i) = REAL(A(i,i))
      ENDDO
      pvt = MAXLOC(Work(1:N),1)
      ajj = REAL(A(pvt,pvt))
      IF ( ajj<=ZERO .OR. SISNAN(ajj) ) THEN
         Rank = 0
         Info = 1
         GOTO 99999
      ENDIF
!
!     Compute stopping value if not supplied
!
      IF ( Tol<ZERO ) THEN
         sstop = N*SLAMCH('Epsilon')*ajj
      ELSE
         sstop = Tol
      ENDIF
!
!     Set first half of WORK to zero, holds dot products
!
      DO i = 1 , N
         Work(i) = 0
      ENDDO
!
      IF ( upper ) THEN
!
!        Compute the Cholesky factorization P**T * A * P = U**H * U
!
         DO j = 1 , N
!
!        Find pivot, test for exit, else swap rows and columns
!        Update dot products, compute possible pivots which are
!        stored in the second half of WORK
!
            DO i = j , N
!
               IF ( j>1 ) Work(i) = Work(i)                             &
     &                              + REAL(CONJG(A(j-1,i))*A(j-1,i))
               Work(N+i) = REAL(A(i,i)) - Work(i)
!
            ENDDO
!
            IF ( j>1 ) THEN
               itemp = MAXLOC(Work((N+j):(2*N)),1)
               pvt = itemp + j - 1
               ajj = Work(N+pvt)
               IF ( ajj<=sstop .OR. SISNAN(ajj) ) THEN
                  A(j,j) = ajj
                  GOTO 100
               ENDIF
            ENDIF
!
            IF ( j/=pvt ) THEN
!
!              Pivot OK, so can now swap pivot rows and columns
!
               A(pvt,pvt) = A(j,j)
               CALL CSWAP(j-1,A(1,j),1,A(1,pvt),1)
               IF ( pvt<N ) CALL CSWAP(N-pvt,A(j,pvt+1),Lda,A(pvt,pvt+1)&
     &                                 ,Lda)
               DO i = j + 1 , pvt - 1
                  ctemp = CONJG(A(j,i))
                  A(j,i) = CONJG(A(i,pvt))
                  A(i,pvt) = ctemp
               ENDDO
               A(j,pvt) = CONJG(A(j,pvt))
!
!              Swap dot products and PIV
!
               stemp = Work(j)
               Work(j) = Work(pvt)
               Work(pvt) = stemp
               itemp = Piv(pvt)
               Piv(pvt) = Piv(j)
               Piv(j) = itemp
            ENDIF
!
            ajj = SQRT(ajj)
            A(j,j) = ajj
!
!           Compute elements J+1:N of row J
!
            IF ( j<N ) THEN
               CALL CLACGV(j-1,A(1,j),1)
               CALL CGEMV('Trans',j-1,N-j,-CONE,A(1,j+1),Lda,A(1,j),1,  &
     &                    CONE,A(j,j+1),Lda)
               CALL CLACGV(j-1,A(1,j),1)
               CALL CSSCAL(N-j,ONE/ajj,A(j,j+1),Lda)
            ENDIF
!
         ENDDO
!
      ELSE
!
!        Compute the Cholesky factorization P**T * A * P = L * L**H
!
         DO j = 1 , N
!
!        Find pivot, test for exit, else swap rows and columns
!        Update dot products, compute possible pivots which are
!        stored in the second half of WORK
!
            DO i = j , N
!
               IF ( j>1 ) Work(i) = Work(i)                             &
     &                              + REAL(CONJG(A(i,j-1))*A(i,j-1))
               Work(N+i) = REAL(A(i,i)) - Work(i)
!
            ENDDO
!
            IF ( j>1 ) THEN
               itemp = MAXLOC(Work((N+j):(2*N)),1)
               pvt = itemp + j - 1
               ajj = Work(N+pvt)
               IF ( ajj<=sstop .OR. SISNAN(ajj) ) THEN
                  A(j,j) = ajj
                  GOTO 100
               ENDIF
            ENDIF
!
            IF ( j/=pvt ) THEN
!
!              Pivot OK, so can now swap pivot rows and columns
!
               A(pvt,pvt) = A(j,j)
               CALL CSWAP(j-1,A(j,1),Lda,A(pvt,1),Lda)
               IF ( pvt<N ) CALL CSWAP(N-pvt,A(pvt+1,j),1,A(pvt+1,pvt), &
     &                                 1)
               DO i = j + 1 , pvt - 1
                  ctemp = CONJG(A(i,j))
                  A(i,j) = CONJG(A(pvt,i))
                  A(pvt,i) = ctemp
               ENDDO
               A(pvt,j) = CONJG(A(pvt,j))
!
!              Swap dot products and PIV
!
               stemp = Work(j)
               Work(j) = Work(pvt)
               Work(pvt) = stemp
               itemp = Piv(pvt)
               Piv(pvt) = Piv(j)
               Piv(j) = itemp
            ENDIF
!
            ajj = SQRT(ajj)
            A(j,j) = ajj
!
!           Compute elements J+1:N of column J
!
            IF ( j<N ) THEN
               CALL CLACGV(j-1,A(j,1),Lda)
               CALL CGEMV('No Trans',N-j,j-1,-CONE,A(j+1,1),Lda,A(j,1), &
     &                    Lda,CONE,A(j+1,j),1)
               CALL CLACGV(j-1,A(j,1),Lda)
               CALL CSSCAL(N-j,ONE/ajj,A(j+1,j),1)
            ENDIF
!
         ENDDO
!
      ENDIF
!
!     Ran to completion, A has full rank
!
      Rank = N
!
      GOTO 99999
!
!     Rank is number of steps completed.  Set INFO = 1 to signal
!     that the factorization cannot be used to solve a system.
!
 100  Rank = j - 1
      Info = 1
!
!
!     End of CPSTF2
!
99999 END SUBROUTINE CPSTF2


      subroutine xyz(xx,yy,yyp,yypp)
!     compute y,y',y'' for a curve described by cubic's e(5,*)
!     where (1) = x-max  (2) = high order coefficient.
      use kinddefine
      use coef, only:e
      implicit none
      integer(kind=K4) :: k
      real(kind=K8),intent(in) :: xx
      real(kind=K8),intent(out) :: yy,yyp,yypp
      real(kind=K8) :: a1,a2,a3,az,t,s,r,x,y,yp,ypp,zero
      data zero/0.0d+0/
      x=xx
      if(x.ge.e(1,1)) goto 2
1     y=zero
      yp=zero
      ypp=zero
      goto 5
2     do k=2,200
       if(x.le.e(1,k)) goto 4
      enddo
      goto 1
4     a3=e(2,k)
      a2=e(3,k)
      a1=e(4,k)
      az=e(5,k)
      t=a2+a2
      s=a3*3.0d+0
      r=s+s
      y=az+x*(a1+x*(a2+x*a3))
      yp=a1+x*(t+x*s)
      ypp=t+r*x
5     yy=y
      yyp=yp
      yypp=ypp
      end subroutine xyz


	FUNCTION TDSDET(CHANNEL,F)
C
C	THIS IS THE GAIN OF A CIRCUIT JUST BEFORE THE TDS DETECTOR
C
	INTEGER*4 CHANNEL
	COMPLEX Z1,Y2,GAIN
	COMMON /GAINBLK/ PHASE,GAIN
	DATA R1,C1,R2,C2 /1.505E3,.33E-6,1.E5,.33E-6/
	DATA TWOPI /6.2831853/
C
	W = TWOPI*F
	IF(CHANNEL.GT.2) THEN
	  Z1 = CMPLX(R2,-1./W/C2)
	  GAIN = R2/Z1
	ELSE
	  Z1 = CMPLX(R1,-1./W/C1)
	  GAIN = R1/Z1
	ENDIF
C
	GNIP = AIMAG(GAIN)
	GNRP = GAIN
	PHASE = ATAN2(GNIP,GNRP)
	FFTAMP = CABS(GAIN)
	RETURN
	END


module util

  use types, only: dp

  implicit none

  interface cumsum
     module procedure cumsum_dp
     module procedure cumsum_i
  end interface cumsum

contains

  function bincount(x)
    integer, dimension(:), intent(in) :: x
    integer, dimension(:), allocatable :: bincount

    integer :: i, k

    allocate(bincount(maxval(x)))
    bincount = 0

    do i = 1, size(x)
       k = x(i)
       bincount(k) = bincount(k) + 1
    end do
  end function bincount

  function cumsum_i(x) result (cumsum)
    integer, dimension(:), intent(in) :: x
    integer, dimension(size(x)) :: cumsum

    integer :: i

    cumsum(1) = x(1)
    do i = 2, size(x)
       cumsum(i) = cumsum(i - 1) + x(i)
    end do
  end function cumsum_i

  function cumsum_dp(x) result (cumsum)
    real(dp), dimension(:), intent(in) :: x
    real(dp), dimension(size(x)) :: cumsum

    integer :: i

    cumsum(1) = x(1)
    do i = 2, size(x)
       cumsum(i) = cumsum(i - 1) + x(i)
    end do
  end function cumsum_dp

  subroutine cummin(x)
    real(dp), dimension(:), intent(inout) :: x

    integer :: i

    do i = size(x) - 1, 1, -1
       x(i) = min(x(i), x(i + 1))
    end do
  end subroutine cummin

  subroutine unique(x, values, inverse)
    use m_uniinv, only: uniinv

    real(dp), dimension(:), intent(in) :: x
    real(dp), dimension(:), allocatable, intent(out) :: values
    integer, dimension(size(x)), intent(out) :: inverse

    integer :: i

    call uniinv(x, inverse)
    allocate(values(maxval(inverse)))

    do i = 1, size(inverse)
       values(inverse(i)) = x(i)
    end do
  end subroutine unique

  function exponentialSearch(values, key, offset) result (position)
    real(dp), dimension(:), intent(in) :: values
    real(dp), intent(in) :: key
    integer, intent(in) :: offset
    integer :: position

    integer :: lbound, ubound, mid, window

    lbound = offset
    window = min(1, size(values) - offset)  !! assert offset <= size(values) and key <= maxval(values)

    do while (values(lbound + window) < key)
       lbound = lbound + window
       window = min(window * 2, size(values) - lbound)
    end do

    ubound = lbound + window

    do while (lbound <= ubound)
       mid = lbound + (ubound - lbound) / 2
       if (values(mid) >= key) then
          ubound = mid - 1
       else
          lbound = mid + 1
       end if
    end do

    position = lbound
  end function exponentialSearch

  function insertionPoints(keys, values)
    real(dp), dimension(:), intent(in) :: keys
    real(dp), dimension(:), intent(in) :: values
    integer, dimension(size(keys)) :: insertionPoints

    integer :: i, offset

    offset = 1

    do i = 1, size(keys)
       if (keys(i) <= values(size(values))) then
          insertionPoints(i) = exponentialSearch(values, keys(i), offset)
          offset = insertionPoints(i)
       else
          insertionPoints(i) = -1
       end if
    end do
  end function insertionPoints

end module util


module fcn_sod_shock_tube
#include <messenger.h>
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO, HALF, ONE, TWO, THREE, FIVE, EIGHT, PI
    use type_point,     only: point_t
    use type_function,  only: function_t
    implicit none
    private

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !-------------------------------------------------------------------------------
    type, extends(function_t), public :: sod_shock_tube_f
        private

        integer(ik) :: ivar
        real(rk)    :: gam, beta

    contains

        procedure   :: init
        procedure   :: compute

    end type sod_shock_tube_f
    !********************************************************************************

contains

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(sod_shock_tube_f),  intent(inout) :: self

        !
        ! Set function name
        !
        call self%set_name("sod shock tube  ::   ")

    end subroutine init
    !*************************************************************************

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !!
    !----------------------------------------------------------------------------------
    elemental function compute(self,time,coord) result(val)
        class(sod_shock_tube_f),    intent(in)  :: self
        real(rk),                   intent(in)  :: time
        type(point_t),              intent(in)  :: coord

        real(rk)                                :: val

        real(rk)    :: x,   y,   z, &
                       u, v, w, &
                       gam, beta, rho, p

        x = coord%c1_
        y = coord%c2_
        z = coord%c3_

        gam = self%gam
        beta = self%beta

        if (x <= 400._rk) then
            rho = ONE
            u   = ZERO
            v   = ZERO
            w   = ZERO
            p   = ONE
        else if (x > 400._rk) then
            rho = 0.125_rk
            u   = ZERO
            v   = ZERO
            w   = ZERO
            p   = 0.1_rk
        end if

        select case (self%ivar)
            ! RHO
            case (1)
                val = rho

            ! RHO-U
            case (2)
                val = rho*u

            ! RHO-V
            case (3)
                val = rho*v

            ! RHO-W
            case (4)
                val = rho*w

            ! RHO-E
            case (5)
                val = p/(gam-ONE)  +  HALF*rho*(u*u + v*v + w*w)

        end select

    end function compute
    !******************************************************************************************

end module fcn_sod_shock_tube


! chk_quadreal.f90 --
!     Check: does the compiler support reals with larger precision than double precision?
!
!     Note: if not, then the compilation will fail (kind < 0)
!
program chk_quadreal
    implicit none

    integer, parameter :: quadruple = selected_real_kind(precision(1.0d0)+1)
    real(quadruple)    :: quadruple_value = 1.0_quadruple

    write(*,'(a,i0)') 'Precision for "quadruple" reals: ', precision(quadruple_value)
    write(*,'(a,i0)') 'Range for "quadruple" reals:     ', range(quadruple_value)
end program chk_quadreal


C NCLFORTSTART
      SUBROUTINE DH2SDRV(DATI,DATO,HYA,HYB,P0,SIGI,SIGO,INTYP,PSFC,NLVI,
     +                   NLVO)
      IMPLICIT NONE

      INTEGER INTYP,NLVI,NLVO
      DOUBLE PRECISION DATI(NLVI),DATO(NLVO),P0,PSFC,HYA(NLVO),
     +                 HYB(NLVO),SIGI(NLVI),SIGO(NLVO)
C NCLEND

c NCL:  xHybrid = sigma2hybrid(xSigma,sigma,hya,hyb,P0,psfc,intyp)

C*PL*ERROR* Comment line too long
c          sigo must be created in the interface. Need only be done once.
c          It is the same size as hya/hyb.

C         ----- ORIGINAL FUNCTION DOCUMENTATION --------------
C****     THIS ROUTINE INTERPLOATES DATA TO MODEL HYBRID
C****     COORDINATES FROM SIGMA COORDINATES USING SIGMA SURFACES.
C****     THE TYPE OF INTERPOLATION IS CURRENTLY A VARIANT OF
C****     TRANSFORMED SIGMA COORDINATES WITH THE  INTERPOLATION TYPE
C****     SPECIFIED BY INTYP.  ALL HYBRID COORDINATE VALUES ARE
C****     TRANSFORMED TO SIGMA VALUES. WHERE THE
C****     FORMULA FOR THE PRESSURE OF A HYBRID SURFACE IS;
C****          P(K) = HBCOFA(LEVH,K)*P0 + HBCOFB(LEVH,K)*PSFC
C****     THE RELATIONSHIP OF PRESSURE AND SIGMA IS;
C****          SIG(K) = P(K)/PSFC
C****     HENCE,
C****          SIG(K) = HBCOFA(K)*P0/PSFC + HBCOFB(K)
C****     WHERE,
C****          HBCOFA - IS THE "A" OR PRESSURE HYBRID COEF
C****          LEVH   - IS THE LAYER SURFACE (INTERFACE=1 MIDPOINT=2)
C****          P0     - IS THE BASE PRESSURE (PA)
C****          K      - THE LEVEL INDEX (RUNNING FROM TOP TO BOTTOM)
C****          HBCOFB - IS THE "B" OR SIGMA COEFICIENT
C****          P(K)   - IS THE PRESSURE OF A HYBRID SURFACE (PA).
C****          PSFC   - IS THE SURFACE PRESSURE IN PASCALS

C****                   (MB = .01*PASCALS   : PA = 100*MB/hPA)

C****        SIGI    - 1 DIMENSIONAL ARRAY CONTAINING MODEL SIGMA
C****                  SURFACES.  ARRAY IS NLVI.
C****                  AS WITH THE HYBRID COEFFICIENTS THEY ARE
C****                  ORDERED FROM TOP TO BOTTOM.

      INTEGER N

c convert hybrid to sigma. P0 and psfc are in the same units.

      DO N = 1,NLVO
          SIGO(N) = (HYA(N)*P0)/PSFC + HYB(N)
      END DO

      CALL DS2HBD(DATI,DATO,INTYP,SIGI,SIGO,NLVI,NLVO)

      RETURN
      END
c ------------
      SUBROUTINE DS2HBD(FKR,FKM,INTYP,SIGLEVI,SIGLEVO,NLI,NLO)
      IMPLICIT NONE
C
C****     THIS ROUTINE INTERP. A VERTICAL COLUMN OF SIGMA
C****     COORDINATE DATA TO HYBRID COORDINATES.
C
C****     ON INPUT-
C****        FKR     - INPUT DATA ON SIGMA COORDINATES
C****        FKM     - OUTPUT DATA  ON HYBRID COORD.
C****        INTYP   - TYPE OF INTERP. TO BE PERFORMED (1 - LINEAR,
C****                   2 - LOG ,3 - LOG-LOG
C****        SIGLEVI - 2 DIMENSIONAL ARRAY CONTAINING MODEL SIGMA
C****                  SURFACES.  ARRAY IS 2*NLVIP1.  THE 1ST INDEX
C****                  TAKES ON THE VALUE OF EITHER
C****                    1 - FOR LEVEL INTERFACES (OR 1/2 LEVELS) OR;
C****                    2 - FOR LEVEL MIDPOINTS  (OR FULL LEVELS WHERE
C****                        VIRTUALLY ALL VARIABLES ARE LOCATED)
C****                   AS WITH THE HYBRID COEFFICIENTS THEY ARE
C****                   ORDERED FROM TOP TO BOTTOM.
C****        SIGLEVO - ARRAY SPACE TO HOLD OUTPUT PRESURE SURFACES
C****                  FOR EITHER A 1/2 OF FULL LEVELS.  CURRENTLY
C****                  ALL VARIABLES ARE ON FULL LEVELS.
C****        NLI     - NO. OF PRESS SFCS.
C****        NLIP1   - NLI + 1
C****        NLO     - NO. OF MODEL HYBRID LEVELS.
C****
C****     ON OUTPUT-
C****        FKM - OUTPUT DATA ON MODEL HYBRID COORDINATES
C
C     INTEGER INTYP, NLI, NLIP1, NLO, IPHLV
C     REAL    FKR(NLI),FKM(NLO),SIGLEVO(NLO),SIGLEVI(NLIP1)  ! original
      INTEGER INTYP,NLI,NLO
      DOUBLE PRECISION FKR(NLI),FKM(NLO),SIGLEVO(NLO),SIGLEVI(NLI)

      INTEGER K,KP,IPRINT
      DOUBLE PRECISION A2LN,A1
C
C****     STATEMENT FCN. FOR DOUBLE ALOG. INTERP ON PRESSURE SURFACES
C****     PRESUMES PRESSURE IS IN MB
C
C     A2LN(A1)=ALOG(ALOG(A1+2.72))
C
C****     STATEMENT FCN. FOR DOUBLE ALOG. INTERP ON SIGMA SURFACES.
C****     SETS UP ROUGH UPPER BPOUND SIMILAR TO STATEMENT FCN FOR
C****     PRESSURE. I.E.    FIXED VALUE LN(LN(P) = LN(LN(FIXED VAL)
C****     AT .001 SIGMA OR ABOUT 1 MB
C
      A2LN(A1) = DLOG(DLOG(A1+1.001D0))
C
C****     BRACKET LEVEL TO BE INTERP. UNLESS MODEL IS AT EXTREMA OF REAL
C****     DATA LEVELS
C
      DO 60 K = 1,NLO
C
C****     IF BRANCH FOR MODEL TOP
C
          IF (SIGLEVO(K).LE.SIGLEVI(2)) THEN
              KP = 1
              GO TO 20
C
C****     IF BRANCH FOR MODEL BOTTOM
C
          ELSE IF (SIGLEVO(K).GE.SIGLEVI(NLI-1)) THEN
              KP = NLI - 1
              GO TO 20
C
C****     IF BRANCH FOR MODEL INTERIOR
C
          ELSE
              KP = 1
   10         CONTINUE
              KP = KP + 1
              IF (SIGLEVO(K).LE.SIGLEVI(KP+1)) GO TO 20
              GO TO 10
          END IF
   20     CONTINUE
C
C****     LINEAR INTERP.
C
          IF (INTYP.EQ.1) THEN
              FKM(K) = FKR(KP) + (FKR(KP+1)-FKR(KP))*
     +                 (SIGLEVO(K)-SIGLEVI(KP))/
     +                 (SIGLEVI(KP+1)-SIGLEVI(KP))
C
C****     LOG INTERPOLATION.
C
          ELSE IF (INTYP.EQ.2) THEN
              FKM(K) = FKR(KP) + (FKR(KP+1)-FKR(KP))*
     +                 DLOG(SIGLEVO(K)/SIGLEVI(KP))/
     +                 DLOG(SIGLEVI(KP+1)/SIGLEVI(KP))
C
C****     FOR LOG LOG INTERP. NOTE A2LN IS A STATEMENT FCN.
C
          ELSE IF (INTYP.EQ.3) THEN
              FKM(K) = FKR(KP) + (FKR(KP+1)-FKR(KP))*
     +                 (A2LN(SIGLEVO(K))-A2LN(SIGLEVI(KP)))/
     +                 (A2LN(SIGLEVI(KP+1))-A2LN(SIGLEVI(KP)))
          END IF
   60 CONTINUE
      RETURN
      END