!> \file sanseir.f90
!> \brief Solves a stochastic SEIR model
!> \author S. Scott Collis
!=============================================================================!

!> \brief Useful constants
module constants
  real, parameter :: zero    = 0.0000000000000000000d+0
  real, parameter :: pt25    = 2.5000000000000000000d-1
  real, parameter :: pt33    = 3.3333333333333333333d-1
  real, parameter :: pt5     = 5.0000000000000000000d-1
  real, parameter :: pt66    = 6.6666666666666666666d-1
  real, parameter :: one     = 1.0000000000000000000d+0
  real, parameter :: onept25 = 1.2500000000000000000d+0
  real, parameter :: onept33 = 1.3333333333333333333d+0
  real, parameter :: onept5  = 1.5000000000000000000d+0
  real, parameter :: two     = 2.0000000000000000000d+0
  real, parameter :: three   = 3.0000000000000000000d+0
  real, parameter :: four    = 4.0000000000000000000d+0
  real, parameter :: pi      = 3.1415926535897932385d+0
  real, parameter :: eps     = 1.0000000000000000000d-9
end module constants

!=============================================================================!

!> \brief SEIR Model parmameters
module seir_model
  implicit none
  character(60) :: title="disease progression model"  !< Title of run
  integer, parameter :: mk=10  !< max number of phases
  integer :: nk=1              !< number of phases
  real :: Ro(mk)               !< Reproduction rate per phase
  real :: tk(mk)               !< Time of each phase
  real :: P                    !< Total population
  real :: Io                   !< Initial infected (in Ic)
  real :: alphat               !< Reciprocal of incupation period: \f$\tilde\alpha = \alpha^{-1}\f$
  real :: gammat               !< Reciprocal of infectious period: \f$\tilde\gamma = \gamma^{-1}\f$
  real :: beta(mk)             !< Contact rate (per phase)
  real :: rho(mk)              !< Testing fraction (per phase)
  real :: c                    !< Mortality rate
  real :: cfr                  !< Case fatality rate
  logical :: use_cfr=.false.   !< use CFR
  real :: alpham               !< Mean value for incubation period, \f$\alpha\f$
  real :: gammam               !< Mean value for infectious period, \f$\gamma\f$
  real :: to=0                 !< Starting time (days)
  real :: tf=250               !< End time (days)
  real :: dt                   !< time step
  real :: Fa=0.2               !< Fraction of infected accounted for
  integer :: nt=0              !< number of time steps
  integer :: Erlang_k=2        !< Shape of Erlang distribution
  integer :: Erlang_n=100      !< Number of Erlang samples
  real    :: alpha_min=1       !< Minimum value of \f$\alpha\f$
  real    :: gamma_min=1       !< Minimum value of \f$\gamma\f$
  integer :: ms=50             !< Number of samples in ensemble

  namelist /model/ title, P, Io, alpham, gammam, Erlang_k, Erlang_n, Ro, &
                   rho, c, Fa, alpha_min, gamma_min, cfr, use_cfr, ms
  namelist /time/ to, tf, nt, tk, nk
end module seir_model

!=============================================================================!
!> \brief SanSEIR solves a stochastic SEIR disease progression model
program sanseir
!=============================================================================!
!
! This follows the formulation and approach presented in:
!
! Yao Ye Yeo, Yao-Rui Yeo, Wan-Jin Yeo, "A Computational Model for Estimating
! the Progression of the COVID-19 Cases in the US West and East Coasts",
! MedRxiv, March 2020, https://doi.org/10.1101/2020.03.24.20043026
!
! Author:  S. Scott Collis
!
! Copyright: (c)2020 S. Scott Collis, All rights reserved
!
! Written: 3-29-2020
!=============================================================================!
  use constants
  use seir_model
  implicit none

  integer :: i, n, ns
  external :: seir
  real, external :: erlang_sample

  integer, parameter :: neq=8
  real, allocatable :: U(:,:), V(:), dUdt(:,:), t(:)

  integer, parameter :: mfile=1
  integer :: narg, iarg, nfile=0, ifile(mfile)
  character(80) :: arg, iname, ofile, sfile, rfile

  logical :: use_rk4=.false.   !< Whether to use RK4 (default is RKCK45).

  real :: alphai               !< Sample of \f$\alpha\f$
  real :: gammai               !< Sample of \f$\gamma\f$
  real :: alphas               !< Average \f$\alpha\f$
  real :: gammas               !< Average \f$\famma\f$
  real :: Cr                   !< Cases (reported)
  real :: dCrdt                !< rate of cases reported
!=============================================================================!

! parse arguments

  narg = iargc()
  do iarg = 1, narg
    call getarg(iarg,arg)
    if (arg(1:1) .ne. '-') then
      nfile = nfile + 1
      if (nfile .gt. mfile) then
        write(*,*) '>> Error in argument list, too many file names'
        call exit(1)
      end if
      ifile(nfile) = iarg
    else
      select case (arg(1:3))
      case ('-rk')
        write(*,'("Using RK4 instead of RKCK45")')
        use_rk4 = .true.
      case ('-h')
        write(*,"('--------------------------------------------------')")
        write(*,"('Usage: sanseir [options] [file]')")
        write(*,"('--------------------------------------------------')")
        write(*,"('   -h:  this help                                 ')")
        write(*,"('  -rk:  use RK4 instead of RKCK45                 ')")
        write(*,"('--------------------------------------------------')")
        call exit(0)
      case default
        write(*,"('Argument ',i2,' ignored.')") iarg
      end select
    end if
  end do

! Initialize parameters

  Ro = zero
  beta = zero
  rho = zero

! Read in model parameters

  if (nfile.gt.0) then
    call getarg(ifile(1),iname)
  else
    iname = "seir.inp"
  endif
  open(10,file=iname,status='old')
  read(10,nml=time)
  read(10,nml=model)
  close(10)

  write(*,'(80("="))')
  write(*,'("SanSEIR: " a)') title
  write(*,'(80("="))')

  write(*,'("Echo of namelist input:")')
  write(*,nml=time)
  if(nk.gt.mk) then
    write(*,*) "nk > mk, terminating"
    call exit(1)
  endif
  write(*,nml=model)

! allocate storage

  allocate ( U(neq,0:nt), V(neq), dUdt(neq,0:nt), t(0:nt) )

! Setup time

  dt = (tf-to)/nt
  write(*,"('Using timestep, dt = ',1pe12.4e3)") dt

! Setup model parameters

  call random_init(.true.,.true.)
! call random_seed()
  alphai = max(one,erlang_sample(Erlang_k,alpham))
  gammai = max(one,erlang_sample(Erlang_k,gammam))

  alphat = one/alphai
  gammat = one/gammai
  beta   = Ro*gammat

! set the initial condition
! U = {S, E, Ih, Ic, Rh, Rc, Dh, Dc}

#ifdef SANSEIR_ORIGINAL_IC
  U(:,:) = zero
  U(1,0) = P-Io
  U(2,0) = Io
#else
  U(:,:) = zero
  U(1,0) = P-Io
  U(4,0) = Io
#endif

#ifdef TEST_ERLANG
  alphas = 0
  gammas = 0
  do n = 1, 100000
    alphai = max(alpha_min,Erlang_sample(Erlang_k,alpham))
    gammai = max(gamma_min,erlang_sample(Erlang_k,gammam))
    alphas = alphas + alphai
    gammas = gammas   + gammai
  end do
  write(*,*) alphas/100000, gammas/100000
  call exit(0)
#endif

! begin the time loop

  do ns = 1, ms
    write(*,'("Computing sample: ",i0)') ns
    t(0) = to
    do i = 1, nt
      U(:,i) = zero
      do n = 1, Erlang_n
        V(:)   = zero
        alphai = max(alpha_min,Erlang_sample(Erlang_k,alpham))
        gammai = max(gamma_min,Erlang_sample(Erlang_k,gammam))
        alphat = one/alphai
        gammat = one/gammai
        beta   = Ro*gammat
        if (use_rk4) then
          call rk4(neq,U(:,i-1),V,t(i-1),dt,seir)
        else
          call rkck45(neq,U(:,i-1),V,t(i-1),dt,seir)
        endif
        U(:,i) = U(:,i) + V(:)
        call seir(neq, U(:,i-1), t(i-1), V)
        dUdt(:,i) = dUdt(:,i) + V(:)
      end do
      U(:,i) = U(:,i)/Erlang_n
      dUdt(:,i) = dUdt(:,i)/Erlang_n
      t(i) = t(i-1) + dt
    end do
    write(ofile,"('output.',i0)") ns
    write(sfile,"('scaled.',i0)") ns
    write(rfile,"('rates.',i0)") ns
    open(unit=10,file=ofile)
    open(unit=20,file=sfile)
    open(unit=30,file=rfile)
!=============================================================================!
! Column Index:   1  2  3   4   5   6   7   8   9     10    11  12 13
!=============================================================================!
    write(10,'("# t, S, E, Ih, Ic, Rh, Rc, Dh, Dc, Ih+0.2Ic, R, D, Cr")')
    write(20,'("# t, S, E, Ih, Ic, Rh, Rc, Dh, Dc, Ih+0.2Ic, R, D, Cr")')
    write(30,'("# t, S, E, Ih, Ic, Rh, Rc, Dh, Dc, Ih+0.2Ic, R, D, Cr")')
    do i = 0, nt
      Cr    = U(5,i)+Fa*U(6,i)+U(7,i)+U(8,i)              ! Cases (reported)
      dCrdt = dUdt(5,i)+Fa*dUdt(6,i)+dUdt(7,i)+dUdt(8,i)  ! Cases (reported)
      write(10,10) t(i), U(:,i), U(3,i)+Fa*U(4,i), U(5,i)+U(6,i), &
                   U(7,i)+U(8,i), Cr
      write(20,10) t(i), U(:,i)/P, (U(3,i)+Fa*U(4,i))/P, (U(5,i)+U(6,i))/P, &
                   (U(7,i)+U(8,i))/P, Cr/P
      write(30,10) t(i), dUdt(:,i), dUdt(3,i)+Fa*dUdt(4,i), &
                   dUdt(5,i)+dUdt(6,i), dUdt(7,i)+dUdt(8,i), dCrdt
    end do
    close(10)
    close(20)
    close(30)
  end do

10 format(12(1pe16.8E3,', '),1pe16.8e3)
  stop
end program sanseir

!=============================================================================!
!> \brief Erlang probability distribution
!> \param[in] x value for which probability is sought
!> \param[in] k Erlang shape parameter
!> \param[in] mean Mean value of the distribution
!> \return probability from Erlang_k distribution
function Erlang(x, k, mean)
!=============================================================================!
  implicit none
  integer k
  real Erlang, x, mean, lambda, invfact
!=============================================================================!
  lambda = k/mean
  invfact = 1.0/Gamma(real(k))
  Erlang = lambda**k*x**(k-1)*exp(-lambda*x)*invfact
end function Erlang

!=============================================================================!
!> \brief Sample from an Erlang distribution
!> \param[in] k Erlang shape parameter
!> \param[in] mean Mean value of the distribution
!> \return sample from Erlang_k distribution
function Erlang_sample(k, mean)
!=============================================================================!
  implicit none
  integer k, i
  real Erlang_sample, r(k), prod, mean, lambda
!=============================================================================!
  if (k.eq.0) then
    erlang_sample = mean
    return
  end if
  lambda = k/mean
  call random_number(r)
  prod = r(1)
  do i = 2, k
    prod = prod*r(i)
  end do
  Erlang_sample = -1.0/lambda*log(prod)
end function Erlang_sample

!=============================================================================!
!> \brief Compute the time-derivative of the SEIR model
!> \param[in] neq number of equations
!> \param[in] U state fector at time t
!> \param[in] t current time
!> \param[out] dUdt time-derivative at time t
subroutine seir(neq, U, t, dUdt)
!=============================================================================!
  use constants
  use seir_model
  implicit none
  real, external :: erlang_sample
  integer neq, i, k
  real U(neq), t, dUdt(neq), b, r
  real N, Ni, S, E, Ih, Ic, Rh, Rc, It, ct
!=============================================================================!

! compute the effective total population

  N = zero
  do i = 1, 6
    N = N + U(i)
  end do
  Ni = one/N  ! inverse of total effective population

  S  = U(1)   ! susceptable population
  E  = U(2)   ! exposed population
  Ih = U(3)   ! Infected population in a hospital
  Ic = U(4)   ! Infected population in community
  Rh = U(5)   ! Recovered population in hospital
  Rc = U(6)   ! Recovered population in community

! use time varying contact rate and testing fractions

  b = beta(1)
  do k = 1, nk
    if (t.gt.tk(k)) then
      b = beta(k)         ! current contact rate
      r = rho(k)          ! current testing fraction
    endif
  end do

  if (.not.use_cfr) then
    dUdt(1) = -b*Ic*S*Ni
    dUdt(2) =  b*Ic*S*Ni - alphat*E
    dUdt(3) =  alphat*r*E - gammat*Ih
    dUdt(4) =  alphat*(one-r)*E - gammat*Ic
    dUdt(5) =  gammat*(one-c)*Ih
    dUdt(6) =  gammat*(one-c)*Ic
    dUdt(7) =  gammat*c*Ih
    dUdt(8) =  gammat*c*Ic
  else
    It = (Ih + Fa*Ic)        ! confirmed cases
    ct = cfr * It/(Ih+Ic)    ! convert CFR to c
    dUdt(1) = -b*Ic*S*Ni
    dUdt(2) =  b*Ic*S*Ni - alphat*E
    dUdt(3) =  alphat*r*E - gammat*Ih
    dUdt(4) =  alphat*(one-r)*E - gammat*Ic
    dUdt(5) =  gammat*(one-ct)*Ih
    dUdt(6) =  gammat*(one-ct)*Ic
    dUdt(7) =  gammat*ct*Ih
    dUdt(8) =  gammat*ct*Ic
  endif

  return
end subroutine seir

!=============================================================================!
!> \brief Advance one time step using Runge-Kutta Cash-Karp 4/5 method
!> \param[in] neq number of equations
!> \param[in] yo initial value
!> \param[out] yf final value
!> \param[in] to intial time
!> \param[in] h time step
!> \param[in] FUNC function to integrate
subroutine RKCK45(neq, yo, yf, to, h, FUNC)
!=============================================================================!
!
! Advance one time step Runge-Kutta Cash-Karp method
!
!=============================================================================!
  implicit none
  external FUNC
  integer  neq, i, j, k, m, n
  real     to, h, t
  real     yo(neq), yf(neq), yt(neq)
  real     yk(neq,6), ye(neq)
!=============================================================================!
  real b(6,5)
  real a(6), c(6), d(6)
  data a / 0.0, 0.2, 0.3, 0.6, 1.0, 0.875 /
  data b / 0.0, 0.2, 0.075, 0.3, -0.2037037037037037, &
 &         0.029495804398148147, &
 &         0.0, 0.0, 0.225, -0.9, 2.5, 0.341796875, &
 &         0.0, 0.0, 0.0, 1.2, -2.5925925925925926, &
 &         0.041594328703703706, &
 &         0.0, 0.0, 0.0, 0.0, 1.2962962962962963, &
 &         0.40034541377314814, &
 &         0.0, 0.0, 0.0, 0.0, 0.0, 0.061767578125 /
  data c / 0.09788359788359788, 0.0, 0.4025764895330113, &
 &         0.21043771043771045, 0.0, 0.2891022021456804 /
  data d / -0.004293774801587311, 0.0, 0.018668586093857853, &
 &         -0.034155026830808066, -0.019321986607142856, &
 &         0.03910220214568039 /

! Test data

#ifdef DEBUG
  do i = 1, 6
    do j = 1, 5
      write(*,*) i, j, b(i,j)
    end do
  end do
  stop
#endif

! Stage 1 - 6

  do m = 1, 6
    t = to + a(m)*h
    do n = 1, neq
      yt(n) = yo(n)
    end do
    do k = 1, m-1
      do n = 1, neq
        yt(n) = yt(n) + b(m,k)*yk(n,k)
      end do
    end do
    call FUNC(neq, yt, t, yk(1,m))
    do n = 1, neq
      yk(n,m) = h * yk(n,m)
    end do
  end do

! Final solution and error

  do n = 1, neq
    yf(n) = yo(n)
    ye(n) = 0.0
  end do
  do k = 1, 6
    do n = 1, neq
      yf(n) = yf(n) + c(k)*yk(n,k)
      ye(n) = ye(n) + d(k)*yk(n,k)
    end do
  end do

  return
end subroutine RKCK45

!=============================================================================!
!> \brief Advance one time step using fourth order (real) Runge-Kutta
!> \param[in] neq number of equations
!> \param[in] yo initial value
!> \param[out] yf final value
!> \param[in] to intial time
!> \param[in] h time step
!> \param[in] FUNC function to integrate
subroutine RK4(neq, yo, yf, to, h, FUNC)
!=============================================================================!
!
! Advance one time step using fourth order (real) Runge-Kutta
!
!=============================================================================!
  external FUNC
  integer  neq
  real     to, h
  real     yo(neq), yf(neq)
  real     f(neq), k1(neq), k2(neq), k3(neq), k4(neq), q(neq)

  call FUNC(neq, yo, to, f)
  do j = 1 , neq
    k1(j) = h*f(j)
    q(j) = yo(j) + 0.5*k1(j)
  end do
  call FUNC(neq, q, to+0.5*h, f)
  do j = 1 , neq
    k2(j) = h*f(j)
    q(j) = yo(j) + 0.5*k2(j)
  end do
  call FUNC(neq, q, to+0.5*h, f)
  do j = 1 , neq
    k3(j) = h*f(j)
    q(j) = yo(j) + k3(j)
  end do
  call FUNC(neq, q, to+h, f)
  do j = 1 , neq
    k4(j) = h*f(j)
    yf(j) = yo(j)+k1(j)/6.+(k2(j)+k3(j))/3.+k4(j)/6.
  end do

  return
end subroutine RK4


      subroutine  geom
c
c     ******************************************************************
c     *                                                                *
c     *   square root  mapping of the profile to a slit                *
c     *                                                                *
c     ******************************************************************
c
      use dims
c
c     ******************************************************************
c
      use in_var
      use geo_var
      use mesh_var
c
c     ******************************************************************
c
      use flo_param
      use geo_param
c
c     ******************************************************************
c
      implicit none
c
c     ******************************************************************
c
c     local variables
c
c     ******************************************************************
c
      integer  :: i,i1,i2
      integer  :: ind
c
c     ******************************************************************
c
      real     :: pi,angl1,angl2,t1,t2
      real     :: xa,ya,u,v,r,angl
      real     :: x0,y0,x1,ang,a,b,d
c
c     ******************************************************************
c
      real, dimension(nn)      :: xs,ys,d1,d2,d3
c
c     ******************************************************************
c
      pi        = 4.*atan(1.)

      scal      = .50001*xlim**2/(xn(nn)  -xsing)
      angl      = atan(slopt)
      angl1     = atan2((yn(1)  -ysing),(xn(1)  -xsing))
      angl2     = atan2((yn(nn)  -ysing),(xn(nn)  -xsing))
      angl1     = angl  -.5*(angl1  -trail)
      angl2     = angl  -.5*(angl2  +trail)
      t1        = tan(angl1)
      t2        = tan(angl2)

      angl      = pi  +pi
      u         = 1.
      v         = 0.

      do i=1,nn
         xa        = xn(i)  -xsing
         ya        = yn(i)  -ysing
         angl      = angl  +atan2((u*ya  -v*xa),(u*xa  +v*ya))
         r         = scal*sqrt(xa**2  +ya**2)
         u         = xa
         v         = ya
         r         = sqrt(2.*r)
         xs(i)     = r*cos(.5*angl)
         ys(i)     = r*sin(.5*angl)
      end do

      scal      = 1./scal

      call splif (1,nn,xs,ys,d1,d2,d3,1,t1,1,t2,0,0.,ind)
      call intpl (itl,itu,a0,s0,1,nn,xs,ys,d1,d2,d3,0)

      x1        = .125*(xlim)**2
      angl      = pi  +pi
      u         = 1.
      v         = 0.
      i1        = 1
      i2        = itl  -1
      i         = itl

   11 r         = sqrt(a0(i)**2  +s0(i)**2)
      ang       = 2.*atan2(s0(i),a0(i))
      r         = .5*r**2
      x0        = r*cos(ang)
      y0        = r*sin(ang)
      a         = slopt*(x0  -x1)
      b         = 1./(x0  -x1)

      do i=i1,i2
         xa        = .5*a0(i)**2
         d         = b*(xa  -x1)
         ya        = y0  +a*log(d)/d
         angl      = angl  +atan2((u*ya  -v*xa),(u*xa  +v*ya))
         r         = sqrt(xa**2  +ya**2)
         u         = xa
         v         = ya
         r         = sqrt(2.*r)
         s0(i)     = r*sin(.5*angl)
      end do

      if (i2.eq.il) return

      angl      = 0.
      u         = 1.
      v         = 0.
      i1        = itu  +1
      i2        = il
      i         = itu

      go to 11

      end


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Program name: FiveBodyMD.f90
!
! Program Purpose:
!                  Solve five-bodies probelm in molecule simulation.
!  Version message:
!        Date          Programmer            Description of change
!      ========       ============          =========================
!  1.  13/3/2016      Yang Yang :-)               Source Code
!
!
!
! A brief algorithm introduction:
! First time step is caculated using velocity-verlet algorithm and other time step is
! caculated using verlet algorithm. Velocity is caculated using centered differential scheme.
! $r(0 + \delta t) = 2r(0) - \delta t*v(0) + \frac{1}{2} \delta \t^{2} a(0)$
!!$v(0 + \delta t) = v(t) + \frac{1}{2} \delta t [a(0) + a(0 + \delta t)]$
! $r(t+\delta t) = 2r(t) - r(t - \delta t)+ \delta \t^{2}a(t)$
! $v(t) = [r(t + \delta t) - r(t - \delta t)] / 2\delta t$
! $v(N) = [r(N) - r(N - \delta t)] / \delta t$
! external field : $V(r) = \frac{1}{2} \r^{2}
! internal reaction : Leonard-Jones 6-12 potential  $V(r_{ij}) = 4[(\frac{1}{r_{ij}})^{12} - (\frac{1}{r_{ij}})^{6}]
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!------------------------------------------------------------------------------------------------
! Setup computing parameters
MODULE ParametersBlock
implicit none

integer, parameter:: N_particles = 5;                                                      ! Number of particle
integer, parameter:: N_dimension = 2;                                                      ! Problem dimension

! real*8, parameter:: Mass = 1.d0                                                          ! Particles' mass (this term is not necessary!)

integer, parameter:: N_time = 1000000000;                                                  ! Number of time step
real*8, parameter::  delta_t = 1.d-6;                                                      ! Time step size  (really important)

integer, parameter:: Output_interval = 100000                                              ! Output interval

character(len=20), parameter:: OutputFile = 'result.txt'                                   ! Output file name

real*8, parameter:: pi = 3.1415926535897932384626433832795028841971693993751d0             ! Constant ratio of circumference

!real*8, parameter:: x1_ini = cos(90.d0/180.d0 * pi), y1_ini = sin(90.d0/180.d0 * pi)       ! Particle No.1's position
!real*8, parameter:: x2_ini = cos(18.d0/180.d0 * pi), y2_ini = sin(18.d0/180.d0 * pi)       ! Particle No.2's position
!real*8, parameter:: x3_ini = -cos(18.d0/180.d0 * pi), y3_ini = sin(18.d0/180.d0 * pi)      ! Particle No.3's position
!real*8, parameter:: x4_ini = cos(54.d0/180.d0 * pi), y4_ini = -sin(54.d0/180.d0 * pi)      ! Partical No.4's position
!real*8, parameter:: x5_ini = -cos(54.d0/180.d0 * pi), y5_ini = -sin(54.d0/180.d0 * pi)     ! Partical No.5's Position

!real*8, parameter:: x1_ini = cos(90.d0/180.d0 * pi), y1_ini = sin(90.d0/180.d0 * pi)       ! Particle No.1's position
!real*8, parameter:: x2_ini = cos(30.d0/180.d0 * pi), y2_ini = sin(30.d0/180.d0 * pi)       ! Particle No.2's position
!real*8, parameter:: x3_ini = -cos(30.d0/180.d0 * pi), y3_ini = sin(30.d0/180.d0 * pi)      ! Particle No.3's position
!real*8, parameter:: x4_ini = cos(30.d0/180.d0 * pi), y4_ini = -sin(30.d0/180.d0 * pi)      ! Partical No.4's position
!real*8, parameter:: x5_ini = -cos(30.d0/180.d0 * pi), y5_ini = -sin(30.d0/180.d0 * pi)     ! Partical No.5's Position

real*8, parameter:: x1_ini = cos(90.d0/180.d0 * pi), y1_ini = sin(90.d0/180.d0 * pi)       ! Particle No.1's position
real*8, parameter:: x2_ini = cos(13.d0/180.d0 * pi), y2_ini = sin(13.d0/180.d0 * pi)       ! Particle No.2's position
real*8, parameter:: x3_ini = -cos(5.d0/180.d0 * pi), y3_ini = sin(5.d0/180.d0 * pi)      ! Particle No.3's position
real*8, parameter:: x4_ini = cos(60.d0/180.d0 * pi), y4_ini = -sin(60.d0/180.d0 * pi)      ! Partical No.4's position
real*8, parameter:: x5_ini = -cos(80.d0/180.d0 * pi), y5_ini = -sin(80.d0/180.d0 * pi)     ! Partical No.5's Position

END MODULE ParametersBlock
!------------------------------------------------------------------------------------------------
!------------------------------------------------------------------------------------------------

!------------------------------------------------------------------------------------------------
! The main program
PROGRAM Main
use ParametersBlock
implicit none

! Variables
real*8 x_new(1:N_particles,1:N_dimension), x_current(1:N_particles,1:N_dimension), x_old(1:N_particles,1:N_dimension)   ! Particles' direction
real*8 u_current(1:N_particles,1:N_dimension)                                                                           ! Particles' velocity
real*8 acceleration(1:N_particles,1:N_dimension)                                                                        ! Particles' acceleration
real*8 potential_energy(1:N_particles), kinetic_energy(1:N_particles)                                                   ! particle's Potential energy and Kinetic energy

! Index
integer i,j,ierror
integer:: t = 0

! Initial all varibales
do i = 1, N_particles
  do j = 1, N_dimension
      x_new(i,j) = 0.d0
      x_current(i,j) = 0.d0
      x_old(i,j) = 0.d0
      u_current(i,j) = 0.d0
      acceleration(i,j) = 0.d0
  end do
end do

do i = 1, N_particles
    potential_energy(i) = 0.d0
    kinetic_energy(i) = 0.d0
end do

! Initial particles' state
! particles' initial position
x_current(1,1) =  x1_ini
x_current(1,2) =  y1_ini

x_current(2,1) = x2_ini
x_current(2,2) = y2_ini

x_current(3,1) = x3_ini
x_current(3,2) = y3_ini

x_current(4,1) = x4_ini
x_current(4,2) = y4_ini

x_current(5,1) = x5_ini
x_current(5,2) = y5_ini

call compute_acceleration(x_current,acceleration)          ! Compute acceleration at first time step

! time step evolution
do i = 1,N_particles
   do j = 1,N_dimension
      x_new(i,j) = x_current(i,j) + delta_t*u_current(i,j) + 0.5d0*(delta_t**2)*acceleration(i,j)
   end do
end do

! compute potential energy
call compute_potnetialEnergy(x_current,potential_energy)    ! Compute potential energy

! open the output file
open(unit = 10, file = Trim(OutputFile), IOSTAT = ierror)
if (ierror.EQ.0) then
  print*, 'File result.txt successfully opened!...'
endif

! output result in first time step
Write(10,100) (t-1)*delta_t,&
& x_current(1,1), x_current(1,2), u_current(1,1), u_current(1,2), kinetic_energy(1), potential_energy(1),&
& x_current(2,1), x_current(2,2), u_current(2,1), u_current(2,2), kinetic_energy(2), potential_energy(2),&
& x_current(3,1), x_current(3,2), u_current(3,1), u_current(3,2), kinetic_energy(3), potential_energy(3),&
& x_current(4,1), x_current(4,2), u_current(4,1), u_current(4,2), kinetic_energy(4), potential_energy(4),&
& x_current(5,1), x_current(5,2), u_current(5,1), u_current(5,2), kinetic_energy(5), potential_energy(5)
100 format(1x,31ES24.15,/)

! Output simulation setup parameters
call OutputParameters(x_current,u_current,kinetic_energy,potential_energy)
Write(*,*) 'Are these parameters property?... Programing Paused, Continue?...'
pause

! new to old
x_old = x_current
x_current = x_new

! Time evolution
do t = 2,N_time

   ! Compute acceleration
     call compute_acceleration(x_current,acceleration)
   ! particles' new pisition
     call compute_position(x_current,x_old,acceleration,x_new)

   ! Output
       if(mod(t,Output_interval).EQ.0) then
          ! compute particle's celocity
          call compute_velocity(x_new,x_old,u_current)
          ! compute particle's potential energy
          call compute_potnetialEnergy(x_current,potential_energy)
          ! compute particles' kinetic energy
          call compute_kineticEnergy(u_current,kinetic_energy)
          print 200, (t-1)
          Write(10,100) (t-1)*delta_t,&
&            x_current(1,1), x_current(1,2), u_current(1,1), u_current(1,2), kinetic_energy(1), potential_energy(1),&
&            x_current(2,1), x_current(2,2), u_current(2,1), u_current(2,2), kinetic_energy(2), potential_energy(2),&
&            x_current(3,1), x_current(3,2), u_current(3,1), u_current(3,2), kinetic_energy(3), potential_energy(3),&
&            x_current(4,1), x_current(4,2), u_current(4,1), u_current(4,2), kinetic_energy(4), potential_energy(4),&
&            x_current(5,1), x_current(5,2), u_current(5,1), u_current(5,2), kinetic_energy(5), potential_energy(5)
       end if
    ! time update
    x_old = x_current
    x_current = x_new

end do
200 format(1x,'Current Time Step = ',I10)
 close(10)

! Output computing log file
call logfile(t,x_current,u_current,kinetic_energy,potential_energy)

END PROGRAM Main
!------------------------------------------------------------------------------------------------
!------------------------------------------------------------------------------------------------

!------------------------------------------------------------------------------------------------
SUBROUTINE OutputParameters(x_current,u_current,kinetic_energy,potential_energy)
use ParametersBlock
implicit none

! decline variables
real*8, INTENT(IN)::  x_current(1:N_particles,1:N_dimension), u_current(1:N_particles,1:N_dimension)          ! Particles' position and velocity
real*8, INTENT(IN)::  kinetic_energy(1:N_particles), potential_energy(1:N_particles)                          ! Particles' kinetic energy and potential energy

! file name
character(len=20), parameter:: FileName1='SimulationParameters.txt'

! Print parameters in screen
Write(*,100) N_particles,N_dimension
100 format(1x,'Particles = 'I10,', Problem Dimension = ',I10,/)
Write(*,101) N_time, delta_t, Output_interval
101 format(1x,'Total time step = 'I10,', Time step size = ',ES15.5,', Data output interval = ',I10,/)
Write(*,102)
102 format(1x,'Position     Velocity      Kinetic Energy    Potential Energy',/)
Write(*,103) x_current(1,1), x_current(1,2), u_current(1,1), u_current(1,2), kinetic_energy(1), potential_energy(1)
103 format(1x,', x1 = ',ES15.5,', y1 = ',ES15.5,', u1 = ',ES15.5,', v1 = ',ES15.5,', k1 = ',ES15.5,', p1 = ',ES15.5,/)
Write(*,104) x_current(2,1), x_current(2,2), u_current(2,1), u_current(2,2), kinetic_energy(2), potential_energy(2)
104 format(1x,', x2 = ',ES15.5,', y2 = ',ES15.5,', u2 = ',ES15.5,', v2 = ',ES15.5,', k2 = ',ES15.5,', p2 = ',ES15.5,/)
Write(*,105) x_current(3,1), x_current(3,2), u_current(3,1), u_current(3,2), kinetic_energy(3), potential_energy(3)
105 format(1x,', x3 = ',ES15.5,', y3 = ',ES15.5,', u3 = ',ES15.5,', v3 = ',ES15.5,', k3 = ',ES15.5,', p3 = ',ES15.5,/)
Write(*,106) x_current(4,1), x_current(4,2), u_current(4,1), u_current(4,2), kinetic_energy(4), potential_energy(4)
106 format(1x,', x4 = ',ES15.5,', y4 = ',ES15.5,', u4 = ',ES15.5,', v4 = ',ES15.5,', k4 = ',ES15.5,', p4 = ',ES15.5,/)
Write(*,107) x_current(5,1), x_current(5,2), u_current(5,1), u_current(5,2), kinetic_energy(5), potential_energy(5)
107 format(1x,', x5 = ',ES15.5,', y5 = ',ES15.5,', u5 = ',ES15.5,', v5 = ',ES15.5,', k5 = ',ES15.5,', p5 = ',ES15.5,/)

! Output to file
Open(unit=20,file=Trim(FileName1))
Write(20,100) N_particles,N_dimension
Write(20,101) N_time, delta_t, Output_interval
Write(20,102)
Write(20,103) x_current(1,1), x_current(1,2), u_current(1,1), u_current(1,2), kinetic_energy(1), potential_energy(1)
Write(20,104) x_current(2,1), x_current(2,2), u_current(2,1), u_current(2,2), kinetic_energy(2), potential_energy(2)
Write(20,105) x_current(3,1), x_current(3,2), u_current(3,1), u_current(3,2), kinetic_energy(3), potential_energy(3)
Write(20,106) x_current(4,1), x_current(4,2), u_current(4,1), u_current(4,2), kinetic_energy(4), potential_energy(4)
Write(20,107) x_current(5,1), x_current(5,2), u_current(5,1), u_current(5,2), kinetic_energy(5), potential_energy(5)
 close(20)

END SUBROUTINE OutputParameters
!------------------------------------------------------------------------------------------------
!------------------------------------------------------------------------------------------------

!------------------------------------------------------------------------------------------------
! Compute force
SUBROUTINE compute_acceleration(x_current,acceleration)
use ParametersBlock
implicit none

! decline variables
real*8, INTENT(IN)::  x_current(1:N_particles,1:N_dimension)                                     ! Particles' current position
real*8, INTENT(OUT):: acceleration(1:N_particles,1:N_dimension)                                  ! Particles' acceleration

! Temporary varibles
real*8 x_r,y_r,r,f
! real*8 x_r,y_r,z_r,r,f     ! use this for 3-D

! index
integer i,j,k

! recation with external potential field
do i = 1, N_particles
  do k = 1, N_dimension
      acceleration(i,k) = -x_current(i,k)
  end do
end do

! reaction between particles

do i = 1, N_particles - 1
     do j = i+1, N_particles
        x_r = x_current(i,1) - x_current(j,1)                     ! compute vector x_ij
        y_r = x_current(i,2) - x_current(j,2)                     ! compute vector y_ij
!       z_r = x_current(i,3) - x_current(j,3)                     ! compute vector z_ij
        r = sqrt( x_r**2 + y_r**2 )                               ! compute norm of vector r_ij
!       r = sqrt( x_r**2 + y_r**2 + z_r**2)                       ! Three dimension
        f = 24.d0 * ( 2.d0*(1.d0/r)**13 - (1.d0/r)**7 )           ! compute force scalar due to LJ 6-12 Potential
        acceleration(i,1) = acceleration(i,1) + x_r / r * f       ! compute acceleration in x direction
        acceleration(i,2) = acceleration(i,2) + y_r / r * f       ! compute acceleration in y direction
        acceleration(j,1) = acceleration(j,1) - x_r / r * f       ! compute acceleration in x direction  (inverse force)
        acceleration(j,2) = acceleration(j,2) - y_r / r * f       ! compute acceleration in y direction  (inverse force)
     end do
end do

END SUBROUTINE compute_acceleration
!------------------------------------------------------------------------------------------------

!------------------------------------------------------------------------------------------------
! Update particle's Direction
SUBROUTINE compute_position(x_current,x_old,acceleration,x_new)
use ParametersBlock
implicit none

! decline variables
real*8, INTENT(IN):: x_current(1:N_particles,1:N_dimension), x_old(1:N_particles,1:N_dimension)  ! particles' current position and old position
real*8, INTENT(IN):: acceleration(1:N_particles,1:N_dimension)                                   ! Particles' current acceleration
real*8, INTENT(OUT):: x_new(1:N_particles,1:N_dimension)                                         ! Particles' new direction

! Index
integer i,j

! Verlet Scheme
do i = 1,N_particles
   do j = 1,N_dimension
      x_new(i,j) = 2.d0 * x_current(i,j) - x_old(i,j) + (delta_t**2) * acceleration(i,j)
   end do
end do

END SUBROUTINE compute_position
!------------------------------------------------------------------------------------------------
!------------------------------------------------------------------------------------------------

!------------------------------------------------------------------------------------------------
SUBROUTINE compute_velocity(x_new,x_old,u_current)
use ParametersBlock
implicit none
! particles' current position and old position
real*8, INTENT(IN):: x_new(1:N_particles,1:N_dimension), x_old(1:N_particles,1:N_dimension)
real*8, INTENT(OUT):: u_current(1:N_particles,1:N_dimension)                                       ! Particles' new direction

! index
integer i,j

! compute velocity using centered difference scheme
do i = 1, N_particles
  do j = 1, N_dimension
      u_current(i,j) = ( x_new(i,j) - x_old(i,j) ) / (2.d0*delta_t)
  end do
end do

END SUBROUTINE compute_velocity
!------------------------------------------------------------------------------------------------
!------------------------------------------------------------------------------------------------

!------------------------------------------------------------------------------------------------
SUBROUTINE compute_potnetialEnergy(x_current,potential_energy)
use ParametersBlock
implicit none
real*8, INTENT(IN):: x_current(1:N_particles,1:N_dimension)                                        ! Particles' current position
real*8, INTENT(OUT):: potential_energy(1:N_particles)                                              ! Particles' potential energy

! Index
integer i,j

! temporary varibales
real*8 x_r,y_r,r,phi
! real*8 x_r,y_r,z_r,r,phi     ! 3D

! external field potential
do i = 1, N_particles
      potential_energy(i) = 0.5d0*( x_current(i,1)**2 + x_current(i,2)**2 )
!     Potential_energy(i) = 0.5d0*( x_current(i,1)**2 + x_current(i,2)**2 + x_current(i,3)**2 )      ! 3D
end do

! Compute potential energy
do i = 1, N_particles - 1
     do j = i+1, N_particles
        x_r = x_current(i,1) - x_current(j,1)                     ! compute vector x_ij
        y_r = x_current(i,2) - x_current(j,2)                     ! compute vector y_ij
!       z_r = x_current(i,3) - x_current(j,3)                     ! compute vector z_ij
        r = sqrt( x_r**2 + y_r**2 )                               ! compute norm of vector r_ij
!       r = sqrt( x_r**2 + y_r**2 + z_r**2)                       ! Three dimension
        phi = 4.d0 * ( (1.d0/r)**12 - (1.d0/r)**6 )               ! compute LJ 6-12 Potential
        potential_energy(i) = potential_energy(i) + phi
        potential_energy(j) = potential_energy(j) + phi
     end do
end do

END SUBROUTINE compute_potnetialEnergy
!------------------------------------------------------------------------------------------------
!------------------------------------------------------------------------------------------------

!------------------------------------------------------------------------------------------------
SUBROUTINE compute_kineticEnergy(u_current,kinetic_energy)
use ParametersBlock
implicit none
real*8, INTENT(IN):: u_current(1:N_particles,1:N_dimension)                                         ! Particles' current velocity
real*8, INTENT(OUT):: kinetic_energy(1:N_particles)                                                 ! Particles' kinetic energy

! index
integer i,j

! initial
do i = 1,N_particles
    kinetic_energy(i) = 0.d0
end do

! Sum
do i = 1,N_particles
   do j = 1,N_dimension
      kinetic_energy(i) = kinetic_energy(i) + 0.5d0*(u_current(i,j)**2)
   end do
end do

END SUBROUTINE compute_kineticEnergy
!------------------------------------------------------------------------------------------------
!------------------------------------------------------------------------------------------------

!------------------------------------------------------------------------------------------------
SUBROUTINE logfile(t,x_current,u_current,kinetic_energy,potential_energy)
use ParametersBlock
implicit none

! decline variables
integer, INTENT(IN):: t                                                                                ! Final time step
real*8, INTENT(IN)::  x_current(1:N_particles,1:N_dimension), u_current(1:N_particles,1:N_dimension)         ! Particles' position and velocity
real*8, INTENT(IN)::  kinetic_energy(1:N_particles), potential_energy(1:N_particles)                       ! Particles' kinetic energy and potential energy

! file name
character(len=20), parameter:: FileName1='Report.log'

! Output to ReportFile
Open(unit=20,file=Trim(FileName1))
Write(20,100) N_particles,N_dimension
Write(20,101) N_time, delta_t, Output_interval
Write(20,102) t, real(t-1)*delta_t
Write(20,103)
Write(20,104) x_current(1,1), x_current(1,2), u_current(1,1), u_current(1,2), kinetic_energy(1), potential_energy(1)
Write(20,105) x_current(2,1), x_current(2,2), u_current(2,1), u_current(2,2), kinetic_energy(2), potential_energy(2)
Write(20,106) x_current(3,1), x_current(3,2), u_current(3,1), u_current(3,2), kinetic_energy(3), potential_energy(3)
Write(20,107) x_current(4,1), x_current(4,2), u_current(4,1), u_current(4,2), kinetic_energy(4), potential_energy(4)
Write(20,108) x_current(5,1), x_current(5,2), u_current(5,1), u_current(5,2), kinetic_energy(5), potential_energy(5)

100 format(1x,'Particles = 'I10,', Problem Dimension = ',I10,/)
101 format(1x,'Total time step = 'I10,', Time step size = ',ES15.5,', Data output interval = ',I10,/)
102 format(1x,'Final time step= ',I10,', Final time = ',ES15.5,/)
103 format(1x,'Position     Velocity      Kinetic Energy    Potential Energy',/)
104 format(1x,', x1 = ',ES15.5,', y1 = ',ES15.5,', u1 = ',ES15.5,', v1 = ',ES15.5,', k1 = ',ES15.5,', p1 = ',ES15.5,/)
105 format(1x,', x2 = ',ES15.5,', y2 = ',ES15.5,', u2 = ',ES15.5,', v2 = ',ES15.5,', k2 = ',ES15.5,', p2 = ',ES15.5,/)
106 format(1x,', x3 = ',ES15.5,', y3 = ',ES15.5,', u3 = ',ES15.5,', v3 = ',ES15.5,', k3 = ',ES15.5,', p3 = ',ES15.5,/)
107 format(1x,', x4 = ',ES15.5,', y4 = ',ES15.5,', u4 = ',ES15.5,', v4 = ',ES15.5,', k4 = ',ES15.5,', p4 = ',ES15.5,/)
108 format(1x,', x5 = ',ES15.5,', y5 = ',ES15.5,', u5 = ',ES15.5,', v5 = ',ES15.5,', k5 = ',ES15.5,', p5 = ',ES15.5,/)
 close(20)

END SUBROUTINE logfile
!------------------------------------------------------------------------------------------------
!------------------------------------------------------------------------------------------------


SUBROUTINE sfnum
!======================================
! Stacking Fault Number
!======================================
! Determines the Stacking Fault Number to use as a set of CVs for a metadynamics run.
! Derivatives are generated in this version ==> use for less taxing simulations.
! Otherwise use the light version to increase performance
!======================================

   USE PARACLUSTER
   USE CLUSTER
   USE POTENTIAL
   USE ENFORCE
   USE DISTANCE
   USE META

   IMPLICIT NONE

   integer               :: i, j, mminusn_pwr
   double precision      :: ratio_ton, ratio_tom, rnp, rmp, num
   double precision      :: ratio, comfactor
   real(8), dimension(3) :: rij0 ! 3 possible cases: atoms A-A, B-B, A-B
   real(8), dimension(3) :: dij0 ! 3 possible cases: atoms A-A, B-B, A-B
   real(8), DIMENSION(nsiz,nsiz) :: dij, df_dx, df_dy, df_dz

   if (ipas.eq.1) write(*,*) '> sfnum: first calculation of window function 2 (SFN)'

   !------------------------------------------------------------------------
   mminusn_pwr = msf_pwr - nsf_pwr

   ! Evaluating the values of rij0 parameter in dependence of atom pair kind
   rij0 = dist * rsf * dsqrt(2.d0) ! rij0 and dist are 3 element vectors

   ! Evaluating the ref distance for the couple of atoms (THIS IS DIFFERENT)
   dij0 = dist * dsf * dsqrt(2.d0)
   !------------------------------------------------------------------------

!$OMP PARALLEL DEFAULT(SHARED)
!$OMP DO PRIVATE(i, j), SCHEDULE(STATIC)
   DO i = 1, natom
      DO j = 1, natom
         ! Calculating the distance between atom i and atom j
         dij(j,i) = pair_dist (j,i) - dij0(pairkindmat(j,i))
      END DO
   END DO
!$OMP END DO

!$OMP DO PRIVATE(i), SCHEDULE(STATIC)
   ! Elements on the diagonal
   DO i = 1, natom
      ssf(i,i) = 0.d0
   END DO
!$OMP END DO

!$OMP DO PRIVATE(i, j, ratio, ratio_ton, ratio_tom, rnp, rmp, num), SCHEDULE(DYNAMIC,20)
   DO i = 1, natom-1
      DO j = i+1, natom
         ! Calculating the analytic SFN
         ratio = dij(j,i)/rij0(pairkindmat(j,i))
         ! I need to rise to (X_pwr-1) for the derivative
         ratio_ton = ratio**(nsf_pwr-1)
         ratio_tom = ratio_ton*(ratio**(mminusn_pwr))

         ! Calculating some pieces of derivative
         rnp = nsf_pwr * ratio_ton
         rmp = msf_pwr * ratio_tom

         ! Now ratio_ton becomes really ratio to n_pwr
         ratio_ton = ratio_ton * ratio

         ! Another piece of derivative
         num = rmp - rnp - mminusn_pwr*ratio_ton*ratio_tom
         ! same as:
         ! num = rmp - rnp + ( n_pwr - m_pwr )*ratio**(n_pwr + m_pwr - 1)

         ! Now ratio_tom becomes really ratio to m_pwr
         ratio_tom = ratio_tom * ratio

         ! The sum of these s(i,j) is the analytic coord no.
         ssf(j,i) = (1.d0-ratio_ton)/(1.d0-ratio_tom)  ! this is f(rij)
         ssf(i,j) = ssf(j,i)

         ! Derivative of s
         dS(j,i) = num/( rij0(pairkindmat(j,i))* (1.d0 - ratio_tom)**2)
         dS(i,j) = dS(j,i)
      END DO ! on j
   END DO ! on i
!$OMP END DO

!$OMP DO PRIVATE(i), SCHEDULE(STATIC)
   ! LP: Calculating the sum of ssf(i,j), which is SFNatom(i), global.
   ! This is the SFN of any single atom i
   ! No problem because ssf(i,i) is always zero
   DO i = 1, natom
      SFNatom(i) = SUM(ssf(:,i))
   END DO
!$OMP END DO

!$OMP DO PRIVATE(i,j,comfactor), SCHEDULE(STATIC)
   !-------------------------------------------------------------------------
   ! Calculating the sum on j of derivatives of s
   ! with respect to coordinates of every atoms
   DO i = 1, natom
      DO j = 1, natom
         IF (j .NE.i ) THEN
            ! Calculating the derivative of coordination number with
            ! respect to distance between atoms i and j, multiplied for
            ! the derivative of distance between atoms i and j
            ! with respect to position of atom i
            comfactor = dS(j,i)/ pair_dist(j,i)     ! Common factor for the following...
            df_dx(j,i) = comfactor* xyz_dist(1,j,i) ! order of indexes depends on the definition of xyz_dist
            df_dy(j,i) = comfactor* xyz_dist(2,j,i)
            df_dz(j,i) = comfactor* xyz_dist(3,j,i)
            ELSE
            df_dx(j,i) = 0.d0
            df_dy(j,i) = 0.d0
            df_dz(j,i) = 0.d0
         END IF
      END DO
   END DO
!$OMP END DO

!$OMP SECTIONS PRIVATE(i)
!$OMP SECTION
   DO i = 1, natom
      dSsf_dx(i) = 2.d0 * SUM(df_dx(1:natom, i))
   END DO
!$OMP SECTION
   DO i = 1, natom
      dSsf_dy(i) = 2.d0 * SUM(df_dy(1:natom, i))
   END DO
!$OMP SECTION
   DO i = 1, natom
      dSsf_dz(i) = 2.d0 * SUM(df_dz(1:natom, i))
   END DO
!$OMP END SECTIONS
!$OMP END PARALLEL
   !---------------------------------------------------------------------------
END SUBROUTINE sfnum


      subroutine metric
c
c     ******************************************************************
c     *                                                                *
c     *   cell areas and cell centers (dual mesh)                      *
c     *                                                                *
c     ******************************************************************
c
      use dims
c
c     ******************************************************************
c
      use mesh_var
c
c     ******************************************************************
c
      implicit none
c
c     ******************************************************************
c
c     local variables
c
c     ******************************************************************
c
      integer  :: i,j
c
c     ******************************************************************
c
c     set the areas of interior and exterior cells to zero
c
      do j=0,jb
      do i=0,ib
         vol(i,j)  = 0.
         xc(i,j,1) = 0.
         xc(i,j,2) = 0.
      end do
      end do
c
c     calculate the cell areas and cell centers
c
      do j=2,jl
      do i=2,il
         vol(i,j)  = .5*((x(i,j,1)  -x(i-1,j-1,1))
     .                   *(x(i-1,j,2)  -x(i,j-1,2))
     .                  -(x(i,j,2)  -x(i-1,j-1,2))
     .                   *(x(i-1,j,1)  -x(i,j-1,1)))
         xc(i,j,1) = .25*(x(i,j,1)    +x(i-1,j,1)
     .                   +x(i,j-1,1)  +x(i-1,j-1,1))
         xc(i,j,2) = .25*(x(i,j,2)    +x(i-1,j,2)
     .                   +x(i,j-1,2)  +x(i-1,j-1,2))
      end do
         vol(1,j)    = vol(2,j)
         vol(ie,j)   = vol(il,j)
         xc(1,j,1)   = x(1,j,1)   +x(1,j-1,1)   -xc(2,j,1)
         xc(1,j,2)   = x(1,j,2)   +x(1,j-1,2)   -xc(2,j,2)
         xc(ie,j,1)  = x(il,j,1)  +x(il,j-1,1)  -xc(il,j,1)
         xc(ie,j,2)  = x(il,j,2)  +x(il,j-1,2)  -xc(il,j,2)
      end do
c
c     set boudary values at j=1 and j=je
c
      do i=2,il
         vol(i,1)    = vol(i,2)
         vol(i,je)   = vol(i,jl)
         xc(i,1,1)   = x(i,1,1)   +x(i-1,1,1)   -xc(i,2,1)
         xc(i,1,2)   = x(i,1,2)   +x(i-1,1,2)   -xc(i,2,2)
         xc(i,je,1)  = x(i,jl,1)  +x(i-1,jl,1)  -xc(i,jl,1)
         xc(i,je,2)  = x(i,jl,2)  +x(i-1,jl,2)  -xc(i,jl,2)
      end do
c
c     set boundary values along the cut in the c mesh
c
      do i=2,itl
         vol(ib-i,1)   = vol(i,2)
         xc(ib-i,1,1)  = xc(i,2,1)
         xc(ib-i,1,2)  = xc(i,2,2)
         vol(i,1)    = vol(ib-i,2)
         xc(i,1,1)   = xc(ib-i,2,1)
         xc(i,1,2)   = xc(ib-i,2,2)
      end do
c
c     set corner values
c
      vol(1,1)    = vol(2,1)
      vol(1,je)   = vol(2,je)
      vol(ie,1)   = vol(il,1)
      vol(ie,je)  = vol(il,je)

      xc(1,1,1)   = xc(2,1,1)    +xc(1,2,1)    -xc(2,2,1)
      xc(1,1,2)   = xc(2,1,2)    +xc(1,2,2)    -xc(2,2,2)
      xc(ie,1,1)  = xc(il,1,1)   +xc(ie,2,1)   -xc(il,2,1)
      xc(ie,1,2)  = xc(il,1,2)   +xc(ie,2,2)   -xc(il,2,2)
      xc(1,je,1)  = xc(2,je,1)   +xc(1,jl,1)   -xc(2,jl,1)
      xc(1,je,2)  = xc(2,je,2)   +xc(1,jl,2)   -xc(2,jl,2)
      xc(ie,je,1) = xc(il,je,1)  +xc(ie,jl,1)  -xc(il,jl,1)
      xc(ie,je,2) = xc(il,je,2)  +xc(ie,jl,2)  -xc(il,jl,2)

      return

      end


data Nat = Zero
         | S Nat

convert :: Nat -> (R . (R -> R) -> (Unit -> R) -> R)
convert = [<Zero, forall R.lam c1:(R -> R).lam c0:(Unit -> R).(c0 unit)>,
           <S Zero, forall R.lam c1:(R -> R).lam c0:(Unit -> R).c1 (c0 unit)>,
           <S (S Zero), forall R.lam c1:(R -> R).lam c0:(Unit -> R).c1 (c1 (c0 unit))>]

main :: Unit
main = convert (S (S (S Zero)))


!*******************************************************************
!                                                                  *
      SUBROUTINE SIXJ4(JC,JE,JD,JB,JF,ITIK,SI)
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF 6j COEFFICIENT         *
!                                                                  *
!     | JC/2  JE/2  JD/2 |                                         *
!     | JB/2  JF/2    4  |                                         *
!                                                                  *
!                                                                  *
!   Written by G. Gaigalas,                                        *
!   Vanderbilt University,  Nashville               October  1996  *
!   Transform to fortran 90/95 by G. Gaigalas       December 2012  *
!   The last modification made by G. Gaigalas       October  2017  *
!                                                                  *
!*******************************************************************
!
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE CONS_C,          ONLY: ZERO, HALF, ONE, TWO, THREE, EPS
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ixjtik_I
      USE dracah_I
      USE sixj2_I
      USE sixj3_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER             :: JC, JE, JD, JB, JF
      INTEGER, INTENT(IN) :: ITIK
      REAL(DOUBLE)        :: SI
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      REAL(DOUBLE) :: A, C, E, D, B, F, X1, X2, X3, S2, S3
!-----------------------------------------------
      SI = ZERO
      IF (ITIK /= 0) THEN
!
!     CHESKED TRIANGULAR CONDITIONS
!
         IF (IXJTIK(JC,JE,JD,JB,JF,8) == 0) RETURN
      ENDIF
      IF (IXJTIK(JC,JE,JD,JB,JF,6) == 0) THEN
         CALL DRACAH (JC, JE, JF, JB, JD, 8, SI)
         IF (MOD(JC + JE + JF + JB,4) /= 0) SI = -SI
      ELSE
         A = THREE
         C = DBLE(JC)*HALF
         E = DBLE(JE)*HALF
         D = DBLE(JD)*HALF
         B = DBLE(JB)*HALF
         F = DBLE(JF)*HALF
         X1 = A*DSQRT((A+B+E+TWO)*(A-B+E+ONE)*(A+B-E+ONE)*((-         &
            A)+B+E)*(A+C+F+TWO)*(A-C+F+ONE)*(A+C-F+ONE)*(             &
            (-A)+C+F))
         X2 = (A+ONE)*DSQRT((A+B+E+ONE)*(A-B+E)*(A+B-E)*((-A)         &
             + B+E+ONE)*(A+C+F+ONE)*(A-C+F)*(A+C-F)*((-A)+C           &
             + F+ONE))
         X3 = (TWO*A+ONE)*(TWO*(A*(A+ONE)*D*(D+ONE)-B*(B+ONE)*C*(C+   &
            ONE)-E*(E+ONE)*F*(F+ONE))+(A*(A+ONE)-B*(B+ONE)-E*(E       &
             +ONE))*(A*(A+ONE)-C*(C+ONE)-F*(F+ONE)))
         IF (DABS(X2) < EPS) THEN
            S2 = ZERO
         ELSE
            CALL SIXJ2 (JC, JE, JD, JB, JF, 0, S2)
         ENDIF
         IF (DABS(X3) < EPS) THEN
            S3 = ZERO
         ELSE
            CALL SIXJ3 (JC, JE, JD, JB, JF, 0, S3)
         ENDIF
         SI = (X3*S3 - X2*S2)/X1
      ENDIF
      RETURN
      END SUBROUTINE SIXJ4


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC for the calculation of alphas
       DOUBLE PRECISION FUNCTION ALPHAS(Q,N)
C--ALPHA_S: Q = SCALE, N = 1 -> LO, N = 2 -> NLO
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION XLB(6)
      COMMON/ALSLAM/XLB1(6),XLB2(6)
      COMMON/ALS/XLAMBDA,AMC,AMB,AMT,N0
      B0(NF)=33.D0-2.D0*NF
      B1(NF)=6.D0*(153.D0-19.D0*NF)/B0(NF)**2
      ALS1(NF,X)=12.D0*PI/(B0(NF)*DLOG(X**2/XLB(NF)**2))
      ALS2(NF,X)=12.D0*PI/(B0(NF)*DLOG(X**2/XLB(NF)**2))
     .          *(1.D0-B1(NF)*DLOG(DLOG(X**2/XLB(NF)**2))
     .           /DLOG(X**2/XLB(NF)**2))
      PI=4.D0*DATAN(1.D0)
      IF(N.EQ.1)THEN
       DO 1 I=1,6
        XLB(I)=XLB1(I)
1      CONTINUE
      ELSE
       DO 2 I=1,6
        XLB(I)=XLB2(I)
2      CONTINUE
      ENDIF

      IF(Q.LT.AMC)THEN
       NF=3
      ELSEIF(Q.LE.AMB)THEN
       NF=4
      ELSEIF(Q.LE.AMT)THEN
       NF=5
      ELSE
       NF=6
      ENDIF
      IF(N.EQ.1)THEN
        ALPHAS=ALS1(NF,Q)
      ELSE
        ALPHAS=ALS2(NF,Q)
      ENDIF
      RETURN
      END

      SUBROUTINE ALSINI(ACC)
C--ALPHA_S: INITIALIZATION OF LAMBDA_NF, ACC = ACCURAY AT THRESHOLDS
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION XLB(6)
      COMMON/ALSLAM/XLB1(6),XLB2(6)
      COMMON/ALS/XLAMBDA,AMC,AMB,AMT,N0
      B0(NF)=33.D0-2.D0*NF
      B1(NF)=6.D0*(153.D0-19.D0*NF)/B0(NF)**2
      ALS2(NF,X)=12.D0*PI/(B0(NF)*DLOG(X**2/XLB(NF)**2))
     .          *(1.D0-B1(NF)*DLOG(DLOG(X**2/XLB(NF)**2))
     .           /DLOG(X**2/XLB(NF)**2))
      PI=4.D0*DATAN(1.D0)
      XLB1(1)=0D0
      XLB1(2)=0D0
      XLB2(1)=0D0
      XLB2(2)=0D0
      IF(N0.EQ.4)THEN
       XLB(4)=XLAMBDA
       XLB(5)=XLB(4)*(XLB(4)/AMB)**(2.D0/23.D0)
      ELSEIF(N0.EQ.5)THEN
       XLB(5)=XLAMBDA
       XLB(4)=XLB(5)*(XLB(5)/AMB)**(-2.D0/25.D0)

      ENDIF
      XLB(3)=XLB(4)*(XLB(4)/AMC)**(-2.D0/27.D0)
      XLB(6)=XLB(5)*(XLB(5)/AMT)**(2.D0/21.D0)
      DO 1 I=1,6
       XLB1(I)=XLB(I)
1     CONTINUE
      IF(N0.EQ.4)THEN
       XLB(4)=XLAMBDA
       XLB(5)=XLB(4)*(XLB(4)/AMB)**(2.D0/23.D0)
     .             *(2.D0*DLOG(AMB/XLB(4)))**(-963.D0/13225.D0)
       XLB(5)=XITER(AMB,XLB(4),4,XLB(5),5,ACC)
      ELSEIF(N0.EQ.5)THEN
       XLB(5)=XLAMBDA
       XLB(4)=XLB(5)*(XLB(5)/AMB)**(-2.D0/25.D0)
     .             *(2.D0*DLOG(AMB/XLB(5)))**(963.D0/14375.D0)
       XLB(4)=XITER(AMB,XLB(5),5,XLB(4),4,ACC)
      ENDIF
      XLB(3)=XLB(4)*(XLB(4)/AMC)**(-2.D0/27.D0)
     .            *(2.D0*DLOG(AMC/XLB(4)))**(107.D0/2025.D0)
      XLB(3)=XITER(AMC,XLB(4),4,XLB(3),3,ACC)
      XLB(6)=XLB(5)*(XLB(5)/AMT)**(2.D0/21.D0)
     .           *(2.D0*DLOG(AMT/XLB(5)))**(-321.D0/3381.D0)
      XLB(6)=XITER(AMT,XLB(5),5,XLB(6),6,ACC)
       DO 2 I=1,6
       XLB2(I)=XLB(I)
2     CONTINUE

      RETURN
      END

      DOUBLE PRECISION FUNCTION XITER(Q,XLB1,NF1,XLB,NF2,ACC)
C--ALPHA_S: ITERATION FOR ALPHA_S(M_Z) -> LAMBDA_5
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      B0(NF)=33.D0-2.D0*NF
      B1(NF)=6.D0*(153.D0-19.D0*NF)/B0(NF)**2
      ALS2(NF,X,XLB)=12.D0*PI/(B0(NF)*DLOG(X**2/XLB**2))
     .              *(1.D0-B1(NF)*DLOG(DLOG(X**2/XLB**2))
     .              /DLOG(X**2/XLB**2))
      AA(NF)=12D0*PI/B0(NF)
      BB(NF)=B1(NF)/AA(NF)
      XIT(A,B,X)=A/2.D0*(1D0+DSQRT(1D0-4D0*B*DLOG(X)))
      PI=4.D0*DATAN(1.D0)
      XLB2=XLB
      IF(ACC.GE.1.D0) GOTO 111
      II=0
1     II=II+1
      X=DLOG(Q**2/XLB2**2)
      ALP=ALS2(NF1,Q,XLB1)
      A=AA(NF2)/ALP
      B=BB(NF2)*ALP
      XX=XIT(A,B,X)
      XLB2=Q*DEXP(-XX/2.D0)
      Y1=ALS2(NF1,Q,XLB1)
      Y2=ALS2(NF2,Q,XLB2)
      DY=DABS(Y2-Y1)/Y1
      IF(DY.GE.ACC) GOTO 1
111   XITER=XLB2

      RETURN
      END


!
! Not finished...
!
! This program calculates the rate C_{eI} in three ways:
!  1. A-coeff folded into distribution function
!  2. Sum rule or Born approximation
!  3. Arbitrary mass ratio
!
      PROGRAM main
      USE allocatablevars
      USE bpsvars
      USE physvars
      USE mathvars
        IMPLICIT NONE
        REAL     :: te, ti, ne
        INTEGER  :: nni

        REAL     :: ln_bps_mass, cei_mass, cei_reg_mass
        REAL     :: cei_sing_mass, cei_qm_mass, delta_mass

        REAL     :: cei_born, ln_bps_born, ln_bps, delta

        REAL     :: cei_dist_ei, cei_sing_dist_ei, cei_reg_dist_ei, cei_qm_dist_ei
        REAL     :: cei_dist_ei1, cei_dist_ei2, cei_dist_ei3, cei_dist_ei4

        REAL     :: cei_tot, cei_i, cei_e, ceic_tot, ceic_i, ceic_e, ceiq_tot
        REAL     :: ceiq_i, ceiq_e, ceic_s_i, ceic_s_e, ceic_r_i , ceic_r_e

        REAL     :: x0, x1, x2, x3, x4, dx, x
        INTEGER  :: nmax, ix, ib

        REAL     :: ze, yei, norme, me, betae, em
        REAL     :: a_tot, a_i, a_e, ac_tot, ac_i, ac_e, aq_tot, aq_i, aq_e
        REAL     :: ac_s_i, ac_s_e, ac_r_i, ac_r_e

        REAL,    DIMENSION(:), ALLOCATABLE :: ceib
!*!
!       REAL     ::  a_tot_lim, a_i_lim, a_e_lim, ac_tot_lim, ac_i_lim, ac_e_lim
!       REAL     ::  aq_tot_lim, aq_i_lim, aq_e_lim, ep
!*!
!
! create test plasma
!
        CALL define_plasma(te,ti,ne,nni)     ! eH
!       CALL define_plasma_He(te,ti,ne,nni)  ! He
        ALLOCATE(ceib(1:nni+1))

        CALL write_output(te, ti, ne, nni, betab, zb, mb, nb,        &
          ln_bps_mass, ln_bps_born, delta_mass, cei_sing_mass,       &
          cei_reg_mass, cei_qm_mass, cei_mass, cei_born, cei_dist_ei)

!
! rate C_{eI} using sum-rule and general expression
!
        CALL bps_rate_cei_born(nni,betab,zb,mb,nb,ln_bps_born,cei_born)   ! born
        CALL bps_rate_cei_mass(nni, betab, zb, mb, nb, ln_bps,      &
          delta, cei_tot, cei_i, cei_e, ceic_tot, ceic_i, ceic_e, ceiq_tot, &
          ceiq_i, ceiq_e, ceic_s_i, ceic_s_e, ceic_r_i , ceic_r_e, ceib)
!
! rate C_{eI} using distribution and A-coefficient integral.
!

        ib=1
        ze=zb(ib)
        me=mb(ib)
        ne=nb(ib)
        betae=betab(ib)
        norme=2*ne*CC*SQRT(betae/me)

!       x0=0
!       x1=30.
!       x1=0.01
!       nmax=1000
!       cei_dist_ei1=0
!       CALL bps_rate_dist(nni, betab, zb, mb, nb, cei_dist_ei, cei_sing_dist_ei,        &
!         cei_reg_dist_ei, cei_qm_dist_ei, x0, x1, nmax)
!       PRINT *, cei_born, cei_born/norme
!       PRINT *, cei_mass, cei_mass/norme
!       PRINT *, cei_dist_ei, cei_dist_ei/norme, (cei_dist_ei-cei_mass)/cei_mass
!       PRINT *, ""
!STOP

        x0=0
        x1=0.2
        x2=1.
        x3=3
        x4=30.
        nmax=1000
        cei_dist_ei1=0
        CALL bps_rate_dist(nni, betab, zb, mb, nb, cei_dist_ei1, cei_sing_dist_ei,        &
          cei_reg_dist_ei, cei_qm_dist_ei, x0, x1, nmax)
        cei_dist_ei2=0
        CALL bps_rate_dist(nni, betab, zb, mb, nb, cei_dist_ei1, cei_sing_dist_ei,        &
          cei_reg_dist_ei, cei_qm_dist_ei, x1, x2, nmax)
        cei_dist_ei3=0
        CALL bps_rate_dist(nni, betab, zb, mb, nb, cei_dist_ei3, cei_sing_dist_ei,        &
          cei_reg_dist_ei, cei_qm_dist_ei, x2, x3, nmax)
        cei_dist_ei4=0
        CALL bps_rate_dist(nni, betab, zb, mb, nb, cei_dist_ei4, cei_sing_dist_ei,        &
          cei_reg_dist_ei, cei_qm_dist_ei, x3, x4, nmax)
        cei_dist_ei=cei_dist_ei1 + cei_dist_ei2 + cei_dist_ei3 + cei_dist_ei4
       PRINT *, cei_born, cei_born/norme
       PRINT *, cei_mass, cei_mass/norme
       PRINT *, cei_dist_ei, cei_dist_ei/norme, (cei_dist_ei-cei_mass)/cei_mass
       PRINT *, ""
!STOP

!STOP

        ib=1
        ze=zb(ib)
        me=mb(ib)
        ne=nb(ib)
        betae=betab(ib)
        norme=2*ne*CC*SQRT(betae/me)

        x0=1.E-10
        x1=0.001
        nmax=500
        dx=(x1-x0)/nmax
        DO ix=0,nmax
           x=x0 + dx*ix
           em=x/betae
           CALL bps_acoeff_ei_mass(nni,em,ze,me,betab,zb,mb,nb,   &
              a_tot,a_i,a_e,ac_tot,ac_i,ac_e,aq_tot,aq_i,aq_e,&
              ac_s_i, ac_s_e, ac_r_i, ac_r_e)
           yei=x*EXP(-x)*a_i*SQRT(2./PI)*1.E7
           WRITE(6,*) ix, x, yei, yei*norme
           WRITE(1,*) ix, x, yei, yei*norme
        ENDDO

        x0=x1 + 0.00001
        x1=1.0
        nmax=2000
        dx=(x1-x0)/nmax
        DO ix=0,nmax
           x=x0 + dx*ix
           em=x/betae
           CALL bps_acoeff_ei_mass(nni,em,ze,me,betab,zb,mb,nb,   &
              a_tot,a_i,a_e,ac_tot,ac_i,ac_e,aq_tot,aq_i,aq_e,&
              ac_s_i, ac_s_e, ac_r_i, ac_r_e)
           yei=x*EXP(-x)*a_i*SQRT(2./PI)*1.E7
           WRITE(6,*) ix+nmax, x, yei, yei*norme
           WRITE(1,*) ix+nmax, x, yei, yei*norme
        ENDDO

        x0=x1 + 0.00001
        x1=30
        nmax=500
        dx=(x1-x0)/nmax
        DO ix=0,nmax
           x=x0 + dx*ix
           em=x/betae
           CALL bps_acoeff_ei_mass(nni,em,ze,me,betab,zb,mb,nb,   &
              a_tot,a_i,a_e,ac_tot,ac_i,ac_e,aq_tot,aq_i,aq_e,&
              ac_s_i, ac_s_e, ac_r_i, ac_r_e)
           yei=x*EXP(-x)*a_i*SQRT(2./PI)*1.E7
           WRITE(6,*) ix+2*nmax, x, yei, yei*norme
           WRITE(1,*) ix+2*nmax, x, yei, yei*norme
        ENDDO
!
! write output header again
!
        CALL write_output(te, ti, ne, nni, betab, zb, mb, nb,        &
          ln_bps_mass, ln_bps_born, delta_mass, cei_sing_mass,       &
          cei_reg_mass, cei_qm_mass, cei_mass, cei_born, cei_dist_ei)

! PRINT *, cei_mass/norme

        CALL close_output
        CALL close_plasma
      END PROGRAM main
!
!======================================================

!
! Returns the plasma species arrays: betab, mb, nb, zb
! Allocates other plasma arrays
!
      SUBROUTINE define_plasma(te, ti, ne, nni)
      USE allocatablevars
      USE physvars
      USE controlvars
        IMPLICIT NONE
        REAL                                :: te     ! [keV]
        REAL                                :: ti     ! [keV]
        REAL                                :: ne     ! [cm^-3]
        INTEGER                             :: nni    ! number of ion species
!
!       REAL,    DIMENSION(:), ALLOCATABLE  :: betab  ! [1/keV]
!       REAL,    DIMENSION(:), ALLOCATABLE  :: mb     ! [keV]
!       REAL,    DIMENSION(:), ALLOCATABLE  :: nb     ! [cm^-3]
!       REAL,    DIMENSION(:), ALLOCATABLE  :: zb     ! [e]
!       REAL,    DIMENSION(:), ALLOCATABLE  :: gb, etab, mpb, mbpb

!
! open output files
!

        te=100.   ! keV
        ti=100.   ! keV
        ne=1.E25 ! cm^-3

        OPEN(UNIT=1, FILE="main.symmetry.heavyMe.010kev.dat") !
        OPEN(UNIT=1, FILE="main.symmetry.heavyMe.100kev.dat") !

!       OPEN(UNIT=1, FILE="main.symmetry.100kev.dat") !

        asymptotic_forms=.FALSE.
        asymptotic_forms=.TRUE.
        IF (asymptotic_forms) THEN
           small_E_form=.TRUE.
           large_E_form=.TRUE.
        ELSE
           small_E_form=.FALSE.
           large_E_form=.FALSE.
        ENDIF

        nni=1  ! number of ion species
        ALLOCATE(betab(1:nni+1),zb(1:nni+1),mb(nni+1),nb(1:nni+1))   ! allocatablevars
        ALLOCATE(gb(1:nni+1),etab(1:nni+1),mpb(nni+1),mbpb(1:nni+1)) ! allocatablevars

        zb(1)=-1.    ! Species charges
        zb(2)=+1.    !
        mb(1)=MEKEV  ! Species masses [keV]
        mb(2)=MPKEV  !
!
! Construct density and temperature arrays
!
        nb(1)=1.                          ! ONLY FOR EQUIMOLAR
        nb(2:nni+1)=1./(zb(2:nni+1)*nni)  ! charge neutrality
        nb=nb*ne                          ! number density array [cm^-3]
        betab(1)=1./te                    ! inverse temp array   [keV^-1]
        betab(2:nni+1)=1./ti              !
      END SUBROUTINE define_plasma

      SUBROUTINE define_plasma_He(te, ti, ne, nni)
      USE allocatablevars
      USE physvars
      USE controlvars
        IMPLICIT NONE
        REAL                                :: te     ! [keV]
        REAL                                :: ti     ! [keV]
        REAL                                :: ne     ! [cm^-3]
        INTEGER                             :: nni    ! number of ion species
!
!       REAL,    DIMENSION(:), ALLOCATABLE  :: betab  ! [1/keV]
!       REAL,    DIMENSION(:), ALLOCATABLE  :: mb     ! [keV]
!       REAL,    DIMENSION(:), ALLOCATABLE  :: nb     ! [cm^-3]
!       REAL,    DIMENSION(:), ALLOCATABLE  :: zb     ! [e]
!       REAL,    DIMENSION(:), ALLOCATABLE  :: gb, etab, mpb, mbpb

!
! open output files
!

        te=100.   ! keV
        ti=100.   ! keV
        ne=1.E25 ! cm^-3

        OPEN(UNIT=1, FILE="main.symmetry.heavyMe.010kev.dat") !
        OPEN(UNIT=1, FILE="main.symmetry.heavyMe.100kev.dat") !

!       OPEN(UNIT=1, FILE="main.symmetry.100kev.dat") !

        asymptotic_forms=.FALSE.
        asymptotic_forms=.TRUE.
        IF (asymptotic_forms) THEN
           small_E_form=.TRUE.
           large_E_form=.TRUE.
        ELSE
           small_E_form=.FALSE.
           large_E_form=.FALSE.
        ENDIF

        nni=1  ! number of ion species
        ALLOCATE(betab(1:nni+1),zb(1:nni+1),mb(nni+1),nb(1:nni+1))   ! allocatablevars
        ALLOCATE(gb(1:nni+1),etab(1:nni+1),mpb(nni+1),mbpb(1:nni+1)) ! allocatablevars

        zb(2)=1.    ! Species charges
        zb(1)=1.    !
        mb(2)=MEKEV  ! Species masses [keV]
        mb(1)=MPKEV  !
!
! Construct density and temperature arrays
!
        nb(1)=1.                          ! ONLY FOR EQUIMOLAR
        nb(2:nni+1)=1./(zb(2:nni+1)*nni)  ! charge neutrality
        nb=nb*ne                          ! number density array [cm^-3]
        betab(1)=1./te                    ! inverse temp array   [keV^-1]
        betab(2:nni+1)=1./ti              !
      END SUBROUTINE define_plasma_He

      SUBROUTINE close_plasma
      USE allocatablevars
        DEALLOCATE(betab,zb,mb,nb)   ! allocatablevars
        DEALLOCATE(gb,etab,mpb)      ! allocatablevars
      END SUBROUTINE close_plasma

      SUBROUTINE write_output(te, ti, ne, nni, betab, zb, mb, nb,   &
      ln_bps_mass, ln_bps_born, delta_mass, cei_sing_mass,        &
      cei_reg_mass, cei_qm_mass, cei_mass, cei_born, cei_dist_ei)
      USE physvars
        IMPLICIT NONE
        REAL,                        INTENT(IN) :: te          ! [keV]
        REAL,                        INTENT(IN) :: ti          ! [keV]
        REAL,                        INTENT(IN) :: ne          ! [cm^-3]
        INTEGER,                     INTENT(IN) :: nni         ! number of ion species
        REAL,    DIMENSION(1:nni+1), INTENT(IN) :: betab       ! [1/keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN) :: zb          ! [e]
        REAL,    DIMENSION(1:nni+1), INTENT(IN) :: mb          ! [keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN) :: nb          ! [cm^-3]
        REAL,                        INTENT(IN) :: ln_bps_mass !
        REAL,                        INTENT(IN) :: ln_bps_born !
        REAL,                        INTENT(IN) :: delta_mass  !
        REAL,                        INTENT(IN) :: cei_sing_mass !
        REAL,                        INTENT(IN) :: cei_reg_mass  !
        REAL,                        INTENT(IN) :: cei_qm_mass   !
        REAL,                        INTENT(IN) :: cei_mass      !
        REAL,                        INTENT(IN) :: cei_born      !
        REAL,                        INTENT(IN) :: cei_dist_ei   !
        REAL  :: etae, ge, gi, ze
        REAL,    DIMENSION(1:nni+1) :: gb
        REAL     :: c_ei_born
        REAL     :: c_ei_tot, c_ei_i,c_ei_e, c_eic_tot, c_eic_i, c_eic_e
        REAL     :: c_eiq_tot, c_eiq_i, c_eiq_e, c_eic_s_i, c_eic_s_e
        REAL     :: c_eic_r_i ,c_eic_r_e
        REAL,    DIMENSION(1:nni+1)  :: c_eib
        REAL,    DIMENSION(1:nni+1,1:nni+1)  :: c_ab, c_ab_sing, c_ab_reg, c_ab_qm

!
! write header
!
        WRITE(6,'(A)') '#'
        WRITE(6,'(A)') '#'
        WRITE(6,'(A, 3X,A17)') '#','Plasma Parameters'
        WRITE(6,'(A, 4X,A28, X,D12.4, X,D12.4)')  '#','electron and ion temp [keV]:', te, ti
        WRITE(6,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','number density nb   [cm^-3]:', nb
        WRITE(6,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [amu]:', mb/AMUKEV
        WRITE(6,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [keV]:', mb
        WRITE(6,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','charge array zb            :', zb
        WRITE(1,'(A)') '#'
        WRITE(1,'(A)') '#'
        WRITE(1,'(A, 3X,A17)') '#','Plasma Parameters'
        WRITE(1,'(A, 4X,A28, X,D12.4, X,D12.4)')  '#','electron and ion temp [keV]:', te, ti
        WRITE(1,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','number density nb   [cm^-3]:', nb
        WRITE(1,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [amu]:', mb/AMUKEV
        WRITE(1,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [keV]:', mb
        WRITE(1,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','charge array zb            :', zb
!
! Print plasma parameters
!
        CALL param(nni, betab, nb, gb, ge, gi, etae, ze)
        WRITE(6,'(A1, 2X,A9, 4X,A7, 4X,A7, 8X,A2, 7X,A2, 10X,A4, 9X,A9)') &
          '#','ne[cm^-3]','Te[keV]', 'Ti[keV]','ge','gi','etae','ze/2**1.5'
        WRITE(6,'(A1,11D12.4)') '#',ne, te, ti, ge, gi, etae, ze/2**1.5
        WRITE(1,'(A1, 2X,A9, 4X,A7, 4X,A7, 8X,A2, 7X,A2, 10X,A4, 9X,A9)') &
          '#','ne[cm^-3]','Te[keV]', 'Ti[keV]','ge','gi','etae','ze/2**1.5'
        WRITE(1,'(A1,11D12.4)') '#',ne, te, ti, ge, gi, etae, ze/2**1.5
!
! Print rates
!
        CALL bps_rate_cei_born(nni,betab,zb,mb,nb,ln_bps_born,c_ei_born)
        CALL bps_rate_cei_mass(nni, betab, zb, mb, nb, ln_bps_mass,   &
          delta_mass, c_ei_tot, c_ei_i,c_ei_e,c_eic_tot,c_eic_i,c_eic_e,    &
          c_eiq_tot,c_eiq_i,c_eiq_e, c_eic_s_i,c_eic_s_e,c_eic_r_i ,c_eic_r_e, c_eib)
        CALL bps_rate_cab_matrix(nni, betab, zb, mb, nb, &
            c_ab, c_ab_sing, c_ab_reg, c_ab_qm)

        WRITE(6,*) "-----------------------------------"
        WRITE(6,'(A14,E13.5,2X,A10)') "cei_born     :",c_ei_born, "[1/cm^3 s]"
        WRITE(6,'(A14,E13.5,2X,A10)') "cei_mass     :",c_ei_i,    "[1/cm^3 s]"
        WRITE(6,'(A14,E13.5,2X,A10)') "cab_mass_sum :",SUM(c_ab(1,2:nni+1)), "[1/cm^3 s]"
        WRITE(6,'(A14,E13.5)')        "% diff       :",100*ABS((c_ei_i-c_ei_born)/c_ei_i)
        WRITE(6,*) ""
        WRITE(6,'(A14,E13.5)')        "ln_bps_born  :",ln_bps_born
        WRITE(6,'(A14,E13.5)')        "ln_bps_mass  :",ln_bps_mass
        WRITE(6,'(A14,E13.5)')        "% diff       :",100*ABS((ln_bps_mass-ln_bps_born)/ln_bps_mass)
        WRITE(6,*) ""
        WRITE(6,'(A14,E13.5,2X,A10)') "cei_reg_mass :",c_eic_r_i,   "[1/cm^3 s]"
        WRITE(6,'(A14,E13.5,2X,A10)') "cei_sing_mass:",c_eic_s_i,   "[1/cm^3 s]"
        WRITE(6,'(A14,E13.5,2X,A10)') "cei_qm_mass  :",c_eiq_i,     "[1/cm^3 s]"
        WRITE(6,'(A14,E13.5,2X,A10)') "delta_mass   :",delta_mass
        WRITE(6,*) "-----------------------------------"
        WRITE(6,'(A14,E13.5,2X,A10)') "cab_reg_mass :",SUM(c_ab_reg(1,2:nni+1)),   "[1/cm^3 s]"
        WRITE(6,'(A14,E13.5,2X,A10)') "cab_sing_mass:",SUM(c_ab_sing(1,2:nni+1)),  "[1/cm^3 s]"
        WRITE(6,'(A14,E13.5,2X,A10)') "cab_qm_mass  :",SUM(c_ab_qm(1,2:nni+1)),    "[1/cm^3 s]"
        WRITE(6,*) "-----------------------------------"

        WRITE(1,*) "-----------------------------------"
        WRITE(1,'(A14,E13.5,2X,A10)') "cei_born     :",c_ei_born, "[1/cm^3 s]"
        WRITE(1,'(A14,E13.5,2X,A10)') "cei_mass     :",c_ei_i,    "[1/cm^3 s]"
        WRITE(1,'(A14,E13.5,2X,A10)') "cab_mass_sum :",SUM(c_ab(1,2:nni+1)), "[1/cm^3 s]"
        WRITE(1,'(A14,E13.5)')        "% diff       :",100*ABS((c_ei_i-c_ei_born)/c_ei_i)
        WRITE(1,*) ""
        WRITE(1,'(A14,E13.5)')        "ln_bps_born  :",ln_bps_born
        WRITE(1,'(A14,E13.5)')        "ln_bps_mass  :",ln_bps_mass
        WRITE(1,'(A14,E13.5)')        "% diff       :",100*ABS((ln_bps_mass-ln_bps_born)/ln_bps_mass)
        WRITE(1,*) ""
        WRITE(1,'(A14,E13.5,2X,A10)') "cei_reg_mass :",c_eic_r_i,   "[1/cm^3 s]"
        WRITE(1,'(A14,E13.5,2X,A10)') "cei_sing_mass:",c_eic_s_i,   "[1/cm^3 s]"
        WRITE(1,'(A14,E13.5,2X,A10)') "cei_qm_mass  :",c_eiq_i,     "[1/cm^3 s]"
        WRITE(1,'(A14,E13.5,2X,A10)') "delta_mass   :",delta_mass
        WRITE(1,*) "-----------------------------------"
        WRITE(1,'(A14,E13.5,2X,A10)') "cab_reg_mass :",SUM(c_ab_reg(1,2:nni+1)),   "[1/cm^3 s]"
        WRITE(1,'(A14,E13.5,2X,A10)') "cab_sing_mass:",SUM(c_ab_sing(1,2:nni+1)),  "[1/cm^3 s]"
        WRITE(1,'(A14,E13.5,2X,A10)') "cab_qm_mass  :",SUM(c_ab_qm(1,2:nni+1)),    "[1/cm^3 s]"
        WRITE(1,*) "-----------------------------------"

!
! quantities plotted
!
        WRITE(1,'(A77)') "# ix  x  x*EXP(-x)*a_i*SQRT(2./PI)*1.E7  x*EXP(-x)*a_i*norme*SQRT(2./PI)*1.E7"

!       WRITE(6,'(A5, 2X,A7, 5X,A5, 7X,A3, 9X,A3, 9X,A6, 6X,A4, 8X,A4, 8X,A6, 6X,A4, 8X,A4)') &
!         "#  iu", "ep[keV]", "a_tot", "a_i", "a_e", "ac_tot", "ac_i_lim", "ac_e", &
!         "aq_tot", "aq_i", "aq_e"
!       WRITE(1,'(A)') "#"
!       WRITE(1,'(A5, 2X,A7, 5X,A5, 7X,A3, 9X,A3, 9X,A6, 6X,A4, 8X,A4, 8X,A6, 6X,A4, 8X,A4)') &
!         "#  iu", "ep[keV]", "a_tot", "a_i", "a_e", "ac_tot", "ac_i", "ac_e", "aq_tot", "aq_i","aq_e"
      END SUBROUTINE write_output
!
      SUBROUTINE close_output
      IMPLICIT NONE
        CLOSE(1)
      END SUBROUTINE close_output

!
! This routine integrates the A-coefficient weighted by the velocity times
! the distribution function to find the C-coefficient. This method does not
! look symmetric in C_{ab} for a <--> b, although it *must* be symmetric.
!
      SUBROUTINE bps_rate_dist(nni, betab, zb, mb, nb, cei_dist_ei,     &
        cei_sing_dist_ei, cei_reg_dist_ei, cei_qm_dist_ei, xmin, xmax, nmax)
      USE bpsvars
      USE mathvars
      USE physvars
        IMPLICIT NONE
        INTEGER,                     INTENT(IN)  :: nni             !  Number of ions
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: betab           !  Temperature array    [1/keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: zb              !  Charge array
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: mb              !  Mass array [keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: nb              !  Number density array [cm^-3]
        REAL,                        INTENT(OUT) :: cei_dist_ei     !  Equilibration rate [cm^-3 s^-1]
        REAL,                        INTENT(OUT) :: cei_sing_dist_ei!  Normalized singular
        REAL,                        INTENT(OUT) :: cei_reg_dist_ei !  Normalized regular [cm^-3 s^-1]
        REAL,                        INTENT(OUT) :: cei_qm_dist_ei  !  Normalized quantum
        REAL,                        INTENT(IN)  :: xmin, xmax      !  Integration limits
        INTEGER,                     INTENT(IN)  :: nmax            !  Number of integration regions [even]

        REAL,    PARAMETER :: UPM=0.7745966692E0
        REAL,    PARAMETER :: W13=0.5555555556E0, W2=0.8888888889E0
        REAL               :: a_tot, a_i, a_e, ac_tot, ac_i, ac_e, aq_tot, aq_i, aq_e
        REAL               :: ac_s_i, ac_s_e, ac_r_i, ac_r_e
        REAL               :: x, dx, xm, e, em
        INTEGER            :: ix
        REAL               :: ze, ne, me, betae, norme, yei
        INTEGER            :: ib

        cei_dist_ei     =0.
        cei_sing_dist_ei=0.
        cei_reg_dist_ei =0.
        cei_qm_dist_ei  =0.

        ib=1
        ze=zb(ib)
        me=mb(ib)
        ne=nb(ib)
        betae=betab(ib)
        norme=2*ne*CC*SQRT(betae/me)

        dx=(xmax-xmin)/NMAX
        x=xmin-dx
        DO ix=1,NMAX,2 ! Gaussian quadrature
           x=x+2.*dx
           e=x/betae
           CALL bps_acoeff_ei_mass(nni,e,ze,me,betab,zb,mb,nb,     &
              a_tot,a_i,a_e,ac_tot,ac_i,ac_e,aq_tot,aq_i,aq_e, &
              ac_s_i, ac_s_e, ac_r_i, ac_r_e) ! MeV/micron = 10^7 kev/cm
           yei=x*EXP(-x)*a_i
           cei_dist_ei=cei_dist_ei+W2*yei
!
           xm=x-dx*UPM
           em=xm/betae
           CALL bps_acoeff_ei_mass(nni,em,ze,me,betab,zb,mb,nb,    &
              a_tot,a_i,a_e,ac_tot,ac_i,ac_e,aq_tot,aq_i,aq_e, &
              ac_s_i, ac_s_e, ac_r_i, ac_r_e)
           yei=xm*EXP(-xm)*a_i
           cei_dist_ei=cei_dist_ei+W13*yei
!
           xm=x+dx*UPM
           em=xm/betae
           CALL bps_acoeff_ei_mass(nni,em,ze,me,betab,zb,mb,nb,    &
              a_tot,a_i,a_e,ac_tot,ac_i,ac_e,aq_tot,aq_i,aq_e, &
              ac_s_i, ac_s_e, ac_r_i, ac_r_e)
           yei=xm*EXP(-x)*a_i
           cei_dist_ei=cei_dist_ei+W13*yei
        ENDDO
        cei_dist_ei=cei_dist_ei*1.E7 ! convert A from MeV/micron to keV/cm.
        cei_dist_ei=cei_dist_ei*dx*SQRT(2./PI)
        cei_dist_ei=cei_dist_ei*norme
      END SUBROUTINE bps_rate_dist


c       this file contains the following user-callable routines:
c
c
c       routine iddr_aid computes the SVD, to a specified rank,
c       of an arbitrary matrix. This routine is randomized.
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
        subroutine iddr_asvd(m,n,a,krank,w,u,v,s,ier)
c
c       constructs a rank-krank SVD  u diag(s) v^T  approximating a,
c       where u is an m x krank matrix whose columns are orthonormal,
c       v is an n x krank matrix whose columns are orthonormal,
c       and diag(s) is a diagonal krank x krank matrix whose entries
c       are all nonnegative. This routine uses a randomized algorithm.
c
c       input:
c       m -- number of rows in a
c       n -- number of columns in a
c       a -- matrix to be decomposed; the present routine does not
c            alter a
c       krank -- rank of the SVD being constructed
c       w -- initialization array that routine iddr_aidi
c            has constructed (for use in the present routine, w must
c            be at least (2*krank+28)*m+(6*krank+21)*n+25*krank**2+100
c            real*8 elements long)
c
c       output:
c       u -- matrix of orthonormal left singular vectors of a
c       v -- matrix of orthonormal right singular vectors of a
c       s -- array of singular values of a
c       ier -- 0 when the routine terminates successfully;
c              nonzero otherwise
c
c       _N.B._: The algorithm used by this routine is randomized.
c
        implicit none
        integer m,n,krank,lw,ilist,llist,iproj,lproj,icol,lcol,
     1          iwork,lwork,iwinit,lwinit,ier
        real*8 a(m,n),u(m,krank),v(n,krank),s(krank),
     1         w((2*krank+28)*m+(6*krank+21)*n+25*krank**2+100)
c
c
c       Allocate memory in w.
c
        lw = 0
c
        iwinit = lw+1
        lwinit = (2*krank+17)*n+27*m+100
        lw = lw+lwinit
c
        ilist = lw+1
        llist = n
        lw = lw+llist
c
        iproj = lw+1
        lproj = krank*(n-krank)
        lw = lw+lproj
c
        icol = lw+1
        lcol = m*krank
        lw = lw+lcol
c
        iwork = lw+1
        lwork = (krank+1)*(m+3*n)+26*krank**2
        lw = lw+lwork
c
c
        call iddr_asvd0(m,n,a,krank,w(iwinit),u,v,s,ier,
     1                  w(ilist),w(iproj),w(icol),w(iwork))
c
c
        return
        end
c
c
c
c
        subroutine iddr_asvd0(m,n,a,krank,winit,u,v,s,ier,
     1                        list,proj,col,work)
c
c       routine iddr_asvd serves as a memory wrapper
c       for the present routine (please see routine iddr_asvd
c       for further documentation).
c
        implicit none
        integer m,n,krank,list(n),ier
        real*8 a(m,n),u(m,krank),v(n,krank),s(krank),
     1         proj(krank,n-krank),col(m*krank),
     2         winit((2*krank+17)*n+27*m+100),
     3         work((krank+1)*(m+3*n)+26*krank**2)
c
c
c       ID a.
c
        call iddr_aid(m,n,a,krank,winit,list,proj)
c
c
c       Collect together the columns of a indexed by list into col.
c
        call idd_copycols(m,n,a,krank,list,col)
c
c
c       Convert the ID to an SVD.
c
        call idd_id2svd(m,krank,col,n,list,proj,u,v,s,ier,work)
c
c
        return
        end


        subroutine gamma_qdr(pl,gl,a,pu,gu,p,gamma)
ccc
ccc
ccc
ccc     DESCRIPTION :   Evaluate the quadratic gamma profile at a pressure
ccc                     between two bottles
ccc
ccc     PRECISION :     Double
ccc
ccc     INPUT :         pl, pu          bottle pressures
ccc                     gl, gu          bottle gamma values
ccc                     a               quadratic coefficient
ccc                     p               pressure for gamma value
ccc
ccc     OUTPUT :        gamma           gamma value at p
ccc
ccc     UNITS :         pressure        db
ccc                     gamma           kg m-3
ccc                     a               kg m-3
ccc
ccc
ccc     AUTHOR :        David Jackett
ccc
ccc     CREATED :       June 1993
ccc
ccc     REVISION :      1.1             30/6/93
ccc
ccc
ccc
        implicit double precision (a-h,o-z)

        p1 = (p-pu)/(pu-pl)
        p2 = (p-pl)/(pu-pl)

        gamma = (a*p1+(gu-gl))*p2+gl

        return
        end