subroutine t_abs_const(j,k,jl,kl,t0,t2)
!subroutine to compute the (t^0)_{jk}^{j_l k_l} and (t^2)_{jk}^{j_l k_l}
!constants for absorption t_A from L&L04 Eqs.(7.20a).
!tested against matlab routines
use fwigxjpf

implicit none
integer j,k,jl,kl
integer dj,dk
integer m,ml,q

double precision t0,t2
double precision w1,w2,w3,ww,w4_0,w4_2
double precision ljl,fac1,fas,fac

!input:
!j	-- level 1 angular momentum
!k	-- level 1 rank
!jl	-- level 2 (lower) angular momentum
!kl	-- level 2 rank

!output:
!t0	-- (t^0)_{jk}^{j_l k_l} factor
!t0	-- (t^2)_{jk}^{j_l k_l} factor

dj = jl - j
dk = kl - k

t0 = 0.d0
t2 = 0.d0

if (abs(dj).le.1) then
!compute some factors that are required and summarize them in fac
  ljl  = 2.d0 * jl + 1.d0
  fac1 = dsqrt(3.d0 * (2.d0*k+1.d0) * (2.d0*kl+1.d0) )
  fas  = (-1.d0)**(1.d0 - dj)

  fac = ljl * fac1 * fas

  if (dk.eq.0.or.abs(dk).eq.2) then
    !sum for the t0 and t2 constants
    do m = -j,j
      do q = -1,1
        ml = q + m
!these are the Wigner-3j symbols that are computed using the fwigxjpf
!programs -- times two because it also treats half-integers and has
!integers as input
        w1 = fwig3jj (2* j , 2* j    , 2* k ,&
        &              2* m , 2* (-m) , 0    )

        w2 = fwig3jj (2* jl , 2* jl    , 2* kl ,&
        &              2* ml , 2* (-ml) , 0    )

        w3 = fwig3jj (2* j , 2* jl    , 2* 1 ,&
        &              2* (-m) , 2* ml , 2* (-q)  )

        w4_0 = fwig3jj (2* 1 , 2* 1    , 2* 0 ,&
        &              2* q , 2* (-q) , 0    )

        w4_2 = fwig3jj (2* 1 , 2* 1    , 2* 2 ,&
        &              2* q , 2* (-q) , 0    )

        ww = w1*w2*w3*w3

!only if k=kl do we have a contribution from the J_0^0 element
        if (dk.eq.0) t0 = t0 + ww*w4_0
        t2 = t2 + ww*w4_2
      end do
    end do

!extra sqrt(5) factor from the 2*kr+1
    t0 = t0 * fac
    t2 = t2 * dsqrt(5.d0) * fac

  endif
endif

end subroutine

subroutine t_stim_const(j,k,ju,ku,t0,t2)
!subroutine to compute the (t^0)_{jk}^{j_l k_l} and (t^2)_{jk}^{j_l k_l}
!constants for stimulated emission from L&L04 Eqs.(7.20c).
!tested against matlab routines
use fwigxjpf

implicit none
integer j,k,ju,ku
integer dj,dk
integer m,mu,q

double precision t0,t2
double precision w1,w2,w3,ww,w4_0,w4_2
double precision lju,fac1,fas,fac

!input:
!j	-- level 1 angular momentum
!k	-- level 1 rank
!ju	-- level 2 (upper) angular momentum
!ku	-- level 2 rank

!output:
!t0	-- (t^0)_{jk}^{j_l k_l} factor
!t0	-- (t^2)_{jk}^{j_l k_l} factor

dj = ju - j
dk = ku - k

t0 = 0.d0
t2 = 0.d0

if (abs(dj).le.1) then
!compute some factors that are required and summarize them in fac
  lju  = 2.d0 * ju + 1.d0
  fac1 = dsqrt(3.d0 * (2.d0*k+1.d0) * (2.d0*ku+1.d0) )
  fas  = (-1.d0)**(1.d0 - dj)

  fac = lju * fac1 * fas

  if (dk.eq.0.or.abs(dk).eq.2) then
    !sum for the t0 and t2 constants
    do m = -j,j
      do q = -1,1
        mu = m - q
!these are the Wigner-3j symbols that are computed using the fwigxjpf
!programs -- times two because it also treats half-integers and has
!integers as input
        w1 = fwig3jj (2* j , 2* j    , 2* k ,&
        &              2* m , 2* (-m) , 0    )

        w2 = fwig3jj (2* ju , 2* ju    , 2* ku ,&
        &              2* mu , 2* (-mu) , 0    )

        w3 = fwig3jj (2* ju , 2* j    , 2* 1 ,&
        &              2* (-mu) , 2* m , 2* (-q)  )

        w4_0 = fwig3jj (2* 1 , 2* 1    , 2* 0 ,&
        &              2* q , 2* (-q) , 0    )

        w4_2 = fwig3jj (2* 1 , 2* 1    , 2* 2 ,&
        &              2* q , 2* (-q) , 0    )

        ww = w1*w2*w3*w3

!only if k=ku do we have a contribution from the J_0^0 element
        if (dk.eq.0) t0 = t0 + ww*w4_0
        t2 = t2 + ww*w4_2
      end do
    end do

    t0 = t0 * fac
    t2 = t2 * dsqrt(5.d0) * fac

  endif
endif

end subroutine

subroutine t_spont_const(j,k,ju,ku,t0)
!subroutine to compute the (t^0)_{jk}^{j_l k_l} and (t^2)_{jk}^{j_l k_l}
!constants for spontaneous emission from L&L04 Eqs.(7.20b).
!tested against matlab routines
use fwigxjpf

implicit none
integer j,k,ju,ku
integer dj,dk
integer m,mu,q

double precision t0
double precision w1,lju,fas

!input:
!j      -- level 1 angular momentum
!k      -- level 1 rank
!ju     -- level 2 (upper) angular momentum
!ku     -- level 2 rank

!output:
!t0     -- (t^0)_{jk}^{j_l k_l} factor

dj = ju - j
dk = ku - k

t0 = 0.d0

!delta_kku and selection rule
if (abs(dj).le.1.and.dk.eq.0) then
!required factors
  lju  = 2.d0 * ju + 1.d0
  fas  = (-1.d0)**(1.d0 + 1.d0*j + 1.d0*ju + 1.d0*k)

!Wigner 6j-symbol
  w1 = fwig6jj (2* ju , 2* ju , 2* k ,&
  &              2* j , 2* j  , 2* 1    )

  t0 = lju * fas * w1

endif

end subroutine

subroutine r_abs_const(j,k,ju,kp,r0,r2)
!subroutine to compute the (r^0)_{jk}^{j_u k_p} and (r^2)_{jk}^{j_u k_p}
!constants for absorption r_A from L&L04 Eqs.(7.20d).
!tested against matlab routines
use fwigxjpf

implicit none
integer j,k,ju,kp
integer dj,dk
integer m,mu,q

double precision r0,r2
double precision w1,w2,w3,ww,w4_0,w4_2
double precision lj,fac1,fas,fac

!input:
!j	-- level 1 angular momentum
!k	-- level 1 rank
!ju	-- level 2 (upper) angular momentum
!kp	-- level 2 rank (k-prime)

!output:
!r0	-- (r^0)_{jk}^{j_l k_l} factor
!r0	-- (r^2)_{jk}^{j_l k_l} factor

dj = ju - j
dk = kp - k

r0 = 0.d0
r2 = 0.d0

if (abs(dj).le.1) then
!compute some factors that are required and summarize them in fac
  lj  = 2.d0 * j + 1.d0
  fac1 = dsqrt(3.d0 * (2.d0*k+1.d0) * (2.d0*kp+1.d0) )

  if (dk.eq.0.or.abs(dk).eq.2) then
    !sum for the r0 and r2 constants
    do m = -j,j
      do q = -1,1
        mu = m-q

        fas = (-1.d0)**(1.d0 + q)
        fac = lj * fac1 * fas

!these are the Wigner-3j symbols that are computed using the fwigxjpf
!programs -- times two because it also treats half-integers and has
!integers as input
        w1 = fwig3jj (2* j , 2* j    , 2* k ,&
        &              2* m , 2* (-m) , 0    )

        w2 = fwig3jj (2* j , 2* j    , 2* kp ,&
        &              2* m , 2* (-m) , 0    )

        w3 = fwig3jj (2* ju , 2* j    , 2* 1 ,&
        &              2* (-mu) , 2* m , 2* (-q)  )

        w4_0 = fwig3jj (2* 1 , 2* 1    , 2* 0 ,&
        &              2* q , 2* (-q) , 0    )

        w4_2 = fwig3jj (2* 1 , 2* 1    , 2* 2 ,&
        &              2* q , 2* (-q) , 0    )

        ww = w1*w2*w3*w3

!only if k=kl do we have a contribution from the J_0^0 element
        if (dk.eq.0) r0 = r0 + fac*ww*w4_0
        r2 = r2 + fac*ww*w4_2
      end do
    end do

!extra sqrt(5) factor from the 2*kr+1
    r2 = r2 * dsqrt(5.d0)

  endif
endif

end subroutine

subroutine r_stim_const(j,k,jl,kp,r0,r2)
!subroutine to compute the (r^0)_{jk}^{j_l k_l} and (r^2)_{jk}^{j_l k_l}
!constants for stimulated emission from L&L04 Eqs.(7.20f).
!tested against matlab routines
use fwigxjpf

implicit none
integer j,k,jl,kp
integer dj,dk
integer m,ml,q

double precision r0,r2
double precision w1,w2,w3,ww,w4_0,w4_2
double precision lj,fac1,fas,fac

!input:
!j	-- level 1 angular momentum
!k	-- level 1 rank
!jl	-- level 2 (lower) angular momentum
!kp	-- level 2 rank (k-prime)

!output:
!t0	-- (r^0)_{jk}^{j_u k_p} factor
!t0	-- (r^2)_{jk}^{j_u k_p} factor

dj = jl - j
dk = kp - k

r0 = 0.d0
r2 = 0.d0

if (abs(dj).le.1) then
!compute some factors that are required and summarize them in fac
  lj  = 2.d0 * j + 1.d0
  fac1 = dsqrt(3.d0 * (2.d0*k+1.d0) * (2.d0*kp+1.d0) )

  if (dk.eq.0.or.abs(dk).eq.2) then
    !sum for the r0 and r2 constants
    do m = -j,j
      do q = -1,1
        ml = m + q

        fas = (-1.d0)**(1.d0 - q)
        fac = lj * fac1 * fas

!these are the Wigner-3j symbols that are computed using the fwigxjpf
!programs -- times two because it also treats half-integers and has
!integers as input
        w1 = fwig3jj (2* j , 2* j    , 2* k ,&
        &              2* m , 2* (-m) , 0    )

        w2 = fwig3jj (2* j , 2* j    , 2* kp ,&
        &              2* m , 2* (-m) , 0    )

        w3 = fwig3jj (2* j , 2* jl    , 2* 1 ,&
        &              2* (-m) , 2* ml , 2* (-q)  )

        w4_0 = fwig3jj (2* 1 , 2* 1    , 2* 0 ,&
        &              2* q , 2* (-q) , 0    )

        w4_2 = fwig3jj (2* 1 , 2* 1    , 2* 2 ,&
        &              2* q , 2* (-q) , 0    )

        ww = w1*w2*w3*w3

!only if k=kp do we have a contribution from the J_0^0 element
        if (dk.eq.0) r0 = r0 + fac*ww*w4_0
        r2 = r2 + fac*ww*w4_2
      end do
    end do

    r2 = r2 * dsqrt(5.d0)

  endif
endif

end subroutine

subroutine setup_stateq(c_dim,count_array,nlev,j_lev,trans,ntrans,kmax,&
&AC_trans,D0,Temp,Amat,A_mat,B_mat,C_mat)
!subroutine to setup up the statistical equilibrium equation matrix
!subroutine still has to be polished and tested
!calls to the constant-calculations can be replaced by pre-calculated
!matrices to save computational effort
!no de-polarization term D^(K) built in as of yet

!The Hazel program has a built-in kmax=6 -- we have kmax=8

!The Hazel program substitutes the first row of the Amat matrix by
!an equation that says \sum_i sqrt(2*j_i+1) * rho^0_i = 1
!maybe we can do it in a different way

implicit none
integer i,c_dim,nlev,ntrans
integer i1,j1,k1
integer i2,j2,k2
integer i3,j3,q
integer c1,c2,kmax
integer c_up_trans,c_down_trans,t_up,t_down
integer, dimension(2,ntrans) :: trans
integer, dimension(ntrans) :: up_trans
integer, dimension(ntrans) :: down_trans
integer, dimension(3,c_dim) :: C_all
integer, dimension(nlev) :: j_lev,count_array

double precision A21,B21,B12,C21,C12,a_to_b
double precision ts0,ts2,te0,ta0,ta2,r0,r2,JR0,JR2
double precision t_rad,t_col,nu0,col_abs,col_stim
double precision rad_abs,rad_stim,g1,g2,g3,Temp
double precision col_dep

double precision, dimension(nlev,2:kmax) :: D0
double precision, dimension(5,ntrans) :: AC_trans
double precision, dimension(5,ntrans) :: AC_up_trans
double precision, dimension(5,ntrans) :: AC_down_trans
double precision, dimension(c_dim,c_dim) :: Amat
double precision, dimension(c_dim,c_dim) :: A_mat
double precision, dimension(c_dim,c_dim) :: B_mat
double precision, dimension(c_dim,c_dim) :: C_mat

!input
!c_dim		-- dimension of Amat
!count_array	-- counting array that finds initial counting
!		   number associated with certain level
!nlev		-- number of levels
!trans		-- list of transitions (only lower --> upper)
!ntrans		-- total number of transitions. N.B. these are
!		   collisional and radiative transitions combined
!AC_trans	-- transition coefficients (Aij,Cij,nu0,J0,J2)
!Temp		-- temperature required to obtain C12 from
!                  Einstein-Milne relation
!D0             -- Collisional de-polarization rates per level

!output
!Amat		-- statistical equillibrium matrix

a_to_b = 6.781962D49    !best to use L&L relation here
                        !B21 = [c^2 / (2*h * v^3)] * A21
                        !a_to_b = c^2 / (2*h)

Amat(:,:) = 0.d0
A_mat(:,:) = 0.d0
B_mat(:,:) = 0.d0
C_mat(:,:) = 0.d0

do i1 = 1,nlev
!find relevant transitions
!divide relevant transitions up into excitations
!and de-excitations
  c_up_trans = 0
  c_down_trans = 0
  do i2 = 1,nlev
    do q = 1,ntrans
      if (trans(1,q).eq.i1.and.trans(2,q).eq.i2) then
        c_up_trans = c_up_trans + 1
        up_trans(c_up_trans) = i2
        AC_up_trans(1,c_up_trans) = AC_trans(1,q) !A21
        AC_up_trans(2,c_up_trans) = AC_trans(2,q) !C21
        AC_up_trans(3,c_up_trans) = AC_trans(3,q) !nu0
        AC_up_trans(4,c_up_trans) = AC_trans(4,q) !J0
        AC_up_trans(5,c_up_trans) = AC_trans(5,q) !J2
      endif

      if (trans(1,q).eq.i2.and.trans(2,q).eq.i1) then
        c_down_trans = c_down_trans + 1
        down_trans(c_down_trans) = i2
        AC_down_trans(1,c_down_trans) = AC_trans(1,q)
        AC_down_trans(2,c_down_trans) = AC_trans(2,q)
        AC_down_trans(3,c_down_trans) = AC_trans(3,q)
        AC_down_trans(4,c_down_trans) = AC_trans(4,q)
        AC_down_trans(5,c_down_trans) = AC_trans(5,q)
      endif
    end do
  end do

!  write(*,*)i1,c_up_trans,c_down_trans
!  write(*,*)up_trans(1:c_up_trans)
!  write(*,*)down_trans(1:c_down_trans)
!  write(*,*)

  j1 = j_lev(i1)
  g1 = 2.d0 * j1 + 1.d0

!now we have c_up_trans relevant upper transitions
  do t_up = 1,c_up_trans
!   j1 -- lower
!   j2 -- upper

    i2 = up_trans(t_up)
    j2 = j_lev(i2)

    g2 = 2.d0 * j2 + 1.d0

    A21 = AC_up_trans(1,t_up)
    C21 = AC_up_trans(2,t_up)
    nu0 = AC_up_trans(3,t_up)
    JR0  = AC_up_trans(4,t_up)
    JR2  = AC_up_trans(5,t_up)

    B21 = a_to_b * A21 / nu0**3.d0

!    write(*,*)i1,j1,i2,j2
!    write(*,*)A21,C21,B21,nu0,JR0,JR2
!    stop

    c1 = count_array(i1)
    do k1 = 0,min(2*j1,kmax),2
      c1 = c1 + 1
      c2 = count_array(i2)
      do k2 = 0,min(2*j2,kmax),2
        c2 = c2 + 1
        !upper transition factors
        call t_stim_const(j1,k1,j2,k2,ts0,ts2)
        call t_spont_const(j1,k1,j2,k2,te0)

        !radiative coefficent
        t_rad = B21 * (ts0 * JR0 + ts2 * JR2) + A21 * te0

        !collisional coefficient only if k1=k2
        t_col = 0.d0
        if (k1.eq.k2) then
!currently (as in GK), only the rank-0 contribution of the collisional
!operator to the rate equations
          if (k1.eq.0) t_col = dsqrt(g2/g1)*C21          !no degeneracy terms?
        endif

        Amat(c1,c2) = t_rad + t_col         !Amat is only defined once
        A_mat(c1,c2) = A_mat(c1,c2) + A21 * te0
        B_mat(c1,c2) = B_mat(c1,c2) + B21 * (ts0 * JR0 + ts2 * JR2)
        C_mat(c1,c2) = C_mat(c1,c2) + t_col
      end do
    end do
  end do

!now we have c_down_trans relevant down transitions
  do t_down = 1,c_down_trans
!   j1 -- upper
!   j2 -- lower

    i2 = down_trans(t_down)
    j2 = j_lev(i2)
    g2 = 2.d0 * j2 + 1.d0

    A21  = AC_down_trans(1,t_down)
    C21  = AC_down_trans(2,t_down)
    nu0  = AC_down_trans(3,t_down)
    JR0  = AC_down_trans(4,t_down)
    JR2  = AC_down_trans(5,t_down)

    B21 = a_to_b * A21 / nu0**3.d0
    B12 = B21 * g1 / g2

    C12 = C21 * g1 * dexp(-4.79924d-11 * nu0 / Temp) / g2 !constant is h/kB

    c1 = count_array(i1)
    do k1 = 0,min(2*j1,kmax),2
      c1 = c1 + 1
      c2 = count_array(i2)
      do k2 = 0,min(2*j2,kmax),2
        c2 = c2 + 1
        !upper transition factors
        call t_abs_const(j1,k1,j2,k2,ta0,ta2)

        !radiative coefficent
        t_rad = B12 * (ta0 * JR0 + ta2 * JR2)

        !collisional coefficient only if k1=k2
        t_col = 0.d0
        if (k1.eq.k2) then
!currently (as in GK), only the rank-0 contribution of the collisional
!operator to the rate equations
          if (k1.eq.0) t_col = dsqrt(g2/g1)*C12
        endif

        Amat(c1,c2) = t_rad + t_col         !Amat is only defined once
        B_mat(c1,c2) = B_mat(c1,c2) + t_rad
        C_mat(c1,c2) = C_mat(c1,c2) + t_col
      end do
    end do
  end do

!inner level depedancies
  i2 = i1
  j2 = j1

  c1 = count_array(i1)
  do k1 = 0,min(2*j1,kmax),2
    c1 = c1 + 1
    c2 = count_array(i2)
    do k2 = 0,min(2*j2,kmax),2
      c2 = c2 + 1

      rad_abs = 0.d0
      col_abs = 0.d0
      !all excitations away to upper levels
      do t_up = 1,c_up_trans
        !j1 -- lower
        !j3 -- upper

        i3 = up_trans(t_up)
        j3 = j_lev(i3)
        g3 = 2.d0 * j3 + 1.d0

        A21  = AC_up_trans(1,t_up)
        C21  = AC_up_trans(2,t_up)
        nu0  = AC_up_trans(3,t_up)
        JR0  = AC_up_trans(4,t_up)
        JR2  = AC_up_trans(5,t_up)

        B21 = a_to_b * A21 / nu0**3.d0
        B12 = B21 * g3 / g1
        C12 = C21 * g3 * dexp(-4.79924d-11 * nu0 / Temp) / g1 !constant is h/kB (K/Hz)

        call r_abs_const(j1,k1,j3,k2,r0,r2)
        rad_abs = rad_abs + B12 * (JR0 * r0 + JR2 * r2)

        B_mat(c1,c2) = B_mat(c1,c2) - B12 * (JR0 * r0 + JR2 * r2)

        if (k1.eq.k2) then
          col_abs = col_abs + C12

          C_mat(c1,c2) = C_mat(c1,c2) - C12

!          if (k1.eq.0) write(*,*)j1,j3,B12*(JR0*r0+JR2*r2),r0

        endif
      end do

      !all de-excitations to lower levels
      rad_stim = 0.d0      !also includes spontaneous emission
      col_stim = 0.d0
      do t_down = 1,c_down_trans
        i3 = down_trans(t_down)
        j3 = j_lev(i3)

        A21 = AC_down_trans(1,t_down)
        C21 = AC_down_trans(2,t_down)
        nu0 = AC_down_trans(3,t_down)
        JR0  = AC_down_trans(4,t_down)
        JR2  = AC_down_trans(5,t_down)

        B21 = a_to_b * A21 / nu0**3.d0

        call r_stim_const(j1,k1,j3,k2,r0,r2)

        rad_stim = rad_stim + B21 * (JR0 * r0 + JR2 * r2)
        B_mat(c1,c2) = B_mat(c1,c2) - B21 * (JR0 * r0 + JR2 * r2)

        if (k1.eq.k2) then
          rad_stim = rad_stim + A21
          col_stim = col_stim + C21

          A_mat(c1,c2) = A_mat(c1,c2) - A21
          C_mat(c1,c2) = C_mat(c1,c2) - C21

!          if (k1.eq.0) write(*,*)j1,j3,B21*(JR0*r0+JR2*r2),r0
        endif
      end do

      if (k1.eq.k2.and.k2.ge.2) then
        !collisional de-polarization rates
        col_dep = D0(i1,k1)
        C_mat(c1,c2) = C_mat(c1,c2) - col_dep
      endif
!note the minus sign -- Amat is only defined once
      Amat(c1,c2) = -1.d0*(rad_abs + rad_stim + col_abs + col_stim + col_dep)
    end do
  end do
end do

end subroutine


  !   atom 1: N
  !   atom 2: O
  !   atom 3: N
  !
  ! The PES for the NO+N in the ^3A' state is call
  !
  !     call  call initialize_PES()
  !     call USERE(EU,X,Y,Z,DX,DY,DZ,QECONT,ECONT,NATOMX)
  !
  !     EU   - User energy to be returned
  !     X,Y,Z - Coordinates for energy evaluation
  !     DX,DY,DZ - Forces. Must be modified. Append (dE/dX,...)
  !     QECONT - Flag for analysis (0-no analysis,>0=analysis)
  !     ECONT(NATOMX) - Analysis array to be filled if QECONT>0.
  !     NATOMX - Number of atoms = 3
  !
  !
module chm_kinds
    implicit none
    INTEGER, PARAMETER :: chm_real = 8

end module
!***** For Charmm just remove until here and the comments with 3 exclamations (!!!) ***********
!///////////////////////////////////////////////////////////////////////////////
!
!    This module contains the 1-dimensional kernel functions and their derivatives
!
!///////////////////////////////////////////////////////////////////////////////
module RKHS
    implicit none
    private
    !declare all methods/variables available from the outside
    public :: q_ker, dq_ker, k_ker, dk_ker

!functions and subroutines start here
contains
    !the reproducing kernel q_ker for distance like variables
    real*8 function q_ker(x,r)
        implicit none
        real*8 :: x,r,x_l,x_s
        x_l=r
           x_s=x
        if(r < x) then
            x_s=r
            x_l=x
        endif
        q_ker = (1d0/(14d0*x_l**7))*(1d0-7*x_s/(9*x_l))
    end function q_ker

    !derivative of q_ker
    real*8 function dq_ker(x,r)
        implicit none
        real*8 :: x,r
        if(x < r) then
            dq_ker = -1d0/(18d0*r**8)
        else
            dq_ker = -(1d0/18d0)*(9*x-8*r)/(x**9)
        end if
    end function dq_ker

    !the reproducing kernel k_ker for angle like variables
    real*8 function k_ker(x,r)      !k=2 Anglelike
        implicit none
        real*8 :: x,r,x_l,x_s
        x_l=r !Large value of the coordinate
        x_s=x !Small value of the coordinate
        if(r < x) then !Here the smaller and larger value are chosen
            x_s=r
            x_l=x
        endif
        !Only two terms (up to n=1) were taken of the Gauss´ hypergeometric function expansion
        k_ker=1+x_s*x_l+2*x_s**2*x_l*(1.d0-x_s/(3*x_l))
    end function k_ker

    !derivative of k_ker
    real*8 function dk_ker(x,r)
        implicit none
        real*8 :: x,r
        if(x < r) then
            dk_ker = r+4*x*r*(1.d0-x/(3*r))-(2*x**2)/3d0
        else
            dk_ker = r+2*r**2*(1.d0-r/(3*x))+(2*r**3)/(3*x)
        end if
    end function dk_ker
end module RKHS

!///////////////////////////////////////////////////////////////////////////////
!
!    This module contains routines to read files and store them in arrays
!
!///////////////////////////////////////////////////////////////////////////////
module fileInOut
    implicit none
    private
    public :: readData, readData2, writeData, writeData2

    contains
    !subroutine to read in files
    subroutine readData(unitnr,ios,array, inputfile,dim1)
        implicit none
        !declaration of variables
        integer :: unitnr,dim1
        integer :: i,ios
        real*8 :: array(dim1)
        character(len=*) :: inputfile

        open(unitnr,file=inputfile, status='old', action='read', &
                 iostat=ios)
        !error check
        if (ios /= 0) then
            return
        end if
        do i=1,dim1
            read(unitnr,*) array(i)
        end do
        close(unit=unitnr)
    end subroutine readData

    subroutine readData2(unitnr,ios,array, inputfile,dim1,dim2)
        implicit none
        !declaration of variables
        integer :: unitnr,dim1,dim2
        integer :: i,ios
        real*8 :: array(dim1,dim2)
        character(len=*) :: inputfile

        open(unitnr,file=inputfile, status='old', action='read', &
                 iostat=ios)
        !error check
        if (ios /= 0) then
            return
        end if
        do i=1,dim1
            read(unitnr,*) array(i,:)
        end do
        close(unit=unitnr)
    end subroutine readData2

    subroutine writeData(unitnr,ios,array,outputfile,dim1)
        implicit none
        integer :: unitnr,dim1
        integer :: i,ios
        real*8 :: array(dim1)
        character(len=*) :: outputfile

        open(unitnr, file=outputfile, status='new', action='write', &
                iostat=ios)
        if (ios /= 0) then
            return
        end if
        do i=1,dim1
            write(unitnr,*) array(i)
        end do
        close(unit=unitnr)
    end subroutine writeData

    subroutine writeData2(unitnr,ios,array,outputfile,dim1,dim2)
        implicit none
        integer :: unitnr,dim1,dim2
        integer :: i,ios
        real*8 :: array(dim1,dim2)
        character(len=*) :: outputfile

        open(unitnr, file=outputfile, status='new', action='write', &
                iostat=ios)
        if (ios /= 0) then
            return
        end if
        do i=1,dim1
            write(unitnr,*) array(i,:)
        end do
        close(unit=unitnr)
    end subroutine writeData2

end module fileInOut

!///////////////////////////////////////////////////////////////////////////////
!
!    This module contains all the routines necessary to return the custom energies
!    and forces from the RKHS interpolation
!
!///////////////////////////////////////////////////////////////////////////////
module CustomEnergy
    use RKHS
    implicit none
    private
    public :: initialize_PES, Epot, dEdR, dEdVdW, dEdalpha, adEdR, adEdVdW, adEdalpha

!-------------------------------------CHANGE HERE-------------------------------------
! The dimensions of the PES grid is specified here (number of points for the three coordinates)
    integer, parameter ::   nAlpha = 11  ,& !number of gridpoints for alpha
                            nVdW   = 19  ,& !25,&! !number of gridpoints for bigR
                            nR     = 13     !number of gridpoints for smallR
!-------------------------------------------------------------------------------------

    real*8, parameter :: PI = 3.141592653589793238462643383279502884197d0

    !Array to store the grid data
    real*8 :: dataArray(nAlpha*nVdW*nR,4)  !array that the ab initio points are read into
    real*8 :: r_grid(nR)                   !store r_grid for asymptote correction
    real*8, save :: dataArray1(nAlpha*nVdW*nR,4), dataArray2(nAlpha*nVdW*nR,4), dataArray3(nAlpha*nVdW*nR,4)
    real*8, save :: r_grid1(nR), r_grid2(nR), r_grid3(nR)

    !Arrays for the weights (coefficients)
    real*8 :: w_tot(nAlpha*nR*nVdW), w_R(nR)
    real*8, save :: w_tot1(nAlpha*nR*nVdW), w_R1(nR)
    real*8, save :: w_tot2(nAlpha*nR*nVdW), w_R2(nR)
    real*8, save :: w_tot3(nAlpha*nR*nVdW), w_R3(nR)

contains
    !Reads in the weights for the RKHS interpolation. This is invoked at the startup of CHARMM
    subroutine initialize_PES()
        use fileInOut
        implicit none
        integer i
        integer :: IOS, IOS1, IOS2 !used to check file status
        call readData2(20,IOS ,dataArray1,"data/data1.txt",nAlpha*nVdW*nR,4)
        call readData2(20,IOS1,dataArray2,"data/data2.txt",nAlpha*nVdW*nR,4)
        call readData2(20,IOS2,dataArray3,"data/data3.txt",nAlpha*nVdW*nR,4)
        if ((IOS /= 0).or.(IOS1 /= 0).or.(IOS2 /= 0)) then
            print*, "One of the data files that contains the grid in the data folder could not be read properly."
            print*, "program terminated."
            stop
        end if

        !change alpha to new coordinate y=(1-cos(alpha))/2
        do i=1,nR*nVdW*nAlpha
            dataArray1(i,1)=y(dataArray1(i,1))
            dataArray2(i,1)=y(dataArray2(i,1))
            dataArray3(i,1)=y(dataArray3(i,1))
        end do
        !read in r_grid (needed for asymptote correction)
        do i=1,nR
            r_grid1(i)=dataArray1(1+(i-1)*nVdW,2)
            r_grid2(i)=dataArray2(1+(i-1)*nVdW,2)
            r_grid3(i)=dataArray3(1+(i-1)*nVdW,2)
        end do

        !read weight/coefficient data for surface 1 from files
        call readData(21,IOS1,w_R1,"data/w_r1.dat",nR)
        call readData(22,IOS2,w_tot1,"data/w_tot1.dat",nAlpha*nR*nVdW)
        !Error check
        if ((IOS1 /= 0).or.(IOS2 /= 0).or.(IOS /= 0)) then
            print*, "One of the weight-files in the data folder for surface 1 could not be read properly."
            print*, "program terminated."
            stop
        end if

        !read weight/coefficient data for surface 2 from files
        call readData(21,IOS1,w_R2,"data/w_r2.dat",nR)
        call readData(22,IOS2,w_tot2,"data/w_tot2.dat",nAlpha*nR*nVdW)
        !Error check
        if ((IOS1 /= 0).or.(IOS2 /= 0).or.(IOS /= 0)) then
            print*, "One of the weight-files in the data folder for surface 2 could not be read properly."
            print*, "program terminated."
            stop
        end if

        !read weight/coefficient data for surface 3 from files
        call readData(21,IOS1,w_R3,"data/w_r3.dat",nR)
        call readData(22,IOS2,w_tot3,"data/w_tot3.dat",nAlpha*nR*nVdW)
        !Error check
        if ((IOS1 /= 0).or.(IOS2 /= 0).or.(IOS /= 0)) then
            print*, "One of the weight-files in the data folder for surface 3 could not be read properly."
            print*, "program terminated."
            stop
        end if

        return
    end subroutine initialize_PES

    !transforms alpha to the new variable y=(1-cos(alpha))/2
    real*8 function y(alpha)
        implicit none
        real*8,intent(in) :: alpha
        y = (1d0-DCOS(alpha*PI/180d0))/2d0
    end function y

    real*8 function dy(alpha) !used for calculating the analytical derivative with respect to alpha (chainrule)
        implicit none
        real*8,intent(in) :: alpha
        dy = (PI/360d0)*DSIN(alpha*PI/180d0)
    end function dy

    !calculates the new asymptote depending for r'
    real*8 function asymp(R,surf)
        implicit none
        real*8, intent(in) :: R
        !which surface shall be calculated
        integer, intent(in) :: surf
        integer :: counter
        asymp = 0.d0

        !read appropriate weights, depending on which surface is selected
        if      (surf == 1) then
            w_R = w_R1
            r_grid = r_grid1
        else if (surf == 2) then
            w_R = w_R2
            r_grid = r_grid2
        else if (surf == 3) then
            w_R = w_R3
            r_grid = r_grid3
        else
            print*, "ERROR: Only surface numbers 1-3 are supported. Check call for Epot "
            stop
        end if
        do counter=1,nR
            asymp = asymp + w_R(counter)*q_ker(R,r_grid(counter))
        end do
    end function asymp

    real*8 function dasymp(R,surf)
        implicit none
        real*8, intent(in) :: R
        !which surface shall be calculated
        integer, intent(in) :: surf
        integer :: counter
        dasymp = 0.d0

                !read appropriate weights, depending on which surface is selected
        if      (surf == 1) then
            w_R = w_R1
            r_grid = r_grid1
        else if (surf == 2) then
            w_R = w_R2
            r_grid = r_grid2
        else if (surf == 3) then
            w_R = w_R3
            r_grid = r_grid3
        else
            print*, "ERROR: Only surface numbers 1-3 are supported. Check call for Epot "
            stop
        end if
        do counter=1,nR
            dasymp = dasymp + w_R(counter)*dq_ker(R,r_grid(counter))
        end do
    end function dasymp

    !calculates the energy V(alpha',r',R') for an off-grid point
    real*8 function Epot(R,VdW,alpha,surf)
        implicit none
        !input coordinates
        real*8, intent(in) :: R,VdW,alpha
        real*8 :: y_val !coordinate transformation
        !which surface shall be calculated?
        integer, intent(in) :: surf
        integer :: counter
        y_val = y(alpha)    !transforms alpha to y
        Epot = 0d0

        !read appropriate weights, depending on which surface is selected
        if      (surf == 1) then
            w_tot = w_tot1
            dataArray = dataArray1
        else if (surf == 2) then
            w_tot = w_tot2
            dataArray = dataArray2
        else if (surf == 3) then
            w_tot = w_tot3
            dataArray = dataArray3
        else
            print*, "ERROR: Only surface numbers 1-3 are supported. Check call for Epot "
            stop
        end if

        do counter=1,nAlpha*nR*nVdW
            Epot = Epot + w_tot(counter)*k_ker(y_val,dataArray(counter,1)) &
                *q_ker(R,dataArray(counter,2))*q_ker(VdW,dataArray(counter,3))
        end do
        Epot = Epot + asymp(R,surf)
    end function Epot

    !calculates the partial derivative of V(alpha,r,R) with respect to VdW numerically
    real*8 function dEdVdW(R,VdW,alpha,surf)
        implicit none
        real*8, intent(in) :: alpha,R,VdW
        integer, intent(in) :: surf
        real*8 :: eps
        real*8, dimension(4) :: stencil
        !construct epsilon
        !eps = dabs(dsqrt(epsilon(0.d0))*VdW)
        !if(eps < dsqrt(epsilon(0.d0))) eps = dsqrt(epsilon(0.d0))
        eps = 1d-5
        !build stencil
        stencil(1) = Epot(R, VdW +2*eps, alpha, surf)
        stencil(2) = Epot(R, VdW +1*eps, alpha, surf)
        stencil(3) = Epot(R, VdW -1*eps, alpha, surf)
        stencil(4) = Epot(R, VdW -2*eps, alpha, surf)
        dEdVdW = derivative_FivePointStencil(stencil,eps)
    end function dEdVdW

    !calculates the partial derivative of V(alpha,r,R) with respect to r numerically
    real*8 function dEdR(R,VdW,alpha,surf)
        implicit none
        real*8, intent(in) :: alpha,R,VdW
        integer, intent(in) :: surf
        real*8 :: eps
        real*8, dimension(4) :: stencil
        !construct epsilon
        !eps = dabs(dsqrt(epsilon(0.d0))*R)
        !if(eps < dsqrt(epsilon(0.d0))) eps = dsqrt(epsilon(0.d0))
        eps = 1d-5
        !build stencil
        stencil(1) = Epot(R +2*eps, VdW, alpha, surf)
        stencil(2) = Epot(R +1*eps, VdW, alpha, surf)
        stencil(3) = Epot(R -1*eps, VdW, alpha, surf)
        stencil(4) = Epot(R -2*eps, VdW, alpha, surf)
        dEdR = derivative_FivePointStencil(stencil,eps)
    end function dEdR

    !calculates the partial derivative of V(alpha,r,R) with respect to alpha numerically
    real*8 function dEdalpha(R,VdW,alpha,surf)
        implicit none
        real*8, intent(in) :: alpha,R,VdW
        integer, intent(in) :: surf
        real*8 :: eps, tempy, yplusdy, tempalpha
        real*8, dimension(4) :: stencil
        !construct epsilon
        !eps = dabs(dsqrt(epsilon(0.d0))*alpha)
        !if(eps < dsqrt(epsilon(0.d0))) eps = dsqrt(epsilon(0.d0))
        eps = 1d-5
        !This is a long block to construct an appropriate displacement for alpha
        tempy = y(alpha)
        yplusdy = tempy + eps
        if (yplusdy > 1.d0) yplusdy = tempy - eps
        tempalpha = dacos(1-2*yplusdy)
        eps = dabs(alpha-tempalpha)
        !build stencil
        stencil(1) = Epot(R, VdW, alpha +2*eps, surf)
        stencil(2) = Epot(R, VdW, alpha +1*eps, surf)
        stencil(3) = Epot(R, VdW, alpha -1*eps, surf)
        stencil(4) = Epot(R, VdW, alpha -2*eps, surf)
        dEdalpha = derivative_FivePointStencil(stencil,eps)
    end function dEdalpha

    real*8 function derivative_FivePointStencil(stencil,dx)
        implicit none
        real*8, dimension(4), intent(in) :: stencil
        real*8,               intent(in) :: dx
        derivative_FivePointStencil = (-stencil(1)+8*stencil(2)-8*stencil(3)+stencil(4))/(12*dx)
        return
    end function derivative_FivePointStencil

    !calculates the partial derivative of V(alpha,r,R) with respect to VdW analytically
    real*8 function adEdVdW(R,VdW,alpha,surf)
        implicit none
        real*8, intent(in) :: alpha,R,VdW
        real*8 :: y_val
        integer, intent(in) :: surf
        integer :: counter
        y_val = y(alpha)    !transforms alpha to y
        adEdVdW = 0d0
        !read appropriate weights, depending on which surface is selected
        if      (surf == 1) then
            w_tot = w_tot1
            dataArray = dataArray1
        else if (surf == 2) then
            w_tot = w_tot2
            dataArray = dataArray2
        else if (surf == 3) then
            w_tot = w_tot3
            dataArray = dataArray3
        else
            print*, "ERROR: Only surface numbers 1-3 are supported. Check call for Epot "
            stop
        end if

        do counter=1,nAlpha*nR*nVdW
            adEdVdW = adEdVdW + w_tot(counter)*k_ker(y_val,dataArray(counter,1)) &
                    *q_ker(R,dataArray(counter,2))*dq_ker(VdW,dataArray(counter,3))
        end do
    end function adEdVdW

    !calculates the partial derivative of V(alpha,r,R) with respect to r analytically
    real*8 function adEdR(R,VdW,alpha,surf)
        implicit none
        real*8, intent(in) :: alpha,R,VdW
        real*8 :: y_val
        integer, intent(in) :: surf
        integer :: counter
        y_val = y(alpha)    !transforms alpha to y
        adEdR = 0d0
        !read appropriate weights, depending on which surface is selected
        if      (surf == 1) then
            w_tot = w_tot1
            dataArray = dataArray1
        else if (surf == 2) then
            w_tot = w_tot2
            dataArray = dataArray2
        else if (surf == 3) then
            w_tot = w_tot3
            dataArray = dataArray3
        else
            print*, "ERROR: Only surface numbers 1-3 are supported. Check call for Epot "
            stop
        end if

        do counter=1,nAlpha*nR*nVdW
            adEdR = adEdR + w_tot(counter)*k_ker(y_val,dataArray(counter,1)) &
                        *dq_ker(R,dataArray(counter,2))*q_ker(VdW,dataArray(counter,3))
        end do
        adEdR = adEdR + dasymp(R,surf)
    end function adEdR

    !calculates the partial derivative of V(alpha,r,R) with respect to alpha analytically
    real*8 function adEdalpha(R,VdW,alpha,surf)
        implicit none
        real*8, intent(in) :: alpha,R,VdW
        real*8 :: y_val,dy_val
        integer, intent(in) :: surf
        integer :: counter
        y_val = y(alpha)    !transforms alpha to y
        dy_val = dy(alpha)
        adEdalpha = 0d0

        !read appropriate weights, depending on which surface is selected
        if      (surf == 1) then
            w_tot = w_tot1
            dataArray = dataArray1
        else if (surf == 2) then
            w_tot = w_tot2
            dataArray = dataArray2
        else if (surf == 3) then
            w_tot = w_tot3
            dataArray = dataArray3
        else
            print*, "ERROR: Only surface numbers 1-3 are supported. Check call for Epot "
            stop
        end if

        do counter=1,nAlpha*nR*nVdW
            adEdalpha = adEdalpha + w_tot(counter)*dk_ker(y_val,dataArray(counter,1))*dy_val &
                        *q_ker(R,dataArray(counter,2))*q_ker(VdW,dataArray(counter,3))
        end do
    end function adEdalpha

end module CustomEnergy

!///////////////////////////////////////////////////////////////////////////////
!
!    This module contains functions and subroutines needed for unit or coordinate
!    conversion or similar things.
!
!///////////////////////////////////////////////////////////////////////////////
module utility_conversion
use chm_kinds
    implicit none
    private
    public :: calc_Jacobi_coordinates, calc_weights

contains
subroutine calc_Jacobi_coordinates(X,Y,Z,jacCoord,mass,dJacdCart)
!This subroutine calculates the Jacobi coordinates from the cartesian coordinates
!The indices of the Jacobi coordinate arrays coorespond to different surfaces:
!(the numbers here are the atom labels)
!index 1 (surface 1) : 1=2---3
!index 2 (surface 2) : 1=3---2
!index 3 (surface 3) : 2=3---1
    implicit none

    !Input coordinates (cartesian)
    real(chm_real), dimension(3), intent(in) :: X, Y, Z

    !Input masses (needed for some centre of mass)
    real*8, dimension(3), intent(in) :: mass

    !Output coordinates (Jacobi)
    !1st index: surface
    !2nd index: Jacobi coordinate (r, bigR, alpha)
    real*8, dimension(3,3), intent(out) :: jacCoord

    !Output derivatives of Jacobi coordinates with respect to cartesian coordinates
    !1st index: surface
    !2nd index: Jacobi coordinate (r, bigR, alpha)
    !3rd index: cartesian coordinate (x1,y1,z1,x2,y2,z2,x3,y3,z3)
    real*8, intent(out) :: dJacdCart(3,3,9)

    !temporary array to store Jacobi coordinates. We need this for swapping back!
    real*8 :: dJdC_tmp(3,9)

    !Utility variable for convenience that stores all the coordinates in one array
    real*8, dimension(9) :: coord

    !temporary mass array (gets reordered depending on which surface is calculated)
    real*8, dimension(3) :: mass_tmp

    !loop variables
    integer i

    !calculate the Jacobi coordinates for surface 1 (1=2- -3)
        !store coordinates appropriately
    do i=1,3
        coord(1+3*(i-1)) = real(X(i),8)
        coord(2+3*(i-1)) = real(Y(i),8)
        coord(3+3*(i-1)) = real(Z(i),8)
    end do
    call cartesian2jacobi(coord,jacCoord(1,:),dJacdCart(1,:,:),mass)

    !calculate the Jacobi coordinates for surface 2 (1=3- -2)
        !store coordinates appropriately
    coord(1) = real(X(1),8)
    coord(2) = real(Y(1),8)
    coord(3) = real(Z(1),8)
    coord(4) = real(X(3),8)
    coord(5) = real(Y(3),8)
    coord(6) = real(Z(3),8)
    coord(7) = real(X(2),8)
    coord(8) = real(Y(2),8)
    coord(9) = real(Z(2),8)
    !build a temporary mass array with swapped around masses
    mass_tmp(1) = mass(1)
    mass_tmp(2) = mass(3)
    mass_tmp(3) = mass(2)
    call cartesian2jacobi(coord,jacCoord(2,:),dJacdCart(2,:,:),mass_tmp)

    !calculate the Jacobi coordinates for surface 3 (2=3- -1)
        !store coordinates appropriately
    coord(1) = real(X(2),8)
    coord(2) = real(Y(2),8)
    coord(3) = real(Z(2),8)
    coord(4) = real(X(3),8)
    coord(5) = real(Y(3),8)
    coord(6) = real(Z(3),8)
    coord(7) = real(X(1),8)
    coord(8) = real(Y(1),8)
    coord(9) = real(Z(1),8)
    !build a temporary mass array with swapped around masses
    mass_tmp(1) = mass(2)
    mass_tmp(2) = mass(3)
    mass_tmp(3) = mass(1)
    call cartesian2jacobi(coord,jacCoord(3,:),dJacdCart(3,:,:),mass_tmp)

    !Swap back coordinates for surface 2
    dJdC_tmp = dJacdCart(2,:,:)
    dJacdCart(2,:,4:6) = dJdC_tmp(:,7:9)
    dJacdCart(2,:,7:9) = dJdC_tmp(:,4:6)

    !Swap back coordinates for surface 3
    dJdC_tmp = dJacdCart(3,:,:)
    dJacdCart(3,:,1:3) = dJdC_tmp(:,7:9)
    dJacdCart(3,:,4:6) = dJdC_tmp(:,1:3)
    dJacdCart(3,:,7:9) = dJdC_tmp(:,4:6)

    return
end subroutine calc_Jacobi_coordinates

subroutine cartesian2jacobi(x,xi,dxidx,m)
    !This subroutine expects a 9-vector as input that contains the cartesian coordinates,
    !x -> cartesian coordinates (x1,y1,z1,x2,y2,z2,x3,y3,z3)

    !a 3-vector as output that contains the Jacobi coordinates,
    !xi -> 3 Jacobi coordinates (r,R,alpha)

    !an array to store the derivatives of the Jacobi coordinates with respect to the
    !cartesian coordinates. The 1st index corresponds to the Jacobi coordinate (r,R,alpha),
    !while the 2nd index corresponds to the cartesian coordinate (x1,y1,z1,x2,y2,z2,x3,y3,z3).
    !dxidx -> derivatives of the Jacobi coordinates with respect to cartesians

    !Also, a 3-vector containing the masses of the atoms is required. This is because the Jacobi
    !coordinates reference the centre of mass between atom1 and atom2.
    !m -> masses of the 3 atoms

    implicit none
    real*8, parameter   :: PI = 3.141592653589793238462643383279502884197d0
    real*8, intent(in)  :: x(9)
    real*8, intent(in)  :: m(3)
    real*8, intent(out) :: xi(3)
    real*8, intent(out) :: dxidx(3,9)
    real*8::  x12cm(3),dalphadx2(3),dalphadx12cm(3),dalphadx3(3)

    !distance of atom1 and atom2 (Jacobi coordinate r)
    xi(1)  = distance(x(1:3),x(4:6))

    !centre of mass of atom1 and atom2 (needed to calculate bigR)
    x12cm  = (m(1)*x(1:3)+m(2)*x(4:6))/(m(1)+m(2))

    !distance of atom3 and centre of mass of atom1 and atom2 (Jacobi coordinate bigR)
    xi(2)  = distance(x12cm,x(7:9))

    !Derivatives of the Jacobi coordinates with respect to the cartesian coordinates
    !dr/dx
    dxidx(1,1:3) =  (x(1:3)-x(4:6))/xi(1)
    dxidx(1,4:6) = -dxidx(1,1:3)
    dxidx(1,7:9) =  0.d0

    !dR/dx
    dxidx(2,1:3) = (x12cm(1:3)-x(7:9))/xi(2)*m(1)/(m(1)+m(2))
    dxidx(2,4:6) = (x12cm(1:3)-x(7:9))/xi(2)*m(2)/(m(1)+m(2))
    dxidx(2,7:9) = (x(7:9)-x12cm(1:3))/xi(2)

    !calculate Jacobi coordinate alpha and derivatives needed to get the derivatives of
    !alpha with respect to cartesian coordinates (all in radians!!!)
    call angle(x(4:6),x12cm(1:3),x(7:9),xi(3),dalphadx2,dalphadx12cm,dalphadx3)

    !calculate the derivatives of alpha with respect to cartesian coordinates
    dxidx(3,1:3) = dalphadx12cm*m(1)/(m(1)+m(2))
    dxidx(3,4:6) = dalphadx12cm*m(2)/(m(1)+m(2)) + dalphadx2
    dxidx(3,7:9) = dalphadx3

    !transform the derivatives of alpha and alpha itself from radians
    !to degrees
    dxidx(3,1:9) = dxidx(3,1:9)*180.d0/PI
    xi(3)        = xi(3)*180.d0/PI

    return
end subroutine cartesian2jacobi

subroutine angle(a,b,c,phi,dphida,dphidb,dphidc)
!This subroutine calculates the defined by the points a,b,c and the derivative of the angle
!with respect to these three points (all in radians)
    implicit none
    real*8,intent(in) ::a(3),b(3),c(3)
    real*8,intent(out)::phi
    real*8,intent(out),optional::dphida(3),dphidb(3),dphidc(3)
    real*8 :: y(3),z(3),y2,z2,ny,nz,yz,nynz,y0z0
    real*8 :: dcosphidy(3),dcosphidz(3),dcosdphi,dphidcos
    real*8 :: dphidy(3),dphidz(3)
    ! y=a-b, z=c-b
    y   =  a-b
    z   =  c-b
    ! y2, z2
    y2  = sum(y**2)
    z2  = sum(z**2)
    ! abs(y), abs(z)
    ny  = dsqrt(y2)
    nz  = dsqrt(z2)
    ! yz
    yz  = sum(y*z)
    ! abs(y)abs(z)
    nynz =ny*nz
    ! y0*z0

    y0z0=   yz/nynz

    y0z0=   min(1d0,max(-1d0,y0z0))         !=cosphi
    phi =   dacos(y0z0)

    if (.not.present(dphida).or..not.present(dphidb).or..not.present(dphidc)) return

    ! calculate derivatives
    ! y=a-b, z=c-b
    dcosphidy(1:3)=(z(1:3)-y(1:3)/y2*yz)/nynz
    dcosphidz(1:3)=(y(1:3)-z(1:3)/z2*yz)/nynz
    ! dcosdphi
    dcosdphi = -dsin(phi)
    ! dphidcos

    !THIS WAS ADDED BY OLIVER TO CIRCUMVENT DIVISION BY ZERO!!! IMPORTANT!!!
    if(dabs(dcosdphi) < epsilon(0.d0)) dcosdphi = epsilon(0.d0)

    dphidcos =1d0/dcosdphi
    !print*, "dphidcos", dphidcos

    ! dphidy dphidz
    dphidy(1:3) = dphidcos*dcosphidy
    dphidz(1:3) = dphidcos*dcosphidz
    ! dphida= dphidy*dyda = dphidy
    dphida =  dphidy
    ! dphidc= dphidz*dzdc = dphidz
    dphidc =  dphidz
    ! dphida= dphidy*dydb + dphidz*dzdb = - dphidy - dphidz
    dphidb = -dphida-dphidc

    return
end subroutine angle

real*8 function distance(a,b)
    implicit none
    !real*8 ::distance
    real*8,intent(in) ::a(3),b(3)
    distance=dsqrt(sum((a-b)*(a-b)))
end function distance

subroutine calc_weights(w,w0,dw0dr,dwdr,dwdw0,r)
    implicit none
    real*8, dimension(3),   intent(in)  :: r
    real*8, dimension(3),   intent(out) :: w,w0,dw0dr
    real*8, dimension(3,3), intent(out) :: dwdr
    real*8, dimension(3,3), intent(out) :: dwdw0

    real*8, dimension(3), save :: w_save = (/1.d0,0.d0,0.d0/) !this is a safety measure, so that we never get w=0 for all weights!

    real*8 :: sumw0

    !for loops
    integer i

    do i=1,3
        call switchfac(r(i),w0(i),dw0dr(i))
    end do
    sumw0 = sum(w0)
    !this is implemented to prevent division by zero in case we get full atomization
    if(sumw0 < epsilon(0.d0)) sumw0 = 10*epsilon(0.d0)

    !calculate the normalized weights
    w = w0/sumw0

    !check if we have the unfortunate case of all weights being 0. If yes, we load the weights from the previous step.
    if((w(1) == 0.d0).and.(w(2) == 0.d0).and.(w(3) == 0.d0)) then
        w = w_save
    end if

    !store old weights
    w_save = w

    !calculate derivatives of the normalized weights with respect to all different r
    dwdr(1,1)  = (dw0dr(1)*sumw0 - w0(1)*dw0dr(1))/(sumw0**2)
    dwdr(1,2)  = (-w0(1)*dw0dr(2))/(sumw0**2)
    dwdr(1,3)  = (-w0(1)*dw0dr(3))/(sumw0**2)

    dwdr(2,1)  = (-w0(2)*dw0dr(1))/(sumw0**2)
    dwdr(2,2)  = (dw0dr(2)*sumw0 - w0(2)*dw0dr(2))/(sumw0**2)
    dwdr(2,3)  = (-w0(2)*dw0dr(3))/(sumw0**2)

    dwdr(3,1)  = (-w0(3)*dw0dr(1))/(sumw0**2)
    dwdr(3,2)  = (-w0(3)*dw0dr(2))/(sumw0**2)
    dwdr(3,3)  = (dw0dr(3)*sumw0 - w0(3)*dw0dr(3))/(sumw0**2)

    dwdw0(1,1) = (sumw0-w0(1))/(sumw0**2)
    dwdw0(1,2) = (-w0(1))/(sumw0**2)
    dwdw0(1,3) = (-w0(1))/(sumw0**2)

    dwdw0(2,1) = (-w0(2))/(sumw0**2)
    dwdw0(2,2) = (sumw0-w0(2))/(sumw0**2)
    dwdw0(2,3) = (-w0(2))/(sumw0**2)

    dwdw0(3,1) = (-w0(3))/(sumw0**2)
    dwdw0(3,2) = (-w0(3))/(sumw0**2)
    dwdw0(3,3) = (sumw0-w0(3))/(sumw0**2)

    return
end subroutine calc_weights

subroutine switchfac(x,f,dfdx)
!This is the subroutine to calculate the switching factors
  implicit none

  !input
  real*8, intent(in) :: x

  !output
  real*8, intent(out) :: f
  real*8, intent(out), optional :: dfdx

  !local
  !####CHANGE CUTOFF FOR SWITCHING FUNCTION HERE####
  real*8, parameter :: dx = 1.d0 !determines the "cutoff" of the switching
  real*8, parameter :: a  = 4.d0 !determines plateau of switching function

!HERE THE SWITCHING FUNCTION IS SPECIFIED. BE SURE TO ALSO CHANGE THE DERIVATIVE
!SHOULD YOU CHANGE IT!!!

!new function
  f= dexp(-(x/dx)**a)

  if (present(dfdx))  &
        dfdx= -(a/x)*f*(x/dx)**a

end subroutine

end module utility_conversion

!*****************************************************************************************
!    EVERYTHING BETWEEN THESE *** MARKERS WAS ADDED! EVERYTHING ELSE IN THIS SUBROUTINE IS
!    VANILLA CHARMM CODE! YOU SHOULD BE ABLE TO RETURN TO VANILLA CODE BY COMMENTING ALL
!    THE STUFF BETWEEN THESE MARKERS OUT. IMPORTANT: UNCOMMENT EU=0.0 LINE RIGHT AFTER
!    THE VARIABLE DECLARATIONS IF YOU WANT VANILLA CHARMM CODE (THIS WAS THERE ORIGINALLY)
!*****************************************************************************************
module usermod
  logical :: printe_flag = .false., printe_off = .false.
  integer :: iuene

contains

SUBROUTINE USERSB
  !
  !     THIS DOES NOTHING SAVE TELL USER THAT HE CALLED A NULL PROGRAM.
  !
  !     Author: Robert Bruccoleri
  !
  use chm_kinds
!!!  use stream
!!!  use comand
!!!  use string
  implicit none
  !
!!!  CALL WRNDIE(1,'<USERSB>','USERSB CALLED. NO ACTION TAKEN.')
  RETURN
END SUBROUTINE USERSB

SUBROUTINE USERE(EU,X,Y,Z,DX,DY,DZ,QECONT,ECONT,NATOMX)
  !
  !     THE USER ENERGY ROUTINE. DOES NOTHING IN THE NORMAL SYSTEM
  !     EXCEPT SET EU TO ZERO. QECONT IS A FLAG WHICH WILL BE SET TO 1
  !     WHEN THE ROUTINE IS CALLED IN THE QECONTIS SECTION. INDIVIDUAL
  !     ATOM USER ENERGIES ARE THEN RETURNED IN ECONT, AND THE DERIVATIVE
  !     ARRAYS SHOULD NOT BE ACCESSED.
  !
  !     EU   - User energy to be returned
  !     X,Y,Z - Coordinates for energy evaluation
  !     DX,DY,DZ - Forces. Must be modified. Append (dE/dX,...)
  !     QECONT - Flag for analysis (0-no analysis,>0=analysis)
  !     ECONT(NATOMX) - Analysis array to be filled if QECONT>0.
  !     NATOMX - Number of atoms
  !
  !     Author: Robert Bruccoleri
  !
  use chm_kinds
!*****************************************************************************************
! BEGIN OF MODIFICATIONS
!*****************************************************************************************
  use CustomEnergy ,&
      only: Epot, dEdR, dEdVdW, dEdalpha, adEdR, adEdVdw, adEdalpha
  use utility_conversion

!*****************************************************************************************
! END OF MODIFICATIONS
!*****************************************************************************************
  implicit none
  real(chm_real) EU
  INTEGER NATOMX
  real(chm_real) X(NATOMX),Y(NATOMX),Z(NATOMX)
  real(chm_real) DX(NATOMX),DY(NATOMX),DZ(NATOMX)
  LOGICAL QECONT
  real(chm_real) ECONT(NATOMX)
  !
  INTEGER I
  !
  !EU=0.0  !***THIS WAS ORIGINALLY IN CHARMM, BUT I COMMENTED OUT TO CONTINUE DECLARATIONS

!*****************************************************************************************
! BEGIN OF MODIFICATIONS
!*****************************************************************************************

  !loop variable (integer i is already defined by standard charmm code)
  integer j

  !conversion from eV to kcal/mol
  real*8, parameter :: ev2kcalmol = 23.06035d0

  !Array that stores masses. This is needed for some things like calculating the centre of
  !mass, needed to calculate Jacobi coordinates. YOU NEED TO CHANGE THIS WHERE IT'S DEFINED!
  real*8, dimension(NATOMX)  :: mass

  !Output coordinates (Jacobi)
  !1st index: surface
  !2nd index: Jacobi coordinate (r, bigR, alpha)
  real*8, dimension(3,3) :: jacCoord

  !Array for the derivatives of Jacobi coordinates with respect to the cartesian coordinates
  !1st index: surface
  !2nd index: Jacobi coordinate (r,bigR,alpha)
  !3rd index: cartesian coordinate (x1,y1,z1,x2,y2,z2,x3,y3,z3)
  real*8, dimension(3,3,9) :: dJacdCart

  !Array for the derivatives of the potential with respect to the Jacobi coordinates
  !1st index: surface
  !2nd index: Jacobi coordinate (r,bigR,alpha)
  real*8, dimension(3,3) :: dEdJac

  !All this is just needed for the PES switching routine
  !weights for the 3 surfaces, w0: unnormalized, w: normalized
  real*8, dimension(3)   :: w0,w
  !derivatives of raw (unnormalized) weights with respect to r
  real*8, dimension(3)   :: dw0dr
  !derivatives of weight j with respect to r_i (1st index j, 2nd index i)
  real*8, dimension(3,3) :: dwdr
  !derivatives of weight j with respect to raw weight i (1st index j, 2nd index i)
  real*8, dimension(3,3) :: dwdw0
  !derivatives of weight j with respect to cart. coord. i (1st index j, 2nd index i)
  real*8, dimension(3,9) :: dwjdxi
  !derivatives of potential j with respect to cart. coord. i (1st index j, 2nd index i)
  real*8, dimension(3,9) :: dEjdxi
  !temporary array that stores either dwjdxi or dEjdxi, because I need to swap back coordinates
  !for surface 2 and 3!
  real*8, dimension(9) :: ddxi
  !potential energies on the "pure" surfaces
  real*8, dimension(3)   :: Esurf

!-------------------------------------CHANGE HERE-------------------------------------
! If this value is set to .true., reactive MD simulations are performed (the PESs are switched)
! dynamically. If it is set to .false., the simulations will be performed on PES 1 only (bond
! dissociation of the diatomic is then not possible).
  logical :: use_surface_switching = .true.
!-------------------------------------------------------------------------------------

  !####CHOOSE HERE HOW THE DERIVATIVES OF THE PES SHOULD BE CALCULATED!####
  !####Analytical derivatives were found to be superior in this implementation####
  logical :: use_analytical_derivatives = .true.

  !THIS IS AN ERROR CHECK. IF WE DON'T HAVE 3 ATOMS, THIS CODE MAKES NO SENSE AT ALL!
  if(NATOMX /= 3) then
      write(*,*) "WARNING: Number of atoms is not 3."
      write(*,*) "This code is designed for 3-atomic systems ONLY."
      write(*,*) "program was terminated."
      stop
  end if

!-------------------------------------CHANGE HERE-------------------------------------
! Masses of the atoms need to be specified here, because we need to calculate the centre of mass.
! The unit is not important, as long as all masses are given in the same unit.
! The reordering of the masses for the other surfaces is performed automatically.
  mass(1) = 14.007d0  !this corresponds to atom 1
  mass(2) = 15.9994d0 !this corresponds to atom 2
  mass(3) = 14.007d0 !this corresponds to atom 3
!-------------------------------------------------------------------------------------

  call calc_Jacobi_coordinates(X,Y,Z,jacCoord,mass,dJacdCart)
!DEBUG: Jacobi coordinates for all 3 surfaces are calculated fine (was tested)
!and deemed bug-free
!  print*, "Jacobi coordinates: ", "    r    ", "    R    ", "    alpha    "
!  print*, "(surface 1)       : ", jacCoord(1,1), jacCoord(1,2), jacCoord(1,3)
!  print*, "(surface 2)       : ", jacCoord(2,1), jacCoord(2,2), jacCoord(2,3)
!  print*, "(surface 3)       : ", jacCoord(3,1), jacCoord(3,2), jacCoord(3,3)

  !print*, "dJacdCart:", dJacdCart

if(use_surface_switching) then
!calculate weights and their respective derivatives etc.
    call calc_weights(w,w0,dw0dr,dwdr,dwdw0,jacCoord(:,1))
else
!give surface 1 the full weight
    w    = 0.d0
    w(1) = 1.d0
end if

!calculate the derivatives of the potential surfaces 1-3 with respect to the Jacobi
!coordinates (r,R,alpha).
 do i=1,3
     !if a weight is 0, we can just set all the derivatives to 0 and skip expensive
     !calculations
     if(w(i) == 0.d0) then
         dEdJac(i,:) = 0.d0
         cycle
     end if

     if(.not.use_analytical_derivatives) then
     !do it numerically
         dEdJac(i,1) = dEdR(jacCoord(i,1),jacCoord(i,2),jacCoord(i,3),i)
         dEdJac(i,2) = dEdVdW(jacCoord(i,1),jacCoord(i,2),jacCoord(i,3),i)
         dEdJac(i,3) = dEdalpha(jacCoord(i,1),jacCoord(i,2),jacCoord(i,3),i)
     else
     !do it analytically
         dEdJac(i,1) = adEdR(jacCoord(i,1),jacCoord(i,2),jacCoord(i,3),i)
         dEdJac(i,2) = adEdVdW(jacCoord(i,1),jacCoord(i,2),jacCoord(i,3),i)
         dEdJac(i,3) = adEdalpha(jacCoord(i,1),jacCoord(i,2),jacCoord(i,3),i)
     end if
 end do

  !if we need to switch surfaces, we do it like this
  if(use_surface_switching) then
      !calculate energies on "pure" surfaces
      do j=1,3
          !if a weight is 0, we can just set the energy to 0 and skip expensive calculations
          if(w(j) == 0.d0) then
              Esurf(j) = 0.d0
              cycle
          end if
          Esurf(j) = Epot(jacCoord(j,1),jacCoord(j,2),jacCoord(j,3),j)
      end do
      !Assign mixed energy value:
      EU = real((Esurf(1)*w(1) + Esurf(2)*w(2) + Esurf(3)*w(3))*ev2kcalmol,chm_real)

      !calculate all 18 dwjdxi and dEjdxi
      do j=1,3
          do i=1,9
              dEjdxi(j,i) = sum(dEdJac(j,:)*dJacdCart(j,:,i))

              !calculate dwjdxi by using the raw weight derivatives
              dwjdxi(j,i) = dwdw0(j,1)*dw0dr(1)*dJacdCart(1,1,i) + dwdw0(j,2)*dw0dr(2)*dJacdCart(2,1,i) &
                           +dwdw0(j,3)*dw0dr(3)*dJacdCart(3,1,i)
              !print*, "dEjdxi: ", dEjdxi(j,i)
          end do
      end do

     !Assign derivatives:
     do i=1,3
         DX(i) = real(sum(w*dEjdxi(:,1+(i-1)*3) + dwjdxi(:,1+(i-1)*3)*Esurf)*ev2kcalmol,chm_real)
         DY(i) = real(sum(w*dEjdxi(:,2+(i-1)*3) + dwjdxi(:,2+(i-1)*3)*Esurf)*ev2kcalmol,chm_real)
         DZ(i) = real(sum(w*dEjdxi(:,3+(i-1)*3) + dwjdxi(:,3+(i-1)*3)*Esurf)*ev2kcalmol,chm_real)
     end do

  !if not, we just consider the first surface and that's it
  else
      !Assign energy:
      EU = real(Epot(jacCoord(1,1),jacCoord(1,2),jacCoord(1,3),1)*ev2kcalmol,chm_real)

      !Assign derivatives:
      do i=1,3
          DX(i) = real((dEdJac(1,1)*dJacdCart(1,1,1+(i-1)*3) + dEdJac(1,2)*dJacdCart(1,2,1+(i-1)*3) &
                   + dEdJac(1,3)*dJacdCart(1,3,1+(i-1)*3))*ev2kcalmol,chm_real)
          DY(i) = real((dEdJac(1,1)*dJacdCart(1,1,2+(i-1)*3) + dEdJac(1,2)*dJacdCart(1,2,2+(i-1)*3) &
                   + dEdJac(1,3)*dJacdCart(1,3,2+(i-1)*3))*ev2kcalmol,chm_real)
          DZ(i) = real((dEdJac(1,1)*dJacdCart(1,1,3+(i-1)*3) + dEdJac(1,2)*dJacdCart(1,2,3+(i-1)*3) &
                   + dEdJac(1,3)*dJacdCart(1,3,3+(i-1)*3))*ev2kcalmol,chm_real)
      end do
  end if

!*****************************************************************************************
! END OF MODIFICATIONS
!*****************************************************************************************

  IF(QECONT) THEN
     DO I=1,NATOMX
        ECONT(I)=0.0
     ENDDO
  ENDIF
  RETURN
END SUBROUTINE USERE

SUBROUTINE USRACM(NATOMX,X,Y,Z,DX,DY,DZ,QECONT,ECONT,ICALL)
  !
  !     THE USER ACCUMULATION ROUTINE. DOES NOTHING IN THE NORMAL SYSTEM.
  !     This routine is called every time the energy is evaluated.
  !     The ICALL integer tells whether this is a "real" step for
  !     minimization or dynamics.
  !
  !     X,Y,Z    - Coordinates for energy evaluation
  !     DX,DY,DZ - Forces. Must be modified. Append (dE/dX,...)
  !     ICALL    - ECALLS increment
  !
  !     Author: B. Brooks
  !
  use chm_kinds
  implicit none
  INTEGER NATOMX
  real(chm_real) X(NATOMX),Y(NATOMX),Z(NATOMX)
  real(chm_real) DX(NATOMX),DY(NATOMX),DZ(NATOMX)
  LOGICAL QECONT
  real(chm_real) ECONT(*)
  INTEGER ICALL
  !
  RETURN
END SUBROUTINE USRACM

SUBROUTINE USERNM(IUSER,X,Y,Z,XNORMA,YNORMA,ZNORMA,NATOMX)
  !
  !     THIS ROUTINE IS USED TO SETUP A GUESS NORMAL MODE, OR A MOTION
  !     OF INTEREST TO BE ANALYSED, OR APPENDED TO THE COORDINATE SET.
  !     THE CALLING SEQUENCE IS 3 ARRAYS WHICH ARE TO BE FILLED
  !     WITH COORDINATE DISPLACEMENTS. (I.E. DONT MASS WEIGHT THEM)
  !     SEE THE DOCUMENTATION OF VIBRAN FOR FURTHER DETAILS
  !
  !     IUSER  - Code for which function to use. This is only important
  !               if more than one user mode is specified.
  !     X,Y,Z   - Reference coordinates
  !     XNORMA,YNORMA,ZNORMA - Mode vector to be filled
  !     NATOMX  - Number of atoms
  !
  !     Author: Bernie Brooks
  !
  use chm_kinds
  implicit none
  INTEGER IUSER
  INTEGER NATOMX
  real(chm_real) X(NATOMX),Y(NATOMX),Z(NATOMX)
  real(chm_real) XNORMA(NATOMX),YNORMA(NATOMX),ZNORMA(NATOMX)
  !
  INTEGER I
  !
  !     The default user mode is the radius of gyration motion about
  !     the origin.
  !
  DO I=1,NATOMX
     XNORMA(I)=X(I)
     YNORMA(I)=Y(I)
     ZNORMA(I)=Z(I)
  ENDDO
  !
 !!! CALL WRNDIE(1,'<USERNM>', &
 !!!       'NO ROUTINE PROVIDED, RGYR MODE RETURNED')
  RETURN
END SUBROUTINE USERNM

SUBROUTINE USRSEL(NTAGS,FLAGS,X,Y,Z,QCOOR)
  !
  !     THIS ROUTINE ALLOWS A USER TO SELECT ATOMS.
  !
  !     NTAGS - number of entries (atoms)
  !     FLAGS(NTAGS) - array to hold selection values
  !     X,Y,Z  - coordinates
  !     QCOOR  - logical flag specifying that coordinates are present
  !              If .FALSE., then the coordinates should not be accessed.
  !
  !     If an atom is selected, set FLAGS value to be nonzero.
  !
  !
  use chm_kinds
  implicit none
  INTEGER NTAGS
  INTEGER FLAGS(NTAGS)
  real(chm_real) X(*),Y(*),Z(*)
  LOGICAL QCOOR
  !
  INTEGER I
  !
  !!!  CALL WRNDIE(1,'<USRSEL>','NO USER SELECTION SPECIFIED')
  !
  !     THE DEFAULT USER SELECTION IS TO INCLUDE EVERYTHING
  DO I=1,NTAGS
     FLAGS(I)=1
  ENDDO
  RETURN
END SUBROUTINE USRSEL

SUBROUTINE USRTIM(SERVAL,QAT,NQ,ITIME, &
     NATOMX,X,Y,Z,XREF,YREF,ZREF,NSKIP,DELTA,TVAL,ISLCT)
  !
  !     This routine allows the user to specify a time series
  !     for use in CORREL.
  !
  !     SERVAL  - Value for time series specified in the ENTER command.
  !                May be used for distinguishing time series, or for any
  !                other purpose.
  !     QAT(NQ)- List of atoms that were specified in the ENTER command
  !     NQ     - Number of atoms specified in the ENTER command
  !     ITIME  - Which time step is currenlty being processed
  !     NATOMX - Number of atoms
  !     X,Y,Z  - Coordinates for current time step
  !     XREF,YREF,ZREF - Reference coordinates for time series
  !     DELTA  - Time interval between steps in picoseconds.
  !     TVAL   - Time series value returned
  !     ISLCT  - The first atom selection array from the TRAJ command
  !
  use chm_kinds
  implicit none
  !
  real(chm_real) SERVAL
  INTEGER ITIME,NATOMX,NQ
  INTEGER QAT(NQ)
  real(chm_real) X(NATOMX),Y(NATOMX),Z(NATOMX)
  real(chm_real) XREF(NATOMX),YREF(NATOMX),ZREF(NATOMX)
  INTEGER NSKIP
  real(chm_real) DELTA,TVAL
  INTEGER ISLCT(*)
  !
 !!!  CALL WRNDIE(1,'<USECOR>','NO USER TIME SERIES SPECIFIED')
  !
  !     THE DEFAULT USER TIME SERIES IS SIMPLY THE TIME
  TVAL=ITIME/DELTA
  RETURN
END SUBROUTINE USRTIM

SUBROUTINE USRINI
  !
  !     This routine allows the user to specify a startup procedure.
  !     This routine is invoked at the beginning of each CHARMM run.
  !
!BEGIN************************************************************************************
  use CustomEnergy, &
      only : initialize_PES
!END**************************************************************************************
  use chm_kinds
  implicit none
  !
!BEGIN************************************************************************************
  call initialize_PES()
!END**************************************************************************************
  RETURN
END SUBROUTINE USRINI

SUBROUTINE USPAFL(I,XX,YY,ZZ,XY,XZ,YZ, &
     XNORM,YNORM,ZNORM,NATOM,ISLCT)
  !
  !  This routine processes the user specific principal axis
  !  fluctuation code.  See documentation for details.
  !
  use chm_kinds
  implicit none
  INTEGER I,NATOM
  real(chm_real) XX(*),YY(*),ZZ(*),XY(*),XZ(*),YZ(*)
  real(chm_real) XNORM(*),YNORM(*),ZNORM(*)
  INTEGER ISLCT(*)
  !
  RETURN
END SUBROUTINE USPAFL

SUBROUTINE USER_RNGSPEC
  ! specification for USER random number generator

  IMPLICIT NONE

  RETURN
END SUBROUTINE USER_RNGSPEC

end module usermod


submodule (real_transform_routines) real_initialization_routines

contains

    module subroutine rfft1i(n, wsave, lensav, ierror)
        !
        !  rfft1i: initialization for rfft1b and rfft1f.
        !
        !  purpose:
        !
        !  rfft1i initializes array wsave for use in its companion routines
        !  rfft1b and rfft1f.  the prime factorization of n together with a
        !  tabulation of the trigonometric functions are computed and stored
        !  in array wsave.  separate wsave arrays are required for different
        !  values of n.
        !
        !  parameters:
        !
        !  integer n, the length of the sequence to be
        !  transformed.  the transform is most efficient when n is a product of
        !  small primes.
        !
        !  real wsave(lensav), containing the prime factors of
        !  n and also containing certain trigonometric values which will be used in
        !  routines rfft1b or rfft1f.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least n + int(log(real(n))) + 4.
        !
        !  integer ierror, error_flag.
        !  0, successful exit;
        !  2, input parameter lensav not big enough.
        !
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer (ip), intent (in)  :: n
        real (wp),    intent (out) :: wsave(lensav)
        integer (ip), intent (in)  :: lensav
        integer (ip), intent (out) :: ierror
        !--------------------------------------------------------------

        if (lensav < n + int(log(real(n, kind=wp) )/log(TWO)) + 4) then
            ierror = 2
            call fft_error_handler('rfft1i ', 3)
        else
            ierror = 0
        end if

        if (n /= 1) call rffti1(n, wsave(1), wsave(n+1))

    end subroutine rfft1i

    module subroutine rfft2i(l, m, wsave, lensav, ierror)
        !
        ! rfft2i: initialization for rfft2b and rfft2f.
        !
        !  purpose:
        !  rfft2i initializes real array wsave for use in its companion routines
        !  rfft2f and rfft2b for computing the two-dimensional fast fourier
        !  transform of real data.  prime factorizations of l and m, together with
        !  tabulations of the trigonometric functions, are computed and stored in
        !  array wsave.  rfft2i must be called prior to the first call to rfft2f
        !  or rfft2b.  separate wsave arrays are required for different values of
        !  l or m.
        !
        !
        !  integer l, the number of elements to be transformed
        !  in the first dimension.  the transform is most efficient when l is a
        !  product of small primes.
        !
        !  integer m, the number of elements to be transformed
        !  in the second dimension.  the transform is most efficient when m is a
        !  product of small primes.
        !
        !  integer lensav, the number of elements in the wsave
        !  array.  lensav must be at least l + m + int(log(real(l)))
        !  + int(log(real(m))) + 8.
        !
        !  real wsave(lensav), containing the prime factors
        !  of l and m, and also containing certain trigonometric values which
        !  will be used in routines rfft2b or rfft2f.
        !
        !  integer ier, error_flag.
        !  0, successful exit;
        !  2, input parameter lensav not big enough;
        !  20, input error returned by lower level routine.
        !
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer (ip), intent (in)  :: l
        integer (ip), intent (in)  :: m
        real (wp),    intent (out) :: wsave(lensav)
        integer (ip), intent (in)  :: lensav
        integer (ip), intent (out) :: ierror
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer (ip) :: local_error_flag, lwsav, mmsav, mwsav
        !--------------------------------------------------------------

        ! initialize error flag
        ierror = 0

        !
        !==> verify lensav
        !
        lwsav = l+int(log(real(l, kind=wp) )/log(TWO)) + 4
        mwsav = 2*m+int(log(real(m, kind=wp) )/log(TWO)) + 4
        mmsav = m+int(log(real(m, kind=wp) )/log(TWO)) + 4

        if (lensav < lwsav+mwsav+mmsav) then
            ierror = 2
            call fft_error_handler('rfft2i', 4)
            return
        end if

        call rfftmi(l, wsave(1), lwsav, local_error_flag)

        if (local_error_flag /= 0) then
            ierror = 20
            call fft_error_handler('rfft2i',-5)
            return
        end if

        call cfftmi(m, wsave(lwsav+1), mwsav, local_error_flag)

        if (local_error_flag /= 0) then
            ierror = 20
            call fft_error_handler('rfft2i',-5)
            return
        end if

        call rfftmi(m, wsave(lwsav+mwsav+1), mmsav, local_error_flag)

        if (local_error_flag /= 0) then
            ierror = 20
            call fft_error_handler('rfft2i',-5)
            return
        end if

    end subroutine rfft2i

    module subroutine rfftmi(n, wsave, lensav, ierror)
        !
        ! rfftmi: initialization for rfftmb and rfftmf.
        !
        !  purpose:
        !
        !  rfftmi initializes array wsave for use in its companion routines
        !  rfftmb and rfftmf.  the prime factorization of n together with a
        !  tabulation of the trigonometric functions are computed and stored
        !  in array wsave.  separate wsave arrays are required for different
        !  values of n.
        !
        !  input
        !
        !  integer n, the length of each sequence to be
        !  transformed.  the transform is most efficient when n is a product of
        !  small primes.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least n + int(log(real(n))) + 4.
        !
        !  output
        !  real wsave(lensav), work array containing the prime
        !  factors of n and also containing certain trigonometric
        !  values which will be used in routines rfftmb or rfftmf.
        !
        !  integer ierror, error_flag.
        !  0, successful exit;
        !  2, input parameter lensav not big enough.
        !
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer (ip), intent (in)  :: n
        integer (ip), intent (in)  :: lensav
        real (wp),    intent (out) :: wsave(lensav)
        integer (ip), intent (out) :: ierror
        !--------------------------------------------------------------

        !
        !==> Check validity of input arguments
        !
        if (lensav < n + int(log(real(n, kind=wp) )/log(TWO)) + 4) then
            ierror = 2
            call fft_error_handler('rfftmi ', 3)
            return
        else
            ierror = 0
        end if

        !
        !==> Perform transform
        !
        if (n /= 1) call mrfti1(n, wsave(1), wsave(n+1))

    end subroutine rfftmi

    subroutine rffti1(n, wa, fac)
        !
        !  Parameters:
        !
        !  input
        !
        ! n, the number for which factorization
        !  and other information is needed.
        !
        !  output
        ! wa(n), trigonometric information.
        !
        !  output
        !
        !  fac(15), factorization information.
        !  fac(1) is n, fac(2) is nf, the number of factors, and fac(3:nf+2) are the
        !  factors.
        !
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer (ip), intent (in)  :: n
        real (wp),    intent (out) :: fac(15)
        real (wp),    intent (out) :: wa(n)
        !--------------------------------------------------------------
        ! Local variables
        !--------------------------------------------------------------
        integer (ip)            :: i, ib, ido, ii, iip, ipm, is
        integer (ip)            :: j, k1, l1, l2, ld
        integer (ip)            :: nf, nfm1, nl, nq, nr, ntry
        integer (ip), parameter :: NTRYH(*) = [4, 2, 3, 5]
        real (wp),    parameter :: TWO_PI = TWO * acos(-ONE)
        real (wp)               :: arg,  argh, argld, fi
        !--------------------------------------------------------------

        ntry = 0
        nl = n
        nf = 0
        j = 0

        factorize_loop: do
            ! Increment j
            j = j+1

            ! Choose ntry
            if (j <= 4) then
                ntry = NTRYH(j)
            else
                ntry = ntry+2
            end if

            inner_loop: do
                nq = nl/ntry
                nr = nl-ntry*nq
                if (nr < 0) then
                    cycle factorize_loop
                else if (nr == 0) then
                    nf = nf+1
                    fac(nf+2) = ntry
                    nl = nq
                    if (ntry == 2 .and. nf /= 1) then
                        do i=2,nf
                            ib = nf-i+2
                            fac(ib+2) = fac(ib+1)
                        end do
                        fac(3) = 2
                    end if
                    if (nl /= 1) cycle inner_loop
                else
                    cycle factorize_loop
                end if
                exit inner_loop
            end do inner_loop
            exit factorize_loop
        end do factorize_loop

        fac(1) = n
        fac(2) = nf
        argh = TWO_PI/n
        is = 0
        nfm1 = nf-1
        l1 = 1

        if (nfm1 /= 0) then
            do k1=1,nfm1
                iip = int(fac(k1+2), kind=ip)
                ld = 0
                l2 = l1*iip
                ido = n/l2
                ipm = iip-1
                do j=1,ipm
                    ld = ld+l1
                    i = is
                    argld = real(ld, kind=wp) * argh
                    fi = ZERO
                    do ii=3,ido,2
                        i = i+2
                        fi = fi + ONE
                        arg = fi*argld
                        wa(i-1) = cos(arg)
                        wa(i) = sin(arg)
                    end do
                    is = is+ido
                end do
                l1 = l2
            end do
        end if

    end subroutine rffti1

    subroutine mrfti1(n, wa, fac)
        !
        !  input
        !  n, the number for which factorization and
        !  other information is needed.
        !
        !  output
        !   wa(n), trigonometric information.
        !
        !  output
        !  fac(15), factorization information. fac(1) is
        !  n, fac(2) is nf, the number of factors, and fac(3:nf+2) are the factors.
        !
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer (ip), intent (in)  :: n
        real (wp),    intent (out) :: wa(n)
        real (wp),    intent (out) :: fac(15)
        !--------------------------------------------------------------
        ! Local variables
        !--------------------------------------------------------------
        integer (ip)            :: i, ib, ido, ii, iip, ipm, is
        integer (ip)            :: j, k1, l1, l2, ld
        integer (ip)            :: nf, nfm1, nl, nq, nr, ntry
        integer (ip), parameter :: NTRYH(*) = [4, 2, 3, 5]
        real (wp),    parameter :: TWO_PI = TWO * acos(-ONE)
        real (wp)               :: arg, argh, argld, fi
        !--------------------------------------------------------------

        ntry = 0
        nl = n
        nf = 0
        j = 0

        factorize_loop: do
            ! Increment j
            j = j+1

            ! Choose ntry
            if (j <= 4) then
                ntry = NTRYH(j)
            else
                ntry = ntry+2
            end if

            inner_loop: do
                nq = nl/ntry
                nr = nl-ntry*nq
                if (nr < 0) then
                    cycle factorize_loop
                else if (nr == 0) then
                    nf = nf+1
                    fac(nf+2) = ntry
                    nl = nq

                    if (ntry == 2 .and. nf /= 1) then

                        do i=2,nf
                            ib = nf-i+2
                            fac(ib+2) = fac(ib+1)
                        end do

                        fac(3) = 2

                    end if

                    if (nl /= 1) then
                        cycle inner_loop
                    end if
                else
                    cycle factorize_loop
                end if
                exit inner_loop
            end do inner_loop
            exit factorize_loop
        end do factorize_loop

        fac(1) = n
        fac(2) = nf
        argh = TWO_PI/n
        is = 0
        nfm1 = nf-1
        l1 = 1

        do k1=1,nfm1
            iip = int(fac(k1+2), kind=ip)
            ld = 0
            l2 = l1*iip
            ido = n/l2
            ipm = iip-1

            do j=1,ipm

                ld = ld+l1
                i = is
                argld = real(ld, kind=wp) * argh
                fi = ZERO
                do ii=3,ido,2
                    i = i+2
                    fi = fi + ONE
                    arg = fi*argld
                    wa(i-1) = cos(arg)
                    wa(i) = sin(arg)
                end do
                is = is+ido

            end do
            l1 = l2
        end do

    end subroutine mrfti1

end submodule real_initialization_routines


C$Procedure REGLON ( Regularize longitude intervals )

      SUBROUTINE REGLON ( NIVALS, BOUNDS, MAXN,   NOUT,
     .                    MINLON, MAXLON, OUTBDS, SRCS )

C$ Abstract
C
C     Regularize a set of longitude intervals. The output
C     intervals have their endpoints in ascending order,
C     and all output bounds are in the range MINLON:MAXLON.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     DSKBRIEF
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE 'dsktol.inc'

      INTEGER               NIVALS
      DOUBLE PRECISION      BOUNDS ( 2, NIVALS )
      INTEGER               MAXN
      INTEGER               NOUT
      DOUBLE PRECISION      MINLON
      DOUBLE PRECISION      MAXLON
      DOUBLE PRECISION      OUTBDS ( 2, * )
      INTEGER               SRCS   ( * )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     NIVALS     I   is the number of input longitude intervals.
C     BOUNDS     I   is an array of bounds of the input intervals.
C     MAXN       I   is the maximum number of output intervals.
C     NOUT       O   is the number of output intervals.
C     MINLON     O   is the minimum longitude of all output intervals.
C     MAXLON     O   is the maximum longitude of all output intervals.
C     OUTBDS     O   is an array of output longitude intervals.
C     SRCS       O   is an array mapping output to input intervals.
C
C$ Detailed_Input
C
C     NIVALS     is the number of input longitude intervals.
C
C     BOUNDS     is an array of upper and lower interval bounds.
C                Units are radians.
C
C                The elements
C
C                   BOUNDS(1,I)
C                   BOUNDS(2,I)
C
C                are, respectively, the lower and upper bounds of
C                the Ith interval. The upper bound may be less
C                than the lower bound. If the bounds are equal, they
C                are treated as though the upper bound exceeds the
C                lower bound by 2*pi.
C
C                 Bounds must be in the range
C
C                   [ -2*pi,  2*pi ]
C
C     MAXN       is the maximum number of output intervals that
C                can be returned.
C
C$ Detailed_Output
C
C     NOUT       is the number of output intervals. NOUT is greater
C                than or equal to NIVALS.
C
C     MINLON,
C     MAXLON     are, respectively, lower and upper bounds on
C                the range of the output longitudes.
C
C                   {MINLON, MAXLON}
C
C                is either
C
C                   {0, 2*pi}  or {-pi, pi}
C
C     OUTBDS     is an array of output longitude bounds.
C                Units are radians.
C
C                Each output interval represents a subset of some input
C                interval; the endpoints of an output interval may be
C                shifted by 2*pi relative to the endpoints of the
C                subset.
C
C                Input intervals for which the lower bound is greater
C                than the upper bound are broken up into two output
C                intervals.
C
C                The elements
C
C                   OUTBDS(1,I)
C                   OUTBDS(2,I)
C
C                are, respectively, the lower and upper bounds of
C                the Ith interval. The upper bound is always
C                greater than or equal to the lower bound.
C                Bounds are in the range
C
C                   [MINLON, MAXLON]
C
C
C     SRCS       is an array of indices that map the output intervals
C                to the source input intervals from which they were
C                derived.
C
C$ Parameters
C
C     ANGMRG     See the description in dsktol.inc.
C
C$ Exceptions
C
C     1)  If the output array doesn't have enough room to store
C         the output intervals, the error SPICE(ARRAYTOOSMALL)
C         is signaled.
C
C     2)  Longitudes outside the range
C
C            -2*pi - ANGMRG : 2*pi + ANGMRG
C
C         are not accepted: if such a value is encountered, the
C         error will be diagnosed by a routine in the call tree
C         of this routine.
C
C     3)  If the lower bound of a longitude interval matches the
C         upper bound, the error SPICE(ZEROBOUNDSEXTENT) is
C         signaled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine "regularizes" a set of longitude intervals: it maps
C     them to a set of output longitude intervals that has the same
C     coverage on the unit circle as the input set, such that each of
C     the output intervals has its endpoints in increasing order, and
C     all of the output intervals have their endpoints in a common
C     interval of length 2*pi.
C
C     The set of output intervals has the property that order
C     relationships between endpoints are valid.
C
C     This routine supports coverage gap determination.
C
C$ Examples
C
C     See usage in DSKBRIEF.
C
C$ Restrictions
C
C     1) For use only within program DSKBRIEF.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C
C$ Version
C
C     DSKBRIEF Version 1.0.0, 21-FEB-2017 (NJB)
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      DPMAX
      DOUBLE PRECISION      DPMIN
      DOUBLE PRECISION      DPR
      DOUBLE PRECISION      PI
      DOUBLE PRECISION      TWOPI

      LOGICAL               FAILED
      LOGICAL               RETURN

C
C     Local variables
C
      DOUBLE PRECISION      A
      DOUBLE PRECISION      B
      DOUBLE PRECISION      LB
      DOUBLE PRECISION      LOCLB
      DOUBLE PRECISION      LOCUB
      DOUBLE PRECISION      UB

      INTEGER               I
      INTEGER               NREQ

      IF ( RETURN() ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'REGLON' )

C
C     No output intervals have been found yet.
C
      NOUT = 0

      IF ( NIVALS .EQ. 0 ) THEN

         CALL CHKOUT ( 'REGLON')
         RETURN

      END IF

C
C     Get lower and upper bounds of input values.
C
      MINLON = DPMAX()
      MAXLON = DPMIN()

      DO I = 1, NIVALS

         LB = BOUNDS(1,I)
         UB = BOUNDS(2,I)
C
C        Rectangles of zero longitude extent not allowed.
C
         IF ( LB .EQ. UB ) THEN

            CALL SETMSG ( 'Longitude lower bound # (# degrees) '
     .      //            'equals upper bound.'                  )
            CALL ERRDP  ( '#', LB                                )
            CALL ERRDP  ( '#', LB * DPR()                        )
            CALL SIGERR ( 'SPICE(ZEROBOUNDSEXTENT)'              )
            CALL CHKOUT ( 'REGLON'                               )
            RETURN

         END IF

C
C        Adjust UB if necessary before deciding on the output
C        range.
C
         IF ( UB .LT. LB ) THEN
            UB = UB + TWOPI()
         END IF

         MINLON = MIN( LB, UB, MINLON )
         MAXLON = MAX( LB, UB, MAXLON )

      END DO

C
C     If MAXLON and MINLON lie within the range
C
C        0 - ANGMRG : 2*pi + ANGMRG
C
C     we'll set the output longitudes to lie in the range
C
C        0 : 2*pi
C
C
C     If MAXLON and MINLON lie within the range
C
C        -pi - ANGMRG : pi + ANGMRG
C
C     we'll set the output longitudes to lie in the range
C
C        -pi : pi
C
C
C     We use the latter range if neither of the first two
C     conditions are met.
C
C
      IF (      ( MINLON .GT.  -ANGMRG              )
     .    .AND. ( MAXLON .LT. ( TWOPI() + ANGMRG )  )  ) THEN

         A = 0.D0
         B = TWOPI()

      ELSE
C
C        We arbitrarily pick the output longitude range
C
C           -pi : pi
C
         A = -PI()
         B =  PI()

      END IF

C
C     Set the output values of MINLON and MAXLON.
C
      MINLON = A
      MAXLON = B

C
C     Process each input interval.
C
      DO I = 1, NIVALS

         LB = BOUNDS(1,I)
         UB = BOUNDS(2,I)
C
C        We'll adjust the inputs to ensure they're in range.
C
C        First, make sure we're starting with values in
C        the range [-2*pi, 2*pi].
C
         CALL ZZNRMLON ( LB, UB, ANGMRG, LOCLB, LOCUB )

         IF ( FAILED() ) THEN
            CALL CHKOUT ( 'REGLON' )
            RETURN
         END IF

C
C        Move each output into the range [A, B].
C
         IF ( LOCLB .LT. A ) THEN

            LOCLB = LOCLB + TWOPI()

         ELSE IF ( LOCLB .GT. B ) THEN

            LOCLB = LOCLB - TWOPI()

         END IF

         IF ( LOCUB .LT. A ) THEN

            LOCUB = LOCUB + TWOPI()

         ELSE IF ( LOCUB .GT. B ) THEN

            LOCUB = LOCUB - TWOPI()

         END IF

C
C        Now the bounds are in range, but they may be
C        out of order.
C
         IF ( LOCLB .LT. LOCUB ) THEN
C
C           The bounds are in order. Add the interval to
C           the list of output intervals.
C
            NOUT = NOUT + 1

            IF ( NOUT .GT. MAXN ) THEN
C
C              We're out of room.
C
               CALL SETMSG ( 'Output arrays have room for # '
     .         //            'intervals we have found # '
     .         //            'output intervals so far.'      )
               CALL ERRINT ( '#', MAXN                       )
               CALL ERRINT ( '#', NOUT                       )
               CALL SIGERR ( 'SPICE(ARRAYTOOSMALL)'          )
               CALL CHKOUT ( 'REGLON'                        )
               RETURN

            END IF

            OUTBDS(1,NOUT) = LOCLB
            OUTBDS(2,NOUT) = LOCUB
            SRCS  (  NOUT) = I

         ELSE
C
C           The bounds are in range but out of order.
C           We'll split the input interval into two
C           output intervals.
C
            NREQ = 0

            IF ( A .LT. LOCUB ) THEN
               NREQ = NREQ + 1
            END IF

            IF ( LOCLB .LT. B ) THEN
               NREQ = NREQ + 1
            END IF

            IF ( NOUT+NREQ .GT. MAXN ) THEN
C
C              We're out of room.
C
               CALL SETMSG ( 'Output arrays have room for # '
     .         //            'intervals we have found # '
     .         //            'output intervals so far.'      )
               CALL ERRINT ( '#', MAXN                       )
               CALL ERRINT ( '#', NOUT+NREQ                  )
               CALL SIGERR ( 'SPICE(ARRAYTOOSMALL)'          )
               CALL CHKOUT ( 'REGLON'                        )
               RETURN

            END IF
C
C           The input interval "wraps around" the output boundaries.
C
C           The output intervals extend from A to the upper bound and
C           from the lower bound to B.
C
            IF ( A .LT. LOCUB ) THEN

               NOUT = NOUT + 1

               OUTBDS(1,NOUT) = A
               OUTBDS(2,NOUT) = LOCUB
               SRCS  (  NOUT) = I

            END IF

            IF ( LOCLB .LT. B ) THEN

               NOUT = NOUT + 1

               OUTBDS(1,NOUT) = LOCLB
               OUTBDS(2,NOUT) = B
               SRCS  (  NOUT) = I

            END IF

         END IF

      END DO

      CALL CHKOUT ( 'REGLON' )
      RETURN
      END


subroutine optimum(obs,lambda_obs,e_obs,mobs,lsfarr,p,w,error)

!
!	Optimizes the weights for the observed spectrum and an
!	an estimate of the model parameters (p)
!
!	On a successful ouput (error=0), the weights have been tuned
!	and normalized to npix. error=1 signals a failure to optimize
!	and the original weights are not modified.
!
!	Weights are set proportional to the sensitivity of each pixel i,
!	and `sensitivity' is defined as a linear combination of the
!	derivatives of (flux(i)-obs(i))**2 respecto to each of the
!	parameters p(j). The linear combination may compensate for the
!	overall differences among parameters p(j) in impact on the
!	spectrum.
!
!	chi(i) is defined as chi(i)=(flux(i)-obs(i))**2
!	X(i,j) is defined as abs(@chi(i)/@p(j))
!	The overall `impact' of a parameter p(j) is defined as
!		Ipct(j)=Sum_i X(i,j) = Sum_i abs(@chi(i)/@p(j))
!	The weights are either set to
!		w(i)=sum(j) X(i,j)/Ipct(j)	if Ipct(j) is not terribly
!	different for all parameters (impact=1), or simply to
!		w(i)=sum(j) X(i,j) (impact=0)
!
!	C. Allende Prieto, July 2004
!

use share, only: dp,ndim,nov,indv,npix,probe,nphotpix,photpixels, &
			impact,wphot,nlambda1,winter,lambda_syn,              &
			mlsf,nlsf

implicit none

!input/output
real(dp), intent(in)    ::  obs(nlambda1)    ! vector of observations
real(dp), intent(in)    ::  lambda_obs(nlambda1)  ! vector of wavelengths for observations
real(dp), intent(in)    :: e_obs(nlambda1)        ! vector of uncertainties in observations
real(dp), intent(in)    ::  mobs                 ! mean or median of obs array
real(dp), intent(in)    ::  lsfarr(mlsf,nlsf)    ! lsfarray
real(dp), intent(in)	::	p(ndim)		!estimate of parameters
real(dp), intent(out)   ::  w(nlambda1)      ! weights
integer, intent(out)	::	error		!error flag

!locals
integer			::	i,j,k		 			!counters
real(dp)		::	chi,chi2,chi3	 		!chi(i)=(flux(i)-obs(i))**2
real(dp)		:: 	x(nlambda1,nov)	        !X(i,j)=abs(@chi(i)/p(j))
real(dp)		::	Ipct(nov)	 			!vector of `impacts'
real(dp)		::	p2(ndim),p3(ndim)		!aux param vector
real(dp)		::	flux(nlambda1) 	 !synth flux
real(dp)		::	flux2(nlambda1)	 !aux flux vector
real(dp)		::	flux3(nlambda1)	 !"
real(dp)		::	x2,x3		 !temp storage for elemts. of x

error=1

call flx(p,lambda_obs,e_obs,mobs,lsfarr,flux)

!compute x(i,j)
do j=1,nov
	p2=p
	p3=p
	k=indv(j)
	p2(k)=p(k)+probe(k)
	p3(k)=p(k)-probe(k)
	if (p2(k).gt.0.0_dp.and.p2(k).le.1.0_dp.and. &
		p3(k).gt.0.0_dp.and.p3(k).le.1.0_dp) then
		!we have two solutions and take an average

			call flx(p2,lambda_obs,e_obs,mobs,lsfarr,flux2)
			call flx(p2,lambda_obs,e_obs,mobs,lsfarr,flux2)

			do i=1,nlambda1
				chi=(flux(i)-obs(i))**2
				chi2=(flux2(i)-obs(i))**2
				chi3=(flux3(i)-obs(i))**2
				x2=abs(chi2-chi)/probe(k)
				x3=abs(chi3-chi)/probe(k)
				x(i,j)=(x2+x3)/2.0_dp
			enddo
	else
		if (p2(k).gt.0.0_dp.and.p2(k).le.1.0_dp) then
		!only one solution upstream

			call flx(p2,lambda_obs,e_obs,mobs,lsfarr,flux2)

			do i=1,npix
				chi=(flux(i)-obs(i))**2
				chi2=(flux2(i)-obs(i))**2
				x2=abs(chi2-chi)/probe(k)
				x(i,j)=x2
			enddo

		else
			if (p3(k).gt.0.0_dp.and.p3(k).le.1.0_dp) then
			!only one solution downstream

			call flx(p3,lambda_obs,e_obs,mobs,lsfarr,flux3)

			do i=1,npix
					chi=(flux(i)-obs(i))**2
					chi3=(flux3(i)-obs(i))**2
					x3=abs(chi3-chi)/probe(k)
					x(i,j)=x3
				enddo
			else
				x(i,j)=0.0_dp
			endif
		endif
	endif

enddo

!derive impacts
if (impact.eq.0) then
	Ipct(:)=1.0_dp
else
	do j=1,nov
		Ipct(j)=0.0_dp
		do i=1,npix
			Ipct(j)=Ipct(j)+x(i,j)
		enddo
		write(*,*)j,Ipct(j)
	enddo
endif

!weights
do i=1,nlambda1
	x2=0.0_dp
	do j=1,nov
		if (Ipct(j).gt.0.0_dp) x2=x2+x(i,j)/Ipct(j)
	enddo
	if (x2.gt.0.0_dp) then
		w(i)=x2
		error=0	!at least one weight will be updated
	endif
enddo

!reset photometry
do i=1,nphotpix
	w(photpixels(i))=wphot
	write(*,*)'photometry:',photpixels(i),wphot
enddo

!and normalize weights
w=w/sum(w)*real(npix)

end subroutine optimum


      USE PRIMEBAG	!Gain access to NEXTPRIME and ISPRIME.
      USE BIGNUMBERVB	!Alas, INTEGER*600 is not available.
Calculates the largest "left-truncatable" digit sequence that is a prime number, in various bases.
      INTEGER LBASE,MANY	!Some sizes.
      PARAMETER (LBASE = 17, MANY = 66666)
      INTEGER NS,START(LBASE)	!A list of single-digit prime numbers for starters.
      TYPE(BIGNUM) HORDE(MANY)	!A collection.
      INTEGER N,NH,LH		!Counters for the horde.
      INTEGER L		!The length of the digit sequence.
      INTEGER I,D	!Steppers.
      CHARACTER*42 TEXT	!A scratchpad, for decimal values.
      REAL T0,T1	!In memory of lost time.

      MSG = 6	!I/O unit number for "standard output".
      IF (.NOT.GRASPPRIMEBAG(66)) STOP "Gan't grab my file!"	!Attempt in hope.
      NS = 0	!No starters.
      N = 1	!Start looking for some primes.
    1 N = NEXTPRIME(N)	!Thus skipping non-primes.
      IF (N.LE.LBASE) THEN	!Beyond the limit?
        NS = NS + 1		!No. Count another starter.
        START(NS) = N		!Save its value.
        GO TO 1			!And seek further.
      END IF		!One could insted prepare some values, the primes being well-known.
      WRITE (MSG,2) LBASE,NS,START(1:NS)	!But, parameterisation is easy enough.
    2 FORMAT ("Working in bases 3 to ",I0," there are ",I0,	!Announce the known.
     * " single-digit primes: ",666(I0:", "))	!The : sez stop if the list is exhausted.
      WRITE (MSG,3)		!Produce a heading for the tabular output.
    3 FORMAT (/"Base Digits Count",29X," Maximum Value = (in base)")	!See Format 31.

Chug through the various bases to be used for the numerology.
      CALL CPU_TIME(T0)	!Start the timing.
   10 DO BIGBASE = 3,LBASE	!Not really very BIG bases.
        NH = 0			!The horde is empty.
        DO I = 1,NS		!Prepare the starters for base BIGBASE.
          IF (START(I).GE.BIGBASE) EXIT	!Like, they're single-digits in base BIGBASE which may exceed ten...
          NH = NH + 1			!So, count another in.
          HORDE(NH).DIGIT(1) = START(I)		!Its numerical value.
          HORDE(NH).LAST = 1			!Its digit count. Just one.
        END DO			!On to the next single-digit prime number in BIGBASE.
        L = 1		!The numbers all have one digit.
Consider each starter for extension via another high-order digit, to be placed at DIGIT(L + 1).
   20   L = L + 1	!We're about to add another digit, now at DIGIT(L).
        IF (L.GT.BIGLIMIT) STOP "Too many digits!"	!Hopefully, there's room.
        HORDE(1:NH).LAST = L	!There is. Advise the BIGNUM horde of this.
        LH = NH		!The live ones, awaiting extension.
        DO I = 1,LH	!Step through each starter.
          DO D = 1,BIGBASE - 1	!Consider all possible lead digits.
            HORDE(I).DIGIT(L) = D	!Place it at the start of the number.
            IF (BIGISPRIME(HORDE(I))) THEN	!And if it is a prime, or seems likely to be ...
              IF (NH.GE.MANY) STOP "Too many sequences!"	!Add a sequence.
              NH = NH + 1			!Count in a survivor.
              HORDE(NH).LAST = L		!Its digit count.
              HORDE(NH).DIGIT(1:L) = HORDE(I).DIGIT(1:L)	!Its digits.
            END IF			!So much for persistent primality.
          END DO		!On to the next lead digit.
        END DO		!On to the next starter.
Check for added entries and compact the collection if there are some.
        N = NH - LH		!The number of entries added to the horde.
        IF (N.GT.0) THEN	!Were there any?
          DO I = 1,MIN(LH,N)		!Yes. Overwrite the starters.
            HORDE(I).LAST = HORDE(NH).LAST	!From the tail end of the horde.
            HORDE(I).DIGIT(1:L) = HORDE(NH).DIGIT(1:L)	!Copying only the live digits.
            NH = NH - 1				!One snipped off.
          END DO			!Thus fill the gap at the start.
          NH = N			!The new horde count.
          GO TO 20			!See how it goes.
        END IF			!So much for further progress.
Cast forth the mostest of the starters.
   30   HORDE(1:NH).LAST = L - 1	!The testing involved an extra digit, which was not accepted.
        L = 1		!Now go looking for the mostest of the survivors.
        DO I = 2,NH	!By comparing all the rest.
          IF (BIGSIGN(HORDE(L),HORDE(I)).LT.0) L = I	!Consider A - B.
        END DO		!On to the next.
        CALL BIGTEN(HORDE(L),TEXT)	!Get a decimal digit string.
        WRITE (MSG,31) BIGBASE,HORDE(L).LAST,NH,TEXT	!Some auxiliary details.
   31   FORMAT (I4,I7,I6,1X,A," = ",$)			!See Format 3.
        CALL BIGWRITE(MSG,HORDE(L))		!The number at last!
        WRITE (MSG,*)				!Finish the line.
      END DO		!On to the next base.
      CALL CPU_TIME(T1)	!Completed the run.

Closedown.
  200 WRITE (MSG,201)	!First, some statistics.
  201 FORMAT (/,"The MR prime test makes a series of trials, "
     1 "stopping early",/'only when a "definitely composite" ',
     2 "result is encountered.")
      WRITE (MSG,202) "Trial",(I,I = 1,BIGMRTRIALS)	!Roll the trial number.
      WRITE (MSG,202) "Count",BIGMRCOUNT		!Now the counts.
  202 FORMAT (A6,": ",666I8)	!This should do.
      WRITE (MSG,*) "CPU time:",T1 - T0	!The cost.
      END	!Simple enough.