! Written by Ulf Saalmann

MODULE spaic
  IMPLICIT NONE

  ! Global parameters
  double precision, parameter :: pi = 3.141592653589793238462
  integer :: npara, jr, nr
  double precision :: rclus = 14.478
  double precision :: drclus = 0.9
  double precision :: vclus = 0.226
  double precision :: fluc = 0.3
  integer :: lin = 0 ! s
  integer :: kin = 1 ! 1
  integer :: dl  = 1 ! l -> l+1
  integer :: nw = 100 ! num frequencies
  double precision :: wmin = 0.2
  double precision :: wmax = 2.2
  double precision, dimension(:), allocatable :: para

  ! hard-wired parameter
  integer :: jpot=1
  double precision :: dr = 0.05, rmax = 200

  ! Internal parameters
  double precision, allocatable :: knots(:), pots(:,:), pot0(:), pot1(:), pot(:), bpot(:), cpot(:)
  double precision, allocatable :: rr(:), bpsi(:), cpsi(:), frequencies(:), spectrum(:)

  ! Function and Subroutines
  public :: set_params
  public :: bspline
  public :: cnumerov
  public :: bnumerov
  public :: integ
  public :: wkbratio
  public :: compute_crosssection
  public :: initialize
  public :: deinitialize
  public :: free_all_memory

CONTAINS

  ! SUBROUTINE deallocate_dv(mem)
  !   double precision, dimension(:), allocatable, intent(inout) :: mem
  !   if(allocated(mem)) then
  !     deallocate(mem)
  !   endif
  ! END SUBROUTINE deallocate_dv

  SUBROUTINE set_params(params, n)
    integer, intent(in) :: n
    double precision, dimension(n), intent(in) :: params
    double precision, allocatable :: para(:)
    if(allocated(para)) then
      deallocate(para)
    endif
    allocate(para(1:n))
    para(:) = params(:)
    if(npara .NE. n) then
      npara = n
      call initialize()
    endif
  END SUBROUTINE set_params

  SUBROUTINE compute_crosssection()
    call crossection(nr)
  END SUBROUTINE compute_crosssection

  subroutine crossection(nr)
    implicit none
    integer, intent(in) :: nr
    integer :: i
    double precision :: w, eb

    if (lin+dl<0) then
      write (*, *) "negative angular momentum: lin+dl"
      stop
    end if

    ! potential
    pot(:) = pot0(:)
    do i=1,npara
      pot(:) = pot(:) +  (2*para(i)-1)*pots(:,i)
    end do
    bpot(:) = pot(:) + lin*(lin+1)*pot1(:)
    cpot(:) = pot(:) + (lin+dl)*(lin+dl+1)*pot1(:)

    ! bound state
    call bnumerov(lin,kin,bpot(:),eb,bpsi, nr)

    ! continuum states
    do i=1,nr
      if (abs(pot(i)+(lin+dl)*(lin+dl+1)*pot1(i))>1d-3)  jr=i
    end do
    if (nr-jr<10) then
      write (*, *) "too few asymptotic points: ", nr-jr
      stop
    end if

    if (eb+wmin<0) then
      write (*, *) "freqeuncy too small: ", nr-jr, eb+wmin
      stop
    end if

    do i=0,nw
      w = wmin + i*((wmax-wmin)/nw)
      call cnumerov(lin+dl, eb+w,cpot(0:), cpsi, nr)
      frequencies(i) = w
      spectrum(i) = (sum(bpsi(:)*rr(:)*cpsi(:)))**2
    end do

  end subroutine crossection

  SUBROUTINE deinitialize()
  IMPLICIT NONE
    if(allocated(knots)) then
      deallocate(knots)
    endif
    if(allocated(pots)) then
      deallocate(pots)
    endif
    if(allocated(rr)) then
      deallocate(rr)
    endif
    if(allocated(bpot)) then
      deallocate(bpot)
    endif
    if(allocated(cpot)) then
      deallocate(cpot)
    endif
    if(allocated(bpsi)) then
      deallocate(bpsi)
    endif
    if(allocated(cpsi)) then
      deallocate(cpsi)
    endif
    if(allocated(pot)) then
      deallocate(pot)
    endif
    if(allocated(pot0)) then
      deallocate(pot0)
    endif
    if(allocated(pot1)) then
      deallocate(pot1)
    endif
    if(allocated(frequencies)) then
      deallocate(frequencies)
    endif
    if(allocated(spectrum)) then
      deallocate(spectrum)
    endif
  END SUBROUTINE deinitialize

  SUBROUTINE free_all_memory()
  IMPLICIT NONE
    call deinitialize()
    if(allocated(para)) then
      deallocate(para)
    endif
  END SUBROUTINE free_all_memory

  subroutine initialize()
    implicit none
    integer :: i,ii
    double precision :: r

    nr = nint(rmax/dr)

    call deinitialize()
    allocate(knots(1:npara+1))
    allocate(pots(0:nr,1:npara))
    allocate(rr(0:nr),bpot(0:nr),cpot(0:nr),bpsi(0:nr),cpsi(0:nr))
    allocate(pot(0:nr),pot0(0:nr),pot1(0:nr))
    allocate(frequencies(0:nw))
    allocate(spectrum(0:nw))

    ! define the knots for b-splines
    select case(jpot)
    case(1)
      do i=1,npara+1
        knots(i) = (i-1)*((rclus+2*drclus)/npara)
      end do
    end select

    ! calculate all potentials
    do ii=0,nr
      r = ii*dr
      rr(ii) = r
      pot0(ii) = -vclus/(1+exp((r-rclus)/drclus))
      if (ii>0) &
        pot1(ii) = 1/(2*r**2)
      do i=1,npara
        pots(ii,i) = fluc*vclus*bspline(i,r,npara+2,knots(:))
      end do
    end do
    pot1(0) = pot1(1)

  end subroutine initialize

  ! =========
  ! B-splines
  ! =========

  function bspline(j, x, n, xx)
    implicit none
    integer, intent(in) :: j,n
    double precision, intent(in) :: x,xx(1:n-1)
    double precision :: bspline

    bspline = 0
    if (j==1) then
      if (xx(1)<=x .and. x<xx(2)) &
        bspline = ((x-xx(2))/(xx(1)-xx(2)))**2
    end if
    if (j==2) then
      if (xx(1)<=x .and. x<xx(2)) &
        bspline = -(((x - xx(1))*(x*(2*xx(1) - xx(2) - xx(3)) &
        + 2*xx(2)*xx(3) - xx(1)*(xx(2) + xx(3)))) &
        / ((xx(1) - xx(2))**2*(xx(1) - xx(3))))
      if (xx(2)<=x .and. x<=xx(3)) &
        bspline = (x - xx(3))**2 &
        / ((-xx(1) + xx(3))*(-xx(2) + xx(3)))
    end if
    if (2<j .and. j<n-1) then
      if (xx(j-2)<=x .and. x<xx(j-1)) &
        bspline = (x - xx(j-2))**2/((xx(j-2) - xx(j-1))*(xx(j-2) - xx(j)))
      if (xx(j-1)<=x .and. x<xx(j)) &
        bspline = (((x - xx(j-2))*(x - xx(j)))/(xx(j-2) - xx(j)) &
        + ((x - xx(j-1))*(x - xx(j+1)))/(xx(j-1) - xx(j+1)))/(-xx(j-1) + xx(j))
      if (xx(j)<=x .and. x<xx(j+1)) &
        bspline = (x - xx(j+1))**2/((-xx(j-1) + xx(j+1))*(-xx(j) + xx(j+1)))
    end if
    if (j==n-1) then
      if (xx(n-3)<=x .and. x<xx(n-2)) &
        bspline = (x - xx(n-3))**2/((xx(n-3) - xx(n-1))*(xx(n-3) - xx(n-2)))
      if (xx(n-2)<=x .and. x<xx(n-1)) &
        bspline = -(((x - xx(n-1))*(xx(n-3)*(xx(n-1) - 2*xx(n-2)) &
        + xx(n-1)*xx(n-2) + x*(xx(n-3) - 2*xx(n-1) + xx(n-2)))) &
        / ((xx(n-3) - xx(n-1))*(xx(n-1) - xx(n-2))**2))
    end if
    if (j==n) then
      if (xx(n-2)<=x .and. x<=xx(n-1)) &
        bspline = (x - xx(n-2))**2/(xx(n-1) - xx(n-2))**2
    end if

  end function bspline

  ! ==============
  ! numerov method
  ! ==============

  subroutine cnumerov(l,e,pot,psi, nr)
    implicit none
    integer, intent(in) :: l, nr
    double precision, intent(in) :: e,pot(0:nr)
    double precision, intent(out) :: psi(0:nr)

    integer :: j
    double precision :: norm

    call integ(l,e,pot,j,psi, nr)

    norm = maxval(abs(psi(jr:nr)))
    psi(:) = psi(:)/norm
    if (psi(1)<0)  psi(:) = -psi(:)

  end subroutine cnumerov

  subroutine bnumerov(l,k,pot,e,psi, nr)
    implicit none
    integer, intent(in) :: l,k, nr
    double precision, intent(in) :: pot(0:nr)
    double precision, intent(out) :: e,psi(0:nr)

    integer :: j1,j2,j,i,nzeros
    double precision :: e1,e2

    nzeros = k-1
    if (nzeros<0) then
      write (*, *) "bnumerov: nzeros<0"
      stop
    end if

    ! lower limit for bracketing
    e1 = -0.1
    j1 = nzeros+1
    do while(j1>nzeros)
      e1 = 2*e1
      call integ(l,e1,pot(0:nr),j1,psi, nr)
    end do

    ! upper limit for bracketing
    e2 = 1
    j2 = nzeros
    do while(j2.le.nzeros)
      e2 = 2*e2
      call integ(l,e2,pot,j2,psi, nr)
    end do

    ! naive bracketing
    do i=1,33
      ! could be improved
      e = (e1+e2)/2
      call integ(l,e,pot,j,psi, nr)
      if (j>nzeros) then
        e2 = e
      else
        e1 = e
      end if
    end do

    if (e>0 .and. sqrt(2*e)*dr>0.5) then
      write (*, *) "bnumerov: too large grid spacing? momentum:", sqrt(2*e)
    end if

  end subroutine bnumerov

  subroutine integ(l,e,pot,nzeros,psi,nr)
    implicit none
    integer, intent(in) :: l, nr
    double precision, intent(in) :: e
    double precision, intent(in) :: pot(0:nr)
    integer, intent(out) :: nzeros
    double precision, intent(out) :: psi(0:nr)

    integer :: i,j0,flag,j
    double precision :: r,rtp,drq
    double precision :: raux(0:2)

    flag = 1
    nzeros = 0
    drq = dr**2
    psi(:) = 0

    ! outer classical turning point
    j = nr
    do while (e<pot(j) .and. j>0)
      j = j-1
    end do
    rtp = j*dr

    if (pot(1)<e) then
      ! no inner classical forbidden region
      j0 = 1
      r = dr
      psi(1) = r**(l+1)*(1-r/(l+1))
      raux(2) = drq * (pot(1)-e)
      r = 2*dr
      psi(2) = r**(l+1)*(1-r/(l+1))
      raux(1) = drq * (pot(2)-e)
    else
      ! with inner classical forbidden region
      ! j0*dr is the radius where propagation should be possible
      j0 = max(1,nint(sqrt(l*(l+1)/(2*e+1/drq))/dr))
      r = j0*dr
      psi(j0) = 1d-10
      raux(2) = drq * (pot(j0)-e)
      r = (j0+1)*dr
      ! use WKB
      psi(j0+1) = psi(j0) * wkbratio(pot(j0),pot(j0+1),dr,e)
      raux(1) = drq * (pot(j0+1)-e)

      do i=j0-1,1,-1
        psi(i) = psi(i+1)/wkbratio(pot(i),pot(i+1),dr,e)
      end do
    end if

    do i=j0+2,nr
      r = i*dr
      raux(0) = drq * (pot(i)-e)
      psi(i) = ( (12+10*raux(1))*psi(i-1) - (6-raux(2))*psi(i-2) ) / (6-raux(0))
      raux(2) = raux(1)
      raux(1) = raux(0)
      if (flag>0 .and. psi(i)<0) then
        flag = -flag
        nzeros = nzeros+1
      end if
      if (flag<0 .and. psi(i)>0) then
        flag = -flag
        nzeros = nzeros+1
      end if
      if (e<0 .and. r>rtp+1 .and. abs(psi(i))>abs(psi(i-1))) then
        psi(i) = psi(i-1)/2
        exit
      end if
    end do

    ! normalize wave-functions
    psi(:) = psi(:)/sqrt(sum(psi(:)**2))
  end subroutine integ

  function wkbratio(pot1,pot2,dr,e)
    implicit none
    double precision, intent(in) :: pot1,pot2,dr,e
    double precision :: wkbratio
    double precision :: raux1,raux2,raux3
    raux1 = sqrt(2*(pot1-e))
    raux2 = sqrt(2*((pot1+pot2)/2-e))
    raux3 = sqrt(2*(pot2-e))
    wkbratio =  exp((dr/6)*(raux1+4*raux2+raux3))
  end function wkbratio

END MODULE spaic


module radial_1d

  implicit none

  private
  public :: calc_hartree_radial_1d

contains

  subroutine calc_hartree_radial_1d( rad, rab, rho, Vh, Eh )
    implicit none
    real(8),intent(in) :: rad(:), rab(:)
    real(8),intent(in) :: rho(:)
    real(8),intent(out) :: Vh(:)
    real(8),intent(out) :: Eh
    integer :: nrad,i,j
    real(8) :: pi4,sum0,sum1

    Vh=0.0d0
    Eh=0.0d0
    nrad=size(rad)
    pi4=4.0d0*acos(-1.0d0)

    do i=1,nrad

       sum0=0.5d0*rad(1)**2*rho(1)*rab(1) &
           +0.5d0*rad(i)**2*rho(i)*rab(i)
       do j=2,i-1
          sum0=sum0+rad(j)**2*rho(j)*rab(j)
       end do
       sum0=sum0/rad(i)*pi4

       sum1=0.5d0*rad(i)*rho(i)*rab(i) &
           +0.5d0*rad(nrad)*rho(nrad)*rab(nrad)
       do j=i+1,nrad-1
          sum1=sum1+rad(j)*rho(j)*rab(j)
       end do
       sum1=sum1*pi4

       Vh(i) = sum1

       write(20,'(1x,4g20.10)') rad(i),sum0+sum1,sum0,sum1

    end do !i

  end subroutine calc_hartree_radial_1d

end module radial_1d


c
c
c =========================================================
      subroutine limiter3(maxmx,meqn,mwaves,mbc,mx,wave,s,
     &                   dtdx,phi,mthlim)
c =========================================================
c
c     # this routine limits the high-order correction term phi
c
c
      implicit double precision (a-h,o-z)
      dimension   wave(1-mbc:maxmx+mbc, meqn, mwaves)
      dimension    dtdx(1-mbc:maxmx+mbc)
      dimension      s(1-mbc:maxmx+mbc, mwaves)
      dimension    phi(1-mbc:maxmx+mbc, meqn, mwaves)
      dimension mthlim(mwaves)

      dimension      d(1-mbc:maxmx+mbc, meqn, mwaves)

c
c
c     ===============================================================
c     # TVD limiter
c     ===============================================================
c
      do 10 i=1,mx
        do 20 m=1,meqn
            do 30 mw=1,mwaves
              if(mthlim(mw) .eq. 1) then
               if(s(i,mw) .ge. 0d0) then
                phi(i,m,mw) = dmax1(0.d0,
     &          dmin1(2d0/(1d0-dtdx(i)*dabs(s(i,mw))),
     &          phi(i,m,mw),2.*wave(i-1,m,mw)
     &          /(dtdx(i)*dabs(s(i,mw))*wave(i,m,mw))))
               else
                phi(i,m,mw) = dmax1(0.d0,
     &          dmin1(2d0/(1d0-dtdx(i)*dabs(s(i,mw))),
     &          phi(i,m,mw),2.*wave(i+1,m,mw)
     &          /(dtdx(i)*dabs(s(i,mw))*wave(i,m,mw))))
               endif
              endif
   30          continue
   20       continue
   10    continue

c
      return
      end


! --------------------------------------------------------------------
!    Purpose: main program
! --------------------------------------------------------------------
program main
    use mic
    use math
    implicit none
    integer :: i=0
    double precision :: start, finish, t1, t2, t3, t0, t00

    !> read input file to initialize
    open(66, file='../InputFile/input.nml')
    read(66, nml=input)
    read(66, nml=laser)
    read(66, nml=derived)
    allocate(r(NP, 3))
    allocate(v(NP, 3))
    allocate(vb(NP, 3))
    allocate(head(totCell))
    allocate(list(NP))

    call remove_file
    call init
    call links
    call halfleap
    t1 = 0
    t2 = 0
    t3 = 0
    call cpu_time(t0)

    do i = 1, Nstep

        call cpu_time(start)
        call move(method='LF')
        call cpu_time(finish)
        t2 = t2 + finish-start

        call cpu_time(start)
        call links
        call cpu_time(finish)
        t1 = t1 + finish-start

        call cpu_time(start)
        call output(i)
        call cpu_time(finish)
        t3 = t3 + finish-start

        call pstatus(i)
    end do

    call cpu_time(t00)
    write(6, *) 'runtime', t00-t0
    write(6, *) 'links', t1, 'move', t2, 'output', t3

end program main


module sto
use types, only: dp
use constants, only: pi
use utils, only: stop_error
use scf, only: ijkl2intindex
use utils, only: str, assert
use hartree_screening, only: hartree_y
use special_functions, only: wigner3j, getgaunt
use openmp, only: omp_get_thread_num
use quadrature, only: gauss_pts, gauss_wts
use quad_laguerre, only: gauss_laguerre_pts, gauss_laguerre_wts
!use debye, only: Vk
!use debye, only: Vk => Sk
!use debye, only: Vk => Vk2
use debye, only: Vk => Vk3
implicit none
private
public get_basis, get_basis2, stoints, stoints2, get_values, slater_sto_gauss, &
    slater_sto_screen, sto_V_screen

! Array of factorials: fact(n) = n!
! You have to call calc_factorials() to initialize it first.
real(dp), allocatable :: fact(:)

! only used in gauss_aoo()
real(dp), allocatable :: xiq(:), wtq(:)
! only used in gauss_ab()
integer, parameter :: Nq = 64
real(dp), allocatable :: xiq3(:), wtq3(:)

contains

subroutine get_basis(nl, zl, ll, nlist, zetalist, llist, mlist)
integer, intent(in) :: nl(:), ll(:)
real(dp), intent(in) :: zl(:)
integer, allocatable, intent(out) :: nlist(:), llist(:), mlist(:)
real(dp), allocatable, intent(out) :: zetalist(:)
integer :: i, j, n, l, m, a
real(dp) :: zeta
a = sum(2*ll+1)
allocate(nlist(a), zetalist(a), llist(a), mlist(a))
i = 1
j = 1
do j = 1, size(nl)
    n = nl(j)
    zeta = zl(j)
    l = ll(j)
    do m = -l, l
        nlist(i) = n
        zetalist(i) = zeta
        llist(i) = l
        mlist(i) = m
        i = i + 1
    end do
end do
end subroutine

subroutine calc_factorials(maxn, fact)
! Returns fact(n)=n!  for n = 0..maxn
integer, intent(in) :: maxn
real(dp), intent(out), allocatable :: fact(:)
integer :: n
if (maxn < 0) then
    call stop_error("calc_factorials: maxn >= 0 must hold")
end if
allocate(fact(0:maxn))
do n = 0, maxn
    fact(n) = gamma(n + 1._dp)
end do
end subroutine

real(dp) pure function sto_norm(n, zeta) result(r)
integer, intent(in) :: n
real(dp), intent(in) :: zeta
r = sqrt((2*zeta)**(2*n+1) / fact(2*n))
end function

real(dp) function overlap(n, zeta, i, j) result(r)
integer, intent(in) :: n(:)
real(dp), intent(in) :: zeta(:)
integer, intent(in) :: i, j
r = sto_norm(n(i), zeta(i)) * sto_norm(n(j), zeta(j)) * &
        fact(n(i)+n(j)) / (zeta(i)+zeta(j))**(n(i)+n(j)+1)
end function

real(dp) function potential(n, zeta, Z, i, j) result(r)
integer, intent(in) :: n(:), Z
real(dp), intent(in) :: zeta(:)
integer, intent(in) :: i, j
r = -Z * sto_norm(n(i), zeta(i)) * sto_norm(n(j), zeta(j)) * &
        fact(n(i)+n(j)-1) / (zeta(i)+zeta(j))**(n(i)+n(j))
end function

real(dp) function potential_screen(n, zeta, Z, i, j, D) result(r)
integer, intent(in) :: n(:), Z
real(dp), intent(in) :: zeta(:)
integer, intent(in) :: i, j
real(dp), intent(in) :: D
r = -Z * sto_norm(n(i), zeta(i)) * sto_norm(n(j), zeta(j)) * &
        fact(n(i)+n(j)-1) / (zeta(i)+zeta(j)+1/D)**(n(i)+n(j))
end function

real(dp) function kinetic(n, zeta, l, i, j) result(r)
integer, intent(in) :: n(:)
real(dp), intent(in) :: zeta(:)
integer, intent(in) :: l
integer, intent(in) :: i, j
r = 0.5_dp * sto_norm(n(i), zeta(i)) * sto_norm(n(j), zeta(j)) * ( &
        (n(i)*n(j) + l*(l+1)) * fact(n(i)+n(j)-2) / &
            (zeta(i)+zeta(j))**(n(i)+n(j)-1) &
        - (n(i)*zeta(j)+n(j)*zeta(i)) * fact(n(i)+n(j)-1) / &
            (zeta(i)+zeta(j))**(n(i)+n(j)) &
        + zeta(i)*zeta(j) * fact(n(i)+n(j)) / &
            (zeta(i)+zeta(j))**(n(i)+n(j)+1) )
end function

real(dp) pure function H(n, zeta, kk, i, j, k, l) result(r)
integer, intent(in) :: n(:)
real(dp), intent(in) :: zeta(:)
integer, intent(in) :: kk, i, j, k, l
integer :: nu
r = 0
do nu = 0, n(i)+n(k)-kk-1
    r = r + fact(n(j)+n(l)+kk+nu) * (zeta(i)+zeta(k))**nu &
        / (fact(nu) * (zeta(i)+zeta(j)+zeta(k)+zeta(l))**(n(j)+n(l)+kk+nu+1))
end do
end function

real(dp) pure function slater(n, zeta, kk, i, j, k, l) result(r)
! Calculates slater integral R^kk(i, j, k, l) of the STO orbitals given in the
! 'n' and 'zeta' arrays. The indices <ij|kl> are in the physical notation.
integer, intent(in) :: n(:)
real(dp), intent(in) :: zeta(:)
integer, intent(in) :: kk, i, j, k, l
if (n(i)+n(k)-kk-1 < 0 .or. n(j)+n(l)-kk-1 < 0) then
    ! These integrals are never needed due to the winger 3j selection rule, so
    ! we don't calculate them and simply return zero. (Note that the formulas
    ! that we use wouldn't work anyway for this case, so one would have to use
    ! a different method, but that's a different issue.)
    r = 0
else
    r = sto_norm(n(i), zeta(i)) * sto_norm(n(j), zeta(j)) * &
            sto_norm(n(k), zeta(k)) * sto_norm(n(l), zeta(l)) * ( &
                fact(n(i)+n(k)-kk-1) / (zeta(i)+zeta(k))**(n(i)+n(k)-kk) &
                    * H(n, zeta, kk, i, j, k, l) &
              + fact(n(j)+n(l)-kk-1) / (zeta(j)+zeta(l))**(n(j)+n(l)-kk) &
                    * H(n, zeta, kk, j, i, l, k))
end if
end function

subroutine stoints(Z, nlist, zetalist, llist, mlist, S, T, V, int2)
integer, intent(in) :: Z
integer, intent(in) :: nlist(:), llist(:), mlist(:)
real(dp), intent(in) :: zetalist(:)
real(dp), intent(out) :: S(:, :), T(:, :), V(:, :)
real(dp), intent(out) :: int2(:)
integer :: i, j, k, l, Lmax, k_
integer :: l1, l1p, l2, l2p, m1, m1p, m2, m2p
real(dp) :: r, fac
real(dp), allocatable :: ck(:, :, :, :, :)
! Precalculate factorials. The maximum factorial needed is given by 4*maxn-1:
call calc_factorials(maxval(nlist)*4-1, fact)
! Precalculate the radial integrals
Lmax = maxval(llist)
! Construct S, T, V
S = 0
T = 0
V = 0
print *, "Calculating S, T, V, ...."
do i = 1, size(nlist)
    do j = 1, size(nlist)
        if (llist(i) == llist(j) .and. mlist(i) == mlist(j)) then
            S(i, j) = overlap(nlist, zetalist, i, j)
            T(i, j) = kinetic(nlist, zetalist, llist(i), i, j)
            V(i, j) = potential(nlist, zetalist, Z, i, j)
        end if
    end do
end do
print *, "Calculating Gaunt coefficients..."
call getgaunt(Lmax, ck)
!call print_gaunt(Lmax, ck)
print *, "Calculating int2..."
int2 = 0
do i = 1, size(nlist)
    print *, 100._dp * i / size(nlist), "%"
    do j = i, size(nlist)
        do k = 1, size(nlist)
            do l = k, size(nlist)
                if ((i-1)*i/2 + j < (k-1)*k/2 + l) cycle
                l1 = llist(i); l1p = llist(j)
                l2 = llist(k); l2p = llist(l)
                m1 = mlist(i); m1p = mlist(j)
                m2 = mlist(k); m2p = mlist(l)
                if (m1+m2 /= m1p+m2p) cycle
!                m1 = 0
!                m2 = 0
!                m1p = 0
!                m2p = 0
                r = 0
                do k_ = max(abs(l1-l1p), abs(l2-l2p)), min(l1+l1p, l2+l2p)
                    fac = ck(k_, l1, m1, l1p, m1p) * ck(k_, l2p, m2p, l2, m2)
                    if (abs(fac) < tiny(1._dp)) cycle
                    r = r + fac * slater(nlist, zetalist, k_, i, k, j, l)
                end do
                int2(ijkl2intindex(i, j, k, l)) = r
            end do
        end do
    end do
end do
end subroutine

integer function get_maxval(nbfl, nlist) result(r)
integer, intent(in) :: nbfl(0:), nlist(:, 0:)
integer :: l
logical :: mask(size(nlist, 1), 0:ubound(nlist, 2))
mask = .false.
forall(l=0:ubound(nbfl, 1)) mask(:nbfl(l), l) = .true.
r = maxval(nlist, mask=mask)
end function

subroutine stoints2(Z, nbfl, nlist, zetalist, S, T, V, slater_)
! Just like stoints, but it only handles the radial part.
! To get the full 3D integrals, use slater2int22 and radialC2C.
integer, intent(in) :: Z
integer, intent(in) :: nbfl(0:), nlist(:, 0:)
real(dp), intent(in) :: zetalist(:, 0:)
real(dp), allocatable, intent(out) :: S(:, :, :), T(:, :, :), V(:, :, :), &
    slater_(:, :)
integer,  dimension(sum(nbfl)) :: nl
real(dp), dimension(sum(nbfl)) :: zl
integer :: m, n, mu, nu, i, j, k, l, Lmax, k_, ijkl, ndof
integer, allocatable :: intindex(:, :, :, :)
! Precalculate factorials. The maximum factorial needed is given by 4*maxn-1:
call calc_factorials(get_maxval(nbfl, nlist)*4-1, fact)
! Precalculate the radial integrals
Lmax = ubound(nbfl, 1)
ndof = sum(nbfl)
n = maxval(nbfl)
m = ndof*(ndof+1)/2
allocate(S(n, n, 0:Lmax), T(n, n, 0:Lmax), V(n, n, 0:Lmax))
allocate(slater_(m*(m+1)/2, 0:2*Lmax))
! Construct S, T, V
S = 0
T = 0
V = 0
print *, "Calculating S, T, V, ...."
do l = 0, ubound(nbfl, 1)
    do mu = 1, nbfl(l)
        do nu = 1, nbfl(l)
            S(mu, nu, l) = overlap  (nlist(:, l), zetalist(:, l),    mu, nu)
            T(mu, nu, l) = kinetic  (nlist(:, l), zetalist(:, l), l, mu, nu)
            V(mu, nu, l) = potential(nlist(:, l), zetalist(:, l), Z, mu, nu)
        end do
    end do
end do
print *, "Calculating Slater integrals..."
slater_ = 0
j = 1
do l = 0, ubound(nbfl, 1)
    nl(j:j+nbfl(l)-1) = nlist   (:nbfl(l), l)
    zl(j:j+nbfl(l)-1) = zetalist(:nbfl(l), l)
    j = j + nbfl(l)
end do
n = size(nl)
allocate(intindex(n, n, n, n))
call create_index(intindex)
!$omp parallel default(none) shared(n, nbfl, nl, zl, slater_, intindex) private(i, j, k, l, k_, ijkl)
!$omp do schedule(dynamic)
do i = 1, n
    do j = i, n
        do k = 1, n
            do l = k, min((i-1)*i/2 + j - (k-1)*k/2, n)
                ijkl = intindex(l, k, j, i)
                do k_ = 0, 2*ubound(nbfl, 1)
                    slater_(ijkl, k_) = slater(nl, zl, k_, i, k, j, l)
                end do
            end do
        end do
    end do
    ! char(13) is carriage return, so we keep overwriting the percentage
!    write (*, "(a1, f5.1,'%')", advance="no") char(13), &
!        100._dp * ijkl / size(slater_, 1)
end do
!$omp end do
!$omp end parallel
!print *
end subroutine

subroutine sto_V_screen(Z, nbfl, nlist, zetalist, V, D)
! Calculates the potential matrix V with Debye screening
integer, intent(in) :: Z
integer, intent(in) :: nbfl(0:), nlist(:, 0:)
real(dp), intent(in) :: zetalist(:, 0:)
real(dp), allocatable, intent(out) :: V(:, :, :)
real(dp), intent(in) :: D ! Debye screening parameter
integer ::  n, l, mu, nu, Lmax
! Precalculate factorials. The maximum factorial needed is given by 4*maxn-1:
call calc_factorials(get_maxval(nbfl, nlist)*4-1, fact)
! Precalculate the radial integrals
Lmax = ubound(nbfl, 1)
n = maxval(nbfl)
allocate(V(n, n, 0:Lmax))
V = 0
print *, "Calculating V with screening ...."
do l = 0, ubound(nbfl, 1)
    do mu = 1, nbfl(l)
        do nu = 1, nbfl(l)
            V(mu, nu, l) = potential_screen(nlist(:, l), zetalist(:, l), &
                Z, mu, nu, D)
        end do
    end do
end do
end subroutine

real(dp) function factor(l1, l1p, l2, l2p, m1, m1p, m2, m2p, k) result(r)
integer, intent(in) :: l1, l1p, l2, l2p, m1, m1p, m2, m2p, k
integer :: q
r = 0
do q = -k, k
    r = r + (-1)**(m1+m2+q) &
        * wigner3j(l1, l1p, k, -m1, m1p, +q) &
        * wigner3j(l2, l2p, k, -m2, m2p, -q)
end do
if (abs(r-factor2(l1, l1p, l2, l2p, m1, m1p, m2, m2p, k)) > 1e-9_dp) then
    stop "FAIL"
end if
end function

real(dp) function factor2(l1, l1p, l2, l2p, m1, m1p, m2, m2p, k) result(r)
integer, intent(in) :: l1, l1p, l2, l2p, m1, m1p, m2, m2p, k
if (k >= abs(m1-m1p) .and. m1+m2-m1p-m2p == 0) then
    r = (-1)**(m1+m2p) &
        * wigner3j(l1, l1p, k, -m1, m1p, m1-m1p) &
        * wigner3j(l2, l2p, k, -m2, m2p, m2-m2p)
else
    r = 0
end if
end function

real(dp) function factor3(l1, l1p, l2, l2p, m1, m1p, m2, m2p, k, Lmax, &
        wigner3j__) result(r)
integer, intent(in) :: l1, l1p, l2, l2p, m1, m1p, m2, m2p, k, Lmax
real(dp), intent(in) :: wigner3j__(0:, 0:, 0:, -Lmax:, -Lmax:, -2*Lmax:)
if (k >= abs(m1-m1p) .and. m1+m2-m1p-m2p == 0) then
    r = (-1)**(m1+m2p) &
        * wigner3j__(l1, l1p, k, -m1, m1p, m1-m1p) &
        * wigner3j__(l2, l2p, k, -m2, m2p, m2-m2p)
else
    r = 0
end if
end function

subroutine print_gaunt(Lmax, ck)
integer, intent(in) :: Lmax
real(dp), intent(in) :: ck(0:, 0:, -Lmax:, 0:, -Lmax:)
integer :: i, j, k, m1, m2
do k = lbound(ck, 1), ubound(ck, 1)
    do i = lbound(ck, 2), ubound(ck, 2)
        do m1 = lbound(ck, 3), ubound(ck, 3)
            do j = lbound(ck, 4), ubound(ck, 4)
                do m2 = lbound(ck, 5), ubound(ck, 5)
                    if (abs(ck(k, i, m1, j, m2)) < tiny(1._dp)) cycle
                    print "('   ', i3, i3, i3, i3, i3, es24.16)", k, i, &
                        m1, j, m2, ck(k, i, m1, j, m2)
                end do
            end do
        end do
    end do
end do
end subroutine

function get_values(nbfl, nl, zl, C, R) result(u)
integer, intent(in) :: nl(:, 0:), nbfl(0:)
real(dp), intent(in) :: zl(:, 0:), C(:, :, 0:), R(:)
! u(:, n, l) are the values of eigenvector (n, l)
real(dp) :: u(size(R), size(C, 2), 0:ubound(C, 3))
integer :: n, l
call calc_factorials(get_maxval(nbfl, nl)*2, fact)
u = 0
do l = 0, ubound(nbfl, 1)
    do n = 1, nbfl(l)
        u(:, n, l) = sol_eval(nl(:nbfl(l), l), zl(:nbfl(l), l), &
                C(:nbfl(l), n, l), R)
    end do
end do
end function

function sol_eval(n, z, C, r) result(u)
integer, intent(in) :: n(:)
real(dp), intent(in) :: z(:), C(:), r(:)
real(dp) :: u(size(R))
integer :: i
u = 0
do i = 1, size(n)
    u = u + C(i) * sqrt((2*z(i))**(2*n(i)+1) / fact(2*n(i))) * r**n(i) * &
            exp(-z(i)*r)
end do
end function

subroutine get_basis2(Z, nbfl, nl, zl, focc)
integer, intent(in) :: Z
integer, intent(out), allocatable :: nl(:, :), nbfl(:)
real(dp), intent(out), allocatable :: zl(:, :), focc(:, :)

if (Z == 2) then
    allocate(nl(5, 0:0), zl(5, 0:0), nbfl(0:0), focc(5, 0:0))
    focc = 0
    nbfl = 0
    focc(1, 0) = 2
    nbfl(0) = 5
    nl(:5, 0) = [1, 1, 1, 1, 1]
    zl(:5, 0) = [1.41714_dp, 2.37682_dp, 4.39628_dp, 6.52699_dp, 7.94252_dp]
else if (Z == 4) then
    allocate(nl(6, 0:0), zl(6, 0:0), nbfl(0:0), focc(6, 0:0))
    focc = 0
    nbfl = 0
    focc(:2, 0) = [2, 2]
    nbfl(0) = 6
    nl(:6, 0) = [1, 1, 2, 2, 2, 2]
    zl(:6, 0) = [3.47116_dp, 6.36861_dp, 0.77820_dp, 0.94067_dp, 1.48725_dp, &
        2.71830_dp]
else if (Z == 10) then
    allocate(nl(6, 0:1), zl(6, 0:1), nbfl(0:1), focc(6, 0:1))
    focc = 0
    nl = 0
    zl = 0
    ! s
    focc(:2, 0) = [2, 2]
    nbfl(0) = 6
    nl(:6, 0) = [1, 1, 2, 2, 2, 2]
    zl(:6, 0) = [9.48486_dp, 15.56590_dp, 1.96184_dp, 2.86423_dp, 4.82530_dp, &
        7.79242_dp]

    ! p
    focc(:1, 1) = [6]
    nbfl(1) = 4
    nl(:4, 1) = [2, 2, 2, 2]
    zl(:4, 1) = [1.45208_dp, 2.38168_dp, 4.48489_dp, 9.13464_dp]
else if (Z == 12) then
    allocate(nl(8, 0:1), zl(8, 0:1), nbfl(0:1), focc(8, 0:1))
    focc = 0
    nl = 0
    zl = 0
    ! s
    focc(:3, 0) = [2, 2, 2]
    nbfl(0) = 8
    nl(:8, 0) = [1, 3, 3, 3, 3, 3, 3, 3]
    zl(:8, 0) = [12.01140_dp, 13.91620_dp, 9.48612_dp, 6.72188_dp, 4.24466_dp, &
        2.53466_dp, 1.46920_dp, 0.89084_dp]

    ! p
    focc(:1, 1) = [6]
    nbfl(1) = 5
    nl(:5, 1) = [2, 4, 4, 4, 4]
    zl(:5, 1) = [5.92580_dp, 7.98979_dp, 5.32964_dp, 3.71678_dp, 2.59986_dp]
else if (Z == 18) then
    allocate(nl(8, 0:1), zl(8, 0:1), nbfl(0:1), focc(8, 0:1))
    focc = 0
    nl = 0
    zl = 0
    ! s
    focc(:3, 0) = [2, 2, 2]
    nbfl(0) = 8
    nl(:8, 0) = [1, 3, 3, 3, 3, 3, 3, 3]
    zl(:8, 0) = [18.01640_dp, 22.04650_dp, 16.08250_dp, 11.63570_dp, &
        7.70365_dp, 4.87338_dp, 3.32987_dp, 2.02791_dp]

    ! p
    focc(:2, 1) = [6, 6]
    nbfl(1) = 8
    nl(:8, 1) = [2, 4, 4, 4, 4, 4, 4, 4]
    zl(:8, 1) = [9.05477_dp, 15.54410_dp, 12.39970_dp, 8.56120_dp, &
        5.94658_dp, 3.42459_dp, 1.96709_dp, 1.06717_dp]
else if (Z == 54) then
    allocate(nl(11, 0:2), zl(11, 0:2), nbfl(0:2), focc(5, 0:2))
    focc = 0
    nl = 0
    zl = 0
    ! s
    focc(:5, 0) = [2, 2, 2, 2, 2]
    nbfl(0) = 11
    nl(:11, 0) = [1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 5]
    zl(:11, 0) = [55.30720_dp, 37.80730_dp, 27.92970_dp, 23.69210_dp, &
        15.03530_dp, 12.67230_dp, 7.60195_dp, 5.73799_dp, 4.17583_dp, &
        2.99772_dp, 1.98532_dp]

    ! p
    focc(:4, 1) = [6, 6, 6, 6]
    nbfl(1) = 9
    nl(:9, 1) = [2, 2, 3, 3, 4, 4, 5, 5, 5]
    zl(:9, 1) = [34.88440_dp, 23.30470_dp, 12.54120_dp, 12.02300_dp, &
        7.72390_dp, 5.40562_dp, 3.32661_dp, 2.09341_dp, 1.36686_dp]

    ! d
    focc(:2, 2) = [10, 10]
    nbfl(2) = 5
    nl(:5, 2) = [3, 3, 4, 4, 4]
    zl(:5, 2) = [20.08240_dp, 11.78600_dp, 7.30842_dp, 4.88400_dp, 3.19850_dp]
else
    call stop_error("Z=" // str(Z) // " not implemented")
end if
end subroutine

subroutine slater_sto_gauss(nbfl, nlist, zetalist, slater_)
! Just like stoints2, but only the slater integral and uses the Gaussian
! integration to do it.
integer, intent(in) :: nbfl(0:), nlist(:, 0:)
real(dp), intent(in) :: zetalist(:, 0:)
real(dp), allocatable, intent(out) :: slater_(:, :)
integer,  dimension(sum(nbfl)) :: nl
real(dp), dimension(sum(nbfl)) :: zl
integer :: m, n, i, j, k, l, k_, ijkl, ndof, Lmax
! Precalculate factorials. The maximum factorial needed is given by 4*maxn-1:
call calc_factorials(get_maxval(nbfl, nlist)*4-1, fact)
if (.not. allocated(xiq)) then
    allocate(xiq(52), wtq(52))
    xiq = gauss_laguerre_pts(52)
    wtq = gauss_laguerre_wts(52)
end if
if (.not. allocated(xiq3)) then
    allocate(xiq3(Nq), wtq3(Nq))
    xiq3 = gauss_pts(Nq)
    wtq3 = gauss_wts(Nq)
end if
print *, "Calculating Slater integrals..."
Lmax = ubound(nbfl, 1)
ndof = sum(nbfl)
m = ndof*(ndof+1)/2
allocate(slater_(m*(m+1)/2, 0:2*Lmax))
slater_ = 0
j = 1
do l = 0, ubound(nbfl, 1)
    nl(j:j+nbfl(l)-1) = nlist   (:nbfl(l), l)
    zl(j:j+nbfl(l)-1) = zetalist(:nbfl(l), l)
    j = j + nbfl(l)
end do
n = size(nl)
ijkl = 0
do i = 1, n
    do j = 1, i
        do k = 1, n
            do l = 1, k
                if ((i-1)*i/2 + j < (k-1)*k/2 + l) cycle
                ijkl = ijkl + 1
                ! This check can be used to verify, that the "ijkl" index is
                ! calculated properly:
                !call assert(ijkl2intindex(i, j, k, l) == ijkl)
                do k_ = 0, 2*ubound(nbfl, 1)
                    !slater_(ijkl, k_) = slater(nl, zl, k_, i, k, j, l)
                    slater_(ijkl, k_) = slater_gauss(nl, zl, k_, i, k, j, l) &
                        + slater_gauss(nl, zl, k_, k, i, l, j)
                end do
            end do
        end do
    end do
    ! char(13) is carriage return, so we keep overwriting the percentage
    write (*, "(a1, f5.1,'%')", advance="no") char(13), &
        100._dp * ijkl / size(slater_, 1)
end do
print *
end subroutine

real(dp) function slater_gauss(n, zeta, kk, i, j, k, l) result(r)
! Just like slater(), but uses Gaussian integration to do the integrals.
integer, intent(in) :: n(:)
real(dp), intent(in) :: zeta(:)
integer, intent(in) :: kk, i, j, k, l
real(dp) :: xp
if (n(i)+n(k)-kk-1 < 0 .or. n(j)+n(l)-kk-1 < 0) then
    ! This condition is taken from slater() --- these integrals are
    ! never needed, they don't influence anything, thanks to the wigner3j
    ! selection rule:
    r = 0
else
    r = sto_norm(n(i), zeta(i)) * sto_norm(n(j), zeta(j)) * &
            sto_norm(n(k), zeta(k)) * sto_norm(n(l), zeta(l)) * &
            (gauss_ab(n(i) + n(k), zeta(i) + zeta(k), Ykoverr, 0._dp, 0.1_dp) &
            + gauss_ab(n(i) + n(k), zeta(i) + zeta(k), Ykoverr, 0.1_dp, 5._dp) &
            + gauss_aoo(n(i) + n(k), zeta(i) + zeta(k), Ykoverr, 5._dp))
end if

contains

    real(dp) function Ykoverr(x) result(r)
    real(dp), intent(in) :: x
    integer :: n_
    real(dp) :: zeta_
    xp = x ! save x
    n_ = n(j) + n(l)
    zeta_ = zeta(j) + zeta(l)
    r = gauss_ab(n_, zeta_, g, 0._dp, x)
    end function

    real(dp) function g(x)
    real(dp), intent(in) :: x
    !call assert(xp > x)   ! commented out for efficiency reasons
    g = x**kk / xp**(kk+1)
    end function

end function

real(dp) function gauss_aoo(n, zeta, f, x0) result(res)
! Calculates the integral \int_x0^oo r^n * exp(-zeta*r) * f(r) \d r
!
! We first shift the integral to (0, oo) and then convert the integral to:
!
!   \int_0^oo r^n * exp(-zeta*r) * f(r) \d r =
!       = (1/zeta) * \int_0^oo exp(-x) * (x/zeta)^n * f(x/zeta) \d x
!
! And use Gauss-Laguerre quadrature for the integral over "x".
integer, intent(in) :: n
real(dp), intent(in) :: zeta
interface
    real(dp) function f(x)
    import :: dp
    implicit none
    real(dp), intent(in) :: x
    end function
end interface
real(dp), intent(in) :: x0
real(dp) :: r
real(dp), allocatable :: hq(:)
integer :: i

allocate(hq(size(xiq)))
do i = 1, size(xiq)
    r = xiq(i) / zeta
    ! Note: r**n goes to infinity for large "r", and f(r) goes to zero but very
    ! slowly, so r**n * f(r) blows up. For example for Nq=52, the largest point
    ! is x=188.41, zeta=1.7846, so r=105.57, and f(r)=1e-5, but
    ! r**n*f(r)=1837.76
    ! The weight is 1e-80, so the result is zero.
    hq(i) = (r+x0)**n * f(r+x0)
end do
res = sum(wtq * hq) / zeta
res = res * exp(-zeta*x0)
end function

real(dp) recursive function gauss_ab(n, zeta, f, a, b) result(res)
! Calculates the integral \int_a^b r^n * exp(-zeta*r) * f(r) \d r
!
! A direct Gauss-Legendre quadrature is used.
integer, intent(in) :: n
real(dp), intent(in) :: zeta
interface
    real(dp) function f(x)
    import :: dp
    implicit none
    real(dp), intent(in) :: x
    end function
end interface
real(dp), intent(in) :: a, b
real(dp) :: r
real(dp) :: fq(Nq), jac
integer :: i

jac = (b-a)/2
do i = 1, Nq
    r = (xiq3(i)+1) * jac + a
    fq(i) = r**n * exp(-zeta*r) * f(r)
end do
res = sum(wtq3 * fq * jac)
end function

real(dp) function slater_gauss_screening(n, zeta, kk, i, j, k, l, D) result(r)
! Just like slater(), but uses Gaussian integration to do the integrals.
integer, intent(in) :: n(:)
real(dp), intent(in) :: zeta(:)
integer, intent(in) :: kk, i, j, k, l
real(dp), intent(in) :: D
real(dp) :: xp
if (n(i)+n(k)-kk-1 < 0 .or. n(j)+n(l)-kk-1 < 0) then
    ! This condition is taken from slater() --- these integrals are
    ! never needed, they don't influence anything, thanks to the wigner3j
    ! selection rule:
    r = 0
else
    r = sto_norm(n(i), zeta(i)) * sto_norm(n(j), zeta(j)) * &
            sto_norm(n(k), zeta(k)) * sto_norm(n(l), zeta(l)) * &
            (gauss_ab(n(i) + n(k), zeta(i) + zeta(k), Ykoverr, 0._dp, 0.1_dp) &
            + gauss_aoo(n(i) + n(k), zeta(i) + zeta(k), Ykoverr, 0.1_dp))
end if

contains

    real(dp) function Ykoverr(x) result(r)
    real(dp), intent(in) :: x
    integer :: n_
    real(dp) :: zeta_
    xp = x ! save x
    n_ = n(j) + n(l)
    zeta_ = zeta(j) + zeta(l)
    r = gauss_ab(n_, zeta_, g, 0._dp, x)
    end function

    real(dp) function g(x)
    real(dp), intent(in) :: x
    !call assert(xp > x)   ! commented out for efficiency reasons
    g = Vk(kk, D, xp, x)
    end function

end function

subroutine slater_sto_screen(nbfl, nlist, zetalist, slater_, D, &
        verbose, cr)
! Just like stoints2, but only the slater integral and uses the Gaussian
! integration to do it. Uses Debye screening.
integer, intent(in) :: nbfl(0:), nlist(:, 0:)
real(dp), intent(in) :: zetalist(:, 0:)
real(dp), allocatable, intent(out) :: slater_(:, :)
real(dp), intent(in) :: D ! Debye screening length
logical, intent(in), optional :: verbose ! show progress (default .false.)
logical, intent(in), optional :: cr ! use '\n' in progress (default .false.)
integer,  dimension(sum(nbfl)) :: nl
real(dp), dimension(sum(nbfl)) :: zl
integer :: n, i, j, k, l, k_, ijkl, Lmax, ndof, m
integer, allocatable :: intindex(:, :, :, :)
logical :: verbose_, cr_
verbose_ = .false.
cr_ = .false.
if (present(verbose)) verbose_ = verbose
if (present(cr)) cr_ = cr
! Precalculate factorials. The maximum factorial needed is given by 4*maxn-1:
call calc_factorials(get_maxval(nbfl, nlist)*4-1, fact)
print *, "Calculating Slater integrals with screening..."
Lmax = ubound(nbfl, 1)
ndof = sum(nbfl)
m = ndof*(ndof+1)/2
allocate(slater_(m*(m+1)/2, 0:2*Lmax))
slater_ = 0
j = 1
do l = 0, ubound(nbfl, 1)
    nl(j:j+nbfl(l)-1) = nlist   (:nbfl(l), l)
    zl(j:j+nbfl(l)-1) = zetalist(:nbfl(l), l)
    j = j + nbfl(l)
end do

if (.not. allocated(xiq)) then
    allocate(xiq(52), wtq(52))
    xiq = gauss_laguerre_pts(52)
    wtq = gauss_laguerre_wts(52)
end if
if (.not. allocated(xiq3)) then
    allocate(xiq3(Nq), wtq3(Nq))
    xiq3 = gauss_pts(Nq)
    wtq3 = gauss_wts(Nq)
end if

n = size(nl)
allocate(intindex(n, n, n, n))
call create_index(intindex)
!$omp parallel default(none) shared(n, nbfl, nl, zl, slater_, D, intindex, verbose_, cr_) private(i, j, k, l, k_, ijkl)
!$omp do schedule(dynamic)
do i = 1, n  ! Only this outer loop is parallelized
    do j = i, n
        do k = 1, n
            do l = k, min((i-1)*i/2 + j - (k-1)*k/2, n)
                ijkl = intindex(l, k, j, i)
                do k_ = 0, 2*ubound(nbfl, 1)
                    !slater_(ijkl, k_) = slater(nl, zl, k_, i, k, j, l)
                    !slater_(ijkl, k_) = slater_gauss(nl, zl, k_, i, k, j, l)
                    !slater_(ijkl, k_) = slater_gauss2(nl, zl, k_, i, k, j, l)
                    !slater_(ijkl, k_) = slater_gauss3(nl, zl, k_, i, k, j, l)
                    slater_(ijkl, k_) = slater_gauss_screening(nl, zl, &
                        k_, i, k, j, l, D) + &
                    slater_gauss_screening(nl, zl, &
                        k_, k, i, l, j, D)
                end do
            end do
        end do
        if (verbose_) then
            if (omp_get_thread_num() == 0) then
                if (cr_) then
                    write (*, "(f5.1,'%')") 100._dp * (n*(n+1)/2 - (n-i+1)*(n-i+2)/2+j-i+1) / (n*(n+1)/2)
                else
                    ! char(13) is carriage return, so we keep overwriting the
                    ! percentage
                    write (*, "(a1, f5.1,'%')", advance="no") char(13), &
                        100._dp * (n*(n+1)/2 - (n-i+1)*(n-i+2)/2+j-i+1) / (n*(n+1)/2)
                end if
            end if
        end if
    end do
end do
!$omp end do
!$omp end parallel
print *
end subroutine

subroutine create_index(intindex)
integer, intent(out) :: intindex(:, :, :, :)
integer :: i, j, k, l, ijkl, n
n = size(intindex, 1)
! Uncomment the commented lines to run checks:
!intindex = -1
ijkl = 1
do i = 1, n
    do j = 1, i
        do k = 1, n
            do l = 1, k
                if ((i-1)*i/2 + j < (k-1)*k/2 + l) cycle
!                call assert(ijkl2intindex(i, j, k, l) == ijkl)
                intindex(i, j, k, l) = ijkl
                intindex(j, i, k, l) = ijkl
                intindex(j, i, l, k) = ijkl
                intindex(i, j, l, k) = ijkl
                intindex(k, l, i, j) = ijkl
                intindex(l, k, i, j) = ijkl
                intindex(l, k, j, i) = ijkl
                intindex(k, l, j, i) = ijkl
                ijkl = ijkl + 1
            end do
        end do
    end do
end do
!call assert(.not. (any(intindex == -1)))
end subroutine

end module


c#######################################################################
c estimate peacewise cubic spline coefficients
c#######################################################################
      subroutine mspline (ip,n,x,y,ind1,d1,ind2,d2)
      implicit none
      real*8    x(1001),y(1001),c(4,1001),cc(5,10001)
      integer*4 i,j,ip,n,ind1,ind2
      real*8    s,z,d1,d2
c ---
      integer*4 nn(10),ndim(10)
      real*8    xx(1001,10),sc(4,1001,10),scc(5,1001,10)
      common /mspdat/nn,ndim,xx,sc,scc
c ---
c validate input parameters
      if(n.lt.2.or.n.gt.1001) then
        write(*,*) 'mspline: n=',n,
     *             ' is out of bounds. Should be in range 2-1001.'
        stop
      endif
      if(ip.lt.1.or.ip.gt.10) then
        write(*,*) 'mspline: ip=',ip,
     *             ' is out of bounds. Should be in range 1-10.'
        stop
      endif
      if(ind1.lt.0.or.ind1.gt.2) then
        write(*,*) 'mspline: ind1=',ind1,
     *             ' is out of bounds. Should be in range 0-2.'
        stop
      endif
      if(ind2.lt.0.or.ind2.gt.2) then
        write(*,*) 'mspline: ind2=',ind2,
     *             ' is out of bounds. Should be in range 0-2.'
        stop
      endif
      do i =1,n
          c(1,i) = y(i)
      enddo
      c(2,1) = d1
      c(2,n) = d2
      call cubspl(x,c,n,ind1,ind2)
c remove 2 and 6
      do i = 1,n-1
        c(3,i) = c(3,i)/2.0d0
        c(4,i) = c(4,i)/6.0d0
      enddo
c create integral coefficients
      s = 0.0d0
      do i = 1,n-1
        do j =1,4
          cc(j+1,i) = c(j,i)/j
        enddo
        cc(1,i) = s
        z = x(i+1)-x(i)
        s = s+z*(cc(2,i)+z*(cc(3,i)+z*(cc(4,i)+z*cc(5,i))))
      enddo
c save coefficients into common block mspdat
      nn(ip) = n
      do i = 1,n
        xx(i,ip) = x(i)
        do j = 1,4
           sc(j,i,ip) = c(j,i)
           scc(j,i,ip) = cc(j,i)
        enddo
        scc(5,i,ip) = cc(5,i)
      enddo
      return
      end
c#######################################################################
c integral for spline
c#######################################################################
      subroutine msplint (ip,sa,sb,sint,ierr)
      implicit none
      integer*4 ip,ierr,i,ii,j,n
      real*8    sa,sb,sint,x1,x2,r,fsig,s1,s2,z
      real*8    x(1001),cc(5,10001)
c ---
      integer*4 nn(10),ndim(10)
      real*8    xx(1001,10),sc(4,1001,10),scc(5,1001,10)
      common /mspdat/nn,ndim,xx,sc,scc
c ---
      fsig(x1,x2,r)=(x1-r)*(x2-r)

c restore polinomial coefficients
      ierr = 0
      n = nn(ip)
      do i = 1,n
        x(i) = xx(i,ip)
        do j = 1,5
          cc(j,i) = scc(j,i,ip)
        enddo
      enddo
c compute integral for sa
      ii = 0
      do i = 1,n-1
        if(fsig(x(i),x(i+1),sa).le.0.0d0) ii = i
      enddo
      if(ii.eq.0) then
        if(sa.le.x(1)) ii = 1
        if(sa.ge.x(n-1)) ii = n-1
      endif
      z = sa-x(ii)
      s1 = cc(1,ii)+z*(cc(2,ii)+z*(cc(3,ii)+z*(cc(4,ii)+z*cc(5,ii))))
c compute integral for sb
      ii = 0
      do i = 1,n-1
        if(fsig(x(i),x(i+1),sb).le.0.0d0) ii = i
      enddo
      if(ii.eq.0) then
        if(sb.le.x(1)) ii = 1
        if(sb.ge.x(n-1)) ii = n-1
      endif
      z = sb-x(ii)
      s2 = cc(1,ii)+z*(cc(2,ii)+z*(cc(3,ii)+z*(cc(4,ii)+z*cc(5,ii))))
      sint = s2-s1
      return
      end
c#######################################################################
c spline interpolation of funcion and its 1st and 2nd derivatives
c#######################################################################
      subroutine msplder (ip,xt,s,sd,sdd,ierr)
      implicit none
      integer*4 ip,ierr
      real*8    xt,s,sd,sdd
c ---
      integer*4 nn(10),ndim(10)
      real*8    xx(1001,10),sc(4,1001,10),scc(5,1001,10)
      common /mspdat/nn,ndim,xx,sc,scc
c ---
      integer*4 i,j,ii,n
      real*8    x(1001),c(4,1001)
      real*8    x1,x2,r,fsig,z

      fsig(x1,x2,r)=(x1-r)*(x2-r)

c restore polinomial coefficients
      ierr = 0
      n = nn(ip)
      do i = 1,n
        x(i) = xx(i,ip)
        do j = 1,4
          c(j,i) = sc(j,i,ip)
        enddo
      enddo
c find interval for interpolation
      ii = 0
      do i = 1,n-1
        if(fsig(x(i),x(i+1),xt).le.0.0d0) ii = i
      enddo
      if(ii.eq.0) then
        if(xt.le.x(1)) ii = 1
        if(xt.ge.x(n-1)) ii = n-1
      endif
      z = xt-x(ii)
      s = c(1,ii)+z*(c(2,ii)+z*(c(3,ii)+z*c(4,ii)))
      sd = c(2,ii)+z*(2.0d0*c(3,ii)+3.0d0*z*c(4,ii))
      sdd = 2.0d0*c(3,ii)+6.0d0*z*c(4,ii)
      return
      end
c#######################################################################
      subroutine cubspl ( tau, c, n, ibcbeg, ibcend )
c  from  * a practical guide to splines *  by c. de boor
c     ************************  input  ***************************
c     n = number of data points. assumed to be greater than 1.
c     (tau(i), c(1,i), i=1,...,n) = abscissae and ordinates of the
c        data points. tau is assumed to be strictly increasing.
c     ibcbeg, ibcend = boundary condition indicators, and
c     c(2,1), c(2,n) = boundary condition information. Specifically,
c        ibcbeg = 0  means no boundary condition at tau(1) is given.
c           in this case, the not-a-knot condition is used, i.e. the
c           jump in the third derivative across tau(2) is forced to
c           zero, thus the first and the second cubic polynomial pieces
c           are made to coincide.)
c        ibcbeg = 1  means that the slope at tau(1) is made to equal
c           c(2,1), supplied by input.
c        ibcbeg = 2  means that the second derivative at tau(1) is
c           made to equal c(2,1), supplied by input.
c        ibcend = 0, 1, or 2 has analogous meaning concerning the
c           boundary condition at tau(n), with the additional infor-
c           mation taken from c(2,n).
c     ***********************  output  **************************
c     c(j,i), j=1,...,4; i=1,...,l (= n-1) = the polynomial coefficients
c        of the cubic interpolating spline with interior knots (or
c        joints) tau(2), ..., tau(n-1). precisely, in the interval
c        (tau(i), tau(i+1)), the spline f is given by
c           f(x) = c(1,i)+h*(c(2,i)+h*(c(3,i)+h*c(4,i)/3.)/2.)
c        where h = x - tau(i). the function program *ppvalu* may be
c        used to evaluate f or its derivatives from tau,c, l = n-1,
c        and k=4.
      implicit none
c ---
      integer*4 ibcbeg,ibcend,n,i,j,l,m
      real*8    c(4,n),tau(n),divdf1,divdf3,dtau,g
c ---
c****** a tridiagonal linear system for the unknown slopes s(i) of
c  f  at tau(i), i=1,...,n, is generated and then solved by gauss elim-
c  ination, with s(i) ending up in c(2,i), all i.
c     c(3,.) and c(4,.) are used initially for temporary storage.
      l = n-1
c compute first differences of tau sequence and store in c(3,.). also,
c compute first divided difference of data and store in c(4,.).
      do m=2,n
         c(3,m) = tau(m) - tau(m-1)
         c(4,m) = (c(1,m) - c(1,m-1))/c(3,m)
      enddo
c construct first equation from the boundary condition, of the form
c             c(4,1)*s(1) + c(3,1)*s(2) = c(2,1)
cMB   if (ibcbeg-1) 11,15,16
      if (ibcbeg-1.eq.0) goto 15
      if (ibcbeg-1.gt.0) goto 16
      if (n .gt. 2) goto 12
c     no condition at left end and n = 2.
      c(4,1) = 1.0d0
      c(3,1) = 1.0d0
      c(2,1) = 2.0d0*c(4,2)
      goto 25
c     not-a-knot condition at left end and n .gt. 2.
   12 c(4,1) = c(3,3)
      c(3,1) = c(3,2) + c(3,3)
      c(2,1) =((c(3,2)+2.0d0*c(3,1))*c(4,2)*c(3,3)+c(3,2)**2*c(4,3))/c(3,1)
      goto 19
c     slope prescribed at left end.
   15 c(4,1) = 1.0d0
      c(3,1) = 0.0d0
      goto 18
c     second derivative prescribed at left end.
   16 c(4,1) = 2.0d0
      c(3,1) = 1.0d0
      c(2,1) = 3.0d0*c(4,2) - c(3,2)/2.0d0*c(2,1)
   18 if(n .eq. 2) goto 25
c  if there are interior knots, generate the corresp. equations and car-
c  ry out the forward pass of gauss elimination, after which the m-th
c  equation reads    c(4,m)*s(m) + c(3,m)*s(m+1) = c(2,m).
   19 do m=2,l
         g = -c(3,m+1)/c(4,m-1)
         c(2,m) = g*c(2,m-1) + 3.0d0*(c(3,m)*c(4,m+1)+c(3,m+1)*c(4,m))
         c(4,m) = g*c(3,m-1) + 2.0d0*(c(3,m) + c(3,m+1))
      enddo
c construct last equation from the second boundary condition, of the form
c           (-g*c(4,n-1))*s(n-1) + c(4,n)*s(n) = c(2,n)
c     if slope is prescribed at right end, one can go directly to back-
c     substitution, since c array happens to be set up just right for it
c     at this point.
cMB   if (ibcend-1) 21,30,24
      if (ibcend-1.eq.0) goto 30
      if (ibcend-1.gt.0) goto 24
      if (n .eq. 3 .and. ibcbeg .eq. 0) goto 22
c     not-a-knot and n .ge. 3, and either n.gt.3 or  also not-a-knot at
c     left end point.
      g = c(3,n-1) + c(3,n)
      c(2,n) = ((c(3,n)+2.0d0*g)*c(4,n)*c(3,n-1)
     *            + c(3,n)**2*(c(1,n-1)-c(1,n-2))/c(3,n-1))/g
      g = -g/c(4,n-1)
      c(4,n) = c(3,n-1)
      goto 29
c     either (n=3 and not-a-knot also at left) or (n=2 and not not-a-
c     knot at left end point).
   22 c(2,n) = 2.0d0*c(4,n)
      c(4,n) = 1.0d0
      goto 28
c     second derivative prescribed at right endpoint.
   24 c(2,n) = 3.0d0*c(4,n) + c(3,n)/2.0d0*c(2,n)
      c(4,n) = 2.0d0
      goto 28
cMB25 if (ibcend-1) 26,30,24
   25 if (ibcend-1.eq.0) goto 30
      if (ibcend-1.gt.0) goto 24
      if (ibcbeg .gt. 0) goto 22
c     not-a-knot at right endpoint and at left endpoint and n = 2.
      c(2,n) = c(4,n)
      goto 30
   28 g = -1.0d0/c(4,n-1)
c complete forward pass of gauss elimination.
   29 c(4,n) = g*c(3,n-1) + c(4,n)
      c(2,n) = (g*c(2,n-1) + c(2,n))/c(4,n)
c ccarry out back substitution
   30 j = l
   40 c(2,j) = (c(2,j) - c(3,j)*c(2,j+1))/c(4,j)
      j = j - 1
      if (j .gt. 0) goto 40
c****** generate cubic coefficients in each interval, i.e., the deriv.s
c  at its left endpoint, from value and slope at its endpoints.
      do i=2,n
         dtau = c(3,i)
         divdf1 = (c(1,i) - c(1,i-1))/dtau
         divdf3 = c(2,i-1) + c(2,i) - 2.0d0*divdf1
         c(3,i-1) = 2.0d0*(divdf1 - c(2,i-1) - divdf3)/dtau
         c(4,i-1) = (divdf3/dtau)*(6.0d0/dtau)
      enddo
      return
      end


C ======================================================================
      Subroutine FEM3Dext(XY1, XY2, XY3, XY4,
     &                        lbE, lbF, lbR, lbP, DDATA, IDATA, iSYS,
     &                        LDA, A, F, nRow, nCol,
     &             templateR, templateC)
C ======================================================================
      implicit none
      Include 'fem3Dtet.fd'
      Include 'assemble.fd'
C ======================================================================
      Real*8   XY1(*), XY2(*), XY3(*), XY4(*)

      Integer  lbE, lbF(4), lbR(6), lbP(4), LDA
      Real*8   DDATA(*)
      Integer  IDATA(*), iSYS(*)

      Real*8   A(LDA, *), F(*)
      Integer  nRow, nCol, templateR(*), templateC(*)

C Local variables
      Integer  Ddiff, Dconv, Drhs, Dbc
      External Ddiff, Dconv, Drhs, Dbc

      Integer  ANI_Dnull
      Real*8   calVol, calEdge, tet_diameter
      External calVol, calEdge, tet_diameter, ANI_Dnull

      Integer  i,j,k,n, idum, label, ibc, ir, ic
      Real*8   B(4, 4), C(4, 4), FF, vol, DiffCoef(9,9), ConvCoef(9,9)
      Real*8   x, y, z, eBC(1), Dbb, bb, bnrm, h
      Real*8   Pe, delta, dT, ConcAvr

!====================================================
       Real*8   D(4, 4),u_loc(4), DDATASIMP(4), res(4)
      Integer  IDATASIMP(4)
      Integer  ANI_D1x1_scalar
      External ANI_D1x1_scalar

C ======================================================================
      nRow = 4
      nCol = 4

      n       = iSYS(3)   ! index of triangle
      dT      = DDATA(5)   ! time step
      ConcAvr = DDATA(5+n) ! mean value of 2u^{n-1}-u^{n}/2

c      write(*,*) DDATA(1),DDATA(2),DDATA(3),DDATA(4)
c ... set up templates
      Do i = 1, nRow
         templateR(i) = Vdof
         templateC(i) = Vdof

      End do

!!!==============================================
      do i=1,4
      u_loc(i) = DDATA(5+iSYS(21)+iSYS(3+i))
      enddo
      DDATASIMP(1) = 1.5/dT
      IDATASIMP(1) = 1

c ... compute the stiffness matrix
      label = lbE
!!!!!!!!!!!!!!!!!!!!!!!!!!!
      Call fem3Dtet(XY1, XY2, XY3, XY4,
     &              IDEN, FEM_P1, IDEN, FEM_P1,
     &          label, ANI_D1x1_scalar, DDATASIMP, IDATASIMP, iSYS, 2,
     &              4, D, ir, ic)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      Call fem3Dtet(XY1, XY2, XY3, XY4,
     &              GRAD, FEM_P1, GRAD, FEM_P1,
     &              label, Ddiff, DDATA, IDATA, iSYS, 1,
     &              4, A, ir, ic)

c ... compute the convection matrix
      Call fem3Dtet(XY1, XY2, XY3, XY4,
     &              GRAD, FEM_P1, IDEN, FEM_P1,
     &              label, Dconv, DDATA, IDATA, iSYS, 2,
     &              4, B, ir, ic)

      Do i = 1, 4
         Do j = 1, 4
            A(i, j) = A(i, j) + B(i, j)
         End do
      End do

c ... compute the mass matrix
      Call fem3Dtet(XY1, XY2, XY3, XY4,
     &              IDEN, FEM_P1, IDEN, FEM_P1,
     &              label, ANI_Dnull, DDATA, IDATA, iSYS, 2,
     &              4, B, ir, ic)
c ... add scaled mass matrix by 1.5/DeltaT
      Do i = 1, 4
         Do j = 1, 4
            A(i, j) = A(i, j) + B(i, j) * 1.5d0 / dT
         End do
      End do

c ... compute right hand side
      Call fem3Dtet(XY1, XY2, XY3, XY4,
     &              IDEN, FEM_P0, IDEN, FEM_P1,
     &              lbE, Drhs, DDATA, IDATA, iSYS, 1,
     &              LDA, F, ir, ic)

c ... SUPG contribution
      Call fem3Dtet(XY1, XY2, XY3, XY4,
     &              IDEN, FEM_P0, IDEN, FEM_P0,
     &              lbE, Drhs, DDATA, IDATA, iSYS, 1,
     &              1, FF, ir, ic)

      Call fem3Dtet(XY1, XY2, XY3, XY4,
     &              GRAD, FEM_P1, IDEN, FEM_P0,
     &              label, Dconv, DDATA, IDATA, iSYS, 1,
     &              4, C, ir, ic)

      vol = dabs(calVol(XY1, XY2, XY3, XY4))
      Call tet_center(XY1, XY2, XY3, XY4, x, y, z)

      idum = Ddiff(x, y, z, label, DDATA, IDATA, iSYS, DiffCoef)
      idum = Dconv(x, y, z, label, DDATA, IDATA, iSYS, ConvCoef)

      Dbb = 0D0
      Do i = 1, 3
         Do j = 1, 3
            Dbb = Dbb + DiffCoef(i,j) * ConvCoef(1,i) * ConvCoef(1,j)
         End do
      End do

      bb  = ConvCoef(1,1)**2 + ConvCoef(1,2)**2 + ConvCoef(1,3)**2
      bnrm = dsqrt(bb)

      h = tet_diameter(XY1, XY2, XY3, XY4)

      If(bb.NE.0D0) Then
          Dbb = Dbb / bb
          Pe = h * bnrm / Dbb
      Else
          Pe = 0D0
      End if

      delta = 0D0
      If(Pe.GE.1) Then
c        delta = (h / (2*bnrm)) * (1D0 - 1D0/Pe)
         delta = 1D-2
      End if

      Do i = 1, 4
         Do j = 1, 4
            A(i, j) = A(i, j) + delta * C(1,i) *
     &              ( C(1, j) / vol + 0.5d0 / dT )
         End do
      End do
      Do i = 1, 4
         F(i) = F(i) + delta * C(1, i) * ( FF / vol + ConcAvr / dT )
      End do

      Do i = 1, 4
         res(i) = 0.0
 	do j=1,4
		res(i) = res(i) + D(i,j)*u_loc(j)
	enddo
!         if(iSYS(3+i).eq.1) then
!           write(*,*) F(i),res(i)
! 	endif
!         F(i) = F(i) + res(i)
      End do

c ... impose boundary conditions (assume nRow = nCol) at nodes of triangle
      Do k = 1, 4
         If(lbP(k).ne.0) Then
            If(k.EQ.1) Then
               x = XY1(1)
               y = XY1(2)
               z = XY1(3)
            ElseIf(k.EQ.2) Then
               x = XY2(1)
               y = XY2(2)
               z = XY2(3)
            ElseIf(k.EQ.3) Then
               x = XY3(1)
               y = XY3(2)
               z = XY3(3)
            ElseIf(k.EQ.4) Then
               x = XY4(1)
               y = XY4(2)
               z = XY4(3)
            End if

            ibc = Dbc(x, y, z, lbP(k), DDATA, IDATA, iSYS, eBC)

            If(ibc.EQ.BC_DIRICHLET) Then
               Call applyDIR(LDA, nRow, A, F, k, eBC(1))
            End if
         End if
      End do

      Do i = 1, 4
         res(i) = 0.0
 	do j=1,4
		res(i) = res(i) + D(i,j)*u_loc(j)
	enddo
         F(i) = F(i) + res(i)
      End do
      Return
      End

C ======================================================================
C  Diffusion tensor
C ======================================================================
      Integer Function Ddiff(x, y, z, label, DDATA, IDATA, iSYS, Coef)
      include 'fem3Dtet.fd'

      Real*8  x, y, z, DDATA(*), Coef(9, 9)
      Integer label, IDATA(*), iSYS(*)
C ======================================================================
      iSYS(1) = 3
      iSYS(2) = 3

      Do i = 1, 3
         Do j = 1, 3
            Coef(i, j) = 0D0
         End do
         Coef(i, i) = DDATA(1)
      End do

      Ddiff = TENSOR_SYMMETRIC

      Return
      End

C ======================================================================
C  Convection tensor
C ======================================================================
      Integer Function Dconv(x, y, z, label, DDATA, IDATA, iSYS, Conv)
      include 'fem3Dtet.fd'
C ======================================================================
      Real*8  x, y, z, DDATA(*), Conv(9, 9)
      Integer label, IDATA(*), iSYS(*)
C ======================================================================
      iSYS(1) = 1
      iSYS(2) = 3

      Conv(1,1) = DDATA(2)
      Conv(1,2) = DDATA(3)
      Conv(1,3) = DDATA(4)

      Dconv = TENSOR_GENERAL

      Return
      End

C ======================================================================
C Boundary condition
C ======================================================================
      Integer Function Dbc(x, y, z, label, DDATA, IDATA, iSYS, eBC)
      Include 'assemble.fd'
C ======================================================================
      Real*8  x, y, z, DDATA(*), eBC(*)
      Integer label, IDATA(*), iSYS(*)

C ======================================================================
      iSYS(1) = 1
      iSYS(2) = 1

      If(label.EQ.1) Then
         Dbc = BC_DIRICHLET
         eBC(1) = 0D0
      Else If(label.EQ.2) Then
         Dbc = BC_DIRICHLET
         eBC(1) = 1D0
      Else
         Write(*,*) 'Dbc: wrong label=', label
         Stop
      End if

      Return
      End

C ======================================================================
C Right hand side
C ======================================================================
      Integer Function Drhs(x, y, z, label, DDATA, IDATA, iSYS, F)
      Include 'fem3Dtet.fd'
C ======================================================================
      Real*8  x, y, z, DDATA(*), F(*)
      Integer label, IDATA(*), iSYS(*)
C ======================================================================
      iSYS(1) = 1
      iSYS(2) = 1

      F(1) = 0D0
      Drhs = TENSOR_SCALAR

      Return
      End


      REAL FUNCTION RDEWPT(RTEMP,RHUM)
C----------------------------------------------------------------------C
C                                                                      C
C     DEWPOINT CALCULATION FROM TEMPERATURE IN CELSIUS - RTEMP         C
C                               RELATIVE HUMIDITY - RHUM               C
C     USING THE MAGNUS FORMULA WITH CONSTANTS SUITABLE FOR A           C
C     TEMPERATURE RANGE OF -45 TO 60 CELSIUS                           C
C                                                                      C
C     AUTHOR: TJH 28-01-2017                                           C
C                                                                      C
C----------------------------------------------------------------------C
      REAL RH
C
      RH=(LOG10(RHUM)-2)/0.4343+(17.62*RTEMP)/(243.12+RTEMP)
      RDEWPT=243.12*RH/(17.62-RH)
      RETURN
      END

      REAL FUNCTION SPRESS(RHPA, RALT, RTMP)
C----------------------------------------------------------------------C
C                                                                      C
C     ADJUST ABSOLUTE PRESSURE IN hPa (MB) TO SURFACE PRESSURE         C
C     FOR USE IN WEATHER FORECASTING                                   C
C                                                                      C
C     RHPA - ABSOLUTE PRESSURE                                         C
C     RALT - HEIGHT ABOVE SEA LEVEL                                    C
C     RTMP - CURRENT TEMPERATURE                                       C
C                                                                      C
C     AUTHOR: TJH 21-07-2018                                           C
C                                                                      C
C----------------------------------------------------------------------C
      SPRESS=RHPA*(1-(0.0065*RALT)/(RTMP+0.0065*RALT+273.15))**(-5.257)
      RETURN
      END

      REAL FUNCTION COMTEM(ITEMPF)
C----------------------------------------------------------------------C
C                                                                      C
C     CONVERT BME280 TEMPERATURE TO CELSIUS                            C
C                                                                      C
C     ITEMPF - THE VALUE RETURNED FROM THE BME280 TO CONVERT           C
C                                                                      C
C     AUTHOR: TJH 26-07-2018                                           C
C                                                                      C
C----------------------------------------------------------------------C
      COMTEM=((ITEMPF*5+128)/256)/100.0
      RETURN
      END

      SUBROUTINE MFCAST(PDIFF,CIND,CFORE)
C----------------------------------------------------------------------C
C                                                                      C
C     MAKE FORECAST BASED ON 3 HOURLY PRESSURE DIFFERENCE              C
C                                                                      C
C     PDIFF - PRESSURE DIFFERENCE IN LAST THREE HOURS                  C
C     CIND  - CHANGE INDICATOR STRING                                  C
C     CFORE - FORECAST STRING                                          C
C                                                                      C
C     AUTHOR: TJH 26-07-2018                                           C
C                                                                      C
C----------------------------------------------------------------------C
      REAL PDIFF
      CHARACTER*2 CIND
      CHARACTER*20 CFORE
C
      IF (PDIFF.LE.-0.5 .AND. PDIFF.GE.-3.0) THEN
         CIND="v "
         CFORE=" Some rain possible "
      ELSE IF (PDIFF.LT.-3.0 .AND. PDIFF.GE.-6.0) THEN
         CIND="vv"
         CFORE="Wind,rain;fine later"
      ELSE IF (PDIFF.LT.-6.0) THEN
         CIND="vv"
         CFORE="    ** STORMY **    "
      ELSE IF (PDIFF.GE.0.5 .AND. PDIFF.LE.6.0) THEN
         CIND="^ "
         CFORE="Fine, becoming drier"
      ELSE IF (PDIFF.GT.6.0) THEN
         CIND="^^"
         CFORE="Becoming dry & windy"
      ELSE
         CIND="--"
         CFORE="No change in weather"
      END IF
      RETURN
      END

      SUBROUTINE ZFCAST(IMON,PRESS,PDIFF,CIND,CFORE)
C----------------------------------------------------------------------C
C                                                                      C
C     MAKE FORECAST BASED ON 3 HOURLY PRESSURE DIFFERENCE USING AN     C
C     ALGORITHM BASED ON THE ZAMBRETTI FORECASTER                      C
C                                                                      C
C     IMON  - MONTH NUMBER                                             C
C     PRESS - CURRENT PRESSURE IN MILLIBARS, ADJUSTED FOR SEA LEVEL    C
C     PDIFF - PRESSURE DIFFERENCE IN LAST THREE HOURS                  C
C     CIND  - CHANGE INDICATOR STRING                                  C
C     CFORE - FORECAST STRING                                          C
C                                                                      C
C     AUTHOR: TJH 30-08-2019                                           C
C                                                                      C
C----------------------------------------------------------------------C
      INTEGER IMON
      REAL PRESS
      REAL PDIFF
      CHARACTER*2 CIND
      CHARACTER*20 CFORE
      INTEGER IZ
      CHARACTER CZFALL(9)*20, CZSTDY(10)*20, CZRISE(13)*20
      INTEGER IPFALL(9), IPSTDY(10), IPRISE(13)
      COMMON /ZAMBRT/ CZFALL, CZSTDY, CZRISE, IPFALL, IPSTDY, IPRISE
C
C     CALCULATE FORECAST MESSAGE LOCATION (IZ) IN CZFOR BY USING THE
C     CURRENT PRESSURE AND PRESSURE TREND
C
      IF (PDIFF.LE.-1.25) THEN
C
C        PRESSURE IS FALLING
C
         CIND="vv"
         IF (PRESS.GE.IPFALL(1)) THEN
            IZ=1
         ELSE IF (PRESS.GE.IPFALL(2)) THEN
            IZ=2
         ELSE IF (PRESS.GE.IPFALL(3)) THEN
            IZ=3
         ELSE IF (PRESS.GE.IPFALL(4)) THEN
            IZ=4
         ELSE IF (PRESS.GE.IPFALL(5)) THEN
            IZ=5
         ELSE IF (PRESS.GE.IPFALL(6)) THEN
            IZ=6
         ELSE IF (PRESS.GE.IPFALL(7)) THEN
            IZ=7
         ELSE IF (PRESS.GE.IPFALL(8)) THEN
            IZ=8
         ELSE
            IZ=9
         END IF
C
C        IF IT IS WINTER AND PRESSURE IS FALLING THEN THE
C        THE FORECAST IS 1 STEP WORSE (IZ+1) THAN
C        THE CURRENT PRESSURE ALONE PREDICTS.
C        WINTER IS DECEMBER, JANUARY AND FEBRUARY.
C
         IF (IMON.EQ.12 .OR. IMON.LE.2) THEN
            IZ=IZ+1
C
C           CHECK IZ NOT OUT OF RANGE - SHOULDN'T HAPPEN, BUT NEITHER
C           SHOULD MANMADE CLIMATE CHANGE
C
            IF (IZ.GT.9) THEN
               IZ=9
            END IF
         END IF
C
C        SET THE FORECAST STRING
C
         CFORE=CZFALL(IZ)
      ELSE IF (PDIFF.GE.1.25) THEN
C
C        PRESSURE IS RISING
C
         CIND="^^"
         IF (PRESS.GE.IPRISE(1)) THEN
            IZ=1
         ELSE IF (PRESS.GE.IPRISE(2)) THEN
            IZ=2
         ELSE IF (PRESS.GE.IPRISE(3)) THEN
            IZ=3
         ELSE IF (PRESS.GE.IPRISE(4)) THEN
            IZ=4
         ELSE IF (PRESS.GE.IPRISE(5)) THEN
            IZ=5
         ELSE IF (PRESS.GE.IPRISE(6)) THEN
            IZ=6
         ELSE IF (PRESS.GE.IPRISE(7)) THEN
            IZ=7
         ELSE IF (PRESS.GE.IPRISE(8)) THEN
            IZ=8
         ELSE IF (PRESS.GE.IPRISE(9)) THEN
            IZ=9
         ELSE IF (PRESS.GE.IPRISE(10)) THEN
            IZ=10
         ELSE IF (PRESS.GE.IPRISE(11)) THEN
            IZ=11
         ELSE IF (PRESS.GE.IPRISE(12)) THEN
            IZ=12
         ELSE
            IZ=13
         END IF
C
C        IF IT IS SUMMER AND PRESSURE IS RISING THEN THE
C        THE FORECAST IS 1 STEP BETTER (IZ-1) THAN
C        THE CURRENT PRESSURE ALONE PREDICTS.
C        SUMMER IS JUNE, JULY AND AUGUST.
C
         IF (IMON.GE.6 .AND. IMON.LE.8) THEN
            IZ=IZ-1
C
C           CHECK IZ NOT OUT OF RANGE - SHOULDN'T HAPPEN, BUT NEITHER
C           SHOULD MANMADE CLIMATE CHANGE
C
            IF (IZ.LT.1) THEN
               IZ=1
            END IF
         END IF
C
C        SET THE FORECAST STRING
C
         CFORE=CZRISE(IZ)
      ELSE
C
C        PRESSURE IS STEADY
C
         CIND="--"
         IF (PRESS.GE.IPSTDY(1)) THEN
            IZ=1
         ELSE IF (PRESS.GE.IPSTDY(2)) THEN
            IZ=2
         ELSE IF (PRESS.GE.IPSTDY(3)) THEN
            IZ=3
         ELSE IF (PRESS.GE.IPSTDY(4)) THEN
            IZ=4
         ELSE IF (PRESS.GE.IPSTDY(5)) THEN
            IZ=5
         ELSE IF (PRESS.GE.IPSTDY(6)) THEN
            IZ=6
         ELSE IF (PRESS.GE.IPSTDY(7)) THEN
            IZ=7
         ELSE IF (PRESS.GE.IPSTDY(8)) THEN
            IZ=8
         ELSE IF (PRESS.GE.IPSTDY(9)) THEN
            IZ=9
         ELSE
            IZ=10
         END IF
C
C        SET THE FORECAST STRING
C
         CFORE=CZSTDY(IZ)
      END IF
C
C     DEBUG ONLY
C     WRITE (*,*) PRESS, " ", IMON, " ", IZ, " ", CIND, " ", CFORE
C
      RETURN
      END

      BLOCK DATA
C----------------------------------------------------------------------C
C                                                                      C
C     INITIALISE THE COMMON BLOCK FOR THE ZAMBRETTI FORECAST TEXTS     C
C     MODIFIED TO FIT INTO 20 CHARACTERS DUE TO THE 4 LINE LCD DISPLAY C
C     BEING USED. THE IPXXXX ARRAYS ARE THE THRESHOLDS FOR EACH        C
C     FORECAST IN MILLIBARS BEFORE CORRECTING FOR SEASON AND WIND      C
C     DIRECTION                                                        C
C                                                                      C
C     AUTHOR: TJH 30-08-2019                                           C
C                                                                      C
C----------------------------------------------------------------------C
      CHARACTER CZFALL(9)*20, CZSTDY(10)*20, CZRISE(13)*20
      INTEGER   IPFALL(9), IPSTDY(10), IPRISE(13)

      COMMON /ZAMBRT/ CZFALL, CZSTDY, CZRISE, IPFALL, IPSTDY, IPRISE

      DATA CZFALL(1) /'Settled Fine       '/
      DATA CZFALL(2) /'Fine Weather       '/
      DATA CZFALL(3) /'Fine : Less Settled'/
      DATA CZFALL(4) /'Fairly Fine Showery'/
      DATA CZFALL(5) /'Showery : Unsettled'/
      DATA CZFALL(6) /'Unsettled : Rain   '/
      DATA CZFALL(7) /'Some rain : Worse  '/
      DATA CZFALL(8) /'Rain : Unsettled   '/
      DATA CZFALL(9) /'V. Unsettled : Rain'/

      DATA IPFALL /1050,1040,1024,1018,1010,1004,998,991,985/

      DATA CZSTDY(1) /'Settled Fine       '/
      DATA CZSTDY(2) /'Fine Weather       '/
      DATA CZSTDY(3) /'Fine : Showers Poss'/
      DATA CZSTDY(4) /'Fair : Showers Lkly'/
      DATA CZSTDY(5) /'Showers : Bright In'/
      DATA CZSTDY(6) /'Changeable : Rain  '/
      DATA CZSTDY(7) /'Unsettled : Rain   '/
      DATA CZSTDY(8) /'Frequent Rain      '/
      DATA CZSTDY(9) /'V. Unsettled : Rain'/
      DATA CZSTDY(10) /'Stormy : Much Rain '/

      DATA IPSTDY /1033,1023,1014,1008,1000,994,989,981,974,960/

      DATA CZRISE(1) /'Settled Fine       '/
      DATA CZRISE(2) /'Fine Weather       '/
      DATA CZRISE(3) /'Becoming Fine      '/
      DATA CZRISE(4) /'Fairly Fine Imprvng'/
      DATA CZRISE(5) /'Fairly Fine Showers'/
      DATA CZRISE(6) /'Showery : Improving'/
      DATA CZRISE(7) /'Changeable : Mendng '/
      DATA CZRISE(8) /'Unsettled : Clearng'/
      DATA CZRISE(9) /'Unsettled : May Imp'/
      DATA CZRISE(10) /'Unsettled : Fine In'/
      DATA CZRISE(11) /'Very Unsettled     '/
      DATA CZRISE(12) /'Stormy : Poss Imprv'/
      DATA CZRISE(13) /'Stormy : Much Rain '/

      DATA IPRISE
     +/1030,1022,1012,1007,1000,995,990,984,978,970,965,959,947/

      END


      subroutine runP_00iiii(i1,i2,i3,i4,m0sq,Gr,Czero4,N0)
      implicit none
      include 'TRconstants.f'
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,i1,i2,i3,i4,m,n,np
      parameter(np=3)
      double precision m0sq,Gr(np,np)
      double complex Czero4(z4max,-2:0),bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gr(n,m)*Dv(diiiiii(z6(n,m,i1,i2,i3,i4))+N0,ep)
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=4d0*Dv(dzziiii(z4(i1,i2,i3,i4))+N0,ep-1)

      Dv(dzziiii(z4(i1,i2,i3,i4))+N0,ep)=
     . (pole
     . +2d0*Czero4(z4(i1,i2,i3,i4),ep)
     . +2d0*m0sq*Dv(diiii(z4(i1,i2,i3,i4))+N0,ep)
     . -bit)/24d0
      enddo

      return
      end


c     end ranfkbinary

c==============================================================================

      subroutine ranfmodmult( A, B, C )

c------------------------------------------------------------------------------
c
c     Ths routine calculates the product of the first two arguments.  All three
c     arguments are represented as arrays of 12-bit integers, each making up
c     the digits of one radix-4096 number.  The multiplication is done
c     piecemeal.
c
c     It returns the product in the third argument.
c
c------------------------------------------------------------------------------

      include 'pranf.inc'

      integer A, B, C, j1, j2, j3, j4, k1, k2, k3, k4
      integer a1,a2,a3,b1,b2,b3

      dimension A( IRandNumSize ),
     1     B( IRandNumSize ),
     2     C( IRandNumSize )

c------------------------------------------------------------------------------

c     write( *, 10 )
 10   format( ' ranfmodmult', /, '------------' )

c     j1 = A( 1 ) * B( 1 )
c     j2 = A( 1 ) * B( 2 ) + A( 2 ) * B( 1 )
c     j3 = A( 1 ) * B( 3 ) + A( 2 ) * B( 2 ) + A( 3 ) * B( 1 )
c     j4= A( 1 ) * B( 4 ) + A( 2 ) * B( 3 ) + A( 3 ) * B( 2 ) + A( 4 ) * B( 1 )
      a1 = A(1)
      a2 = A(2)
      a3 = A(3)
      b1 = B(1)
      b2 = B(2)
      b3 = B(3)
      j1 = a1 * b1
      j2 = a1 * b2 + a2 * b1
      j3 = a1 * b3 + a2 * b2 + a3 * b1
      j4 = a1 * B( 4 ) + a2 * b3 + a3 * b2 + A( 4 ) * b1

      k1 = j1
      k2 = j2 + k1 / 4096
      k3 = j3 + k2 / 4096
      k4 = j4 + k3 / 4096

      C( 1 ) = mod( k1, 4096 )
      C( 2 ) = mod( k2, 4096 )
      C( 3 ) = mod( k3, 4096 )
      C( 4 ) = mod( k4, 4096 )

c     write( *, 20 )
 20   format( '  leaving ranfmodmult' )

      return
      end


program AOC

  integer :: ios, u = 42, i
  integer(kind=16) :: j, k
  integer, dimension(300) :: fi
  integer(kind=16), dimension(0:8) :: fs

  open(unit=u, file='day_6.txt', iostat=ios)
  read(u, *, iostat=ios) fi

  do i = 0, 8
     fs(i) = 0
  end do

  do i = 1, 300
     fs(fi(i)) = fs(fi(i)) + 1
  end do

  do i = 1, 256
     k = fs(0)
     do j = 0, 7
        fs(j) = fs(j + 1)
     end do
     fs(8) = k
     fs(6) = fs(6) + k
  end do

  j = 0
  do i = 0, 8
     j = j + fs(i)
  end do

  print*, j

  close(u)
end program AOC


!=====================================================================*
!                                                                     *
!   Software Name : HACApK                                            *
!         Version : 0.2.0                                             *
!                                                                     *
!   License                                                           *
!     This file is part of HACApK.                                    *
!     HACApK is a free software, you can use it under the terms       *
!     of The MIT License (MIT). See LICENSE file and User's guide     *
!     for more details.                                               *
!                                                                     *
!   ppOpen-HPC project:                                               *
!     Open Source Infrastructure for Development and Execution of     *
!     Large-Scale Scientific Applications on Post-Peta-Scale          *
!     Supercomputers with Automatic Tuning (AT).                      *
!                                                                     *
!   Sponsorship:                                                      *
!     Japan Science and Technology Agency (JST), Basic Research       *
!     Programs: CREST, Development of System Software Technologies    *
!     for post-Peta Scale High Performance Computing.                 *
!                                                                     *
!   Copyright (c) 2014 <Akihiro Ida and Takeshi Iwashita>             *
!                                                                     *
!=====================================================================*
module m_HACApK_calc_entry_ij

use m_ppohBEM_matrix_element_ij
!*** type :: st_HACApK_calc_entry
  type :: st_HACApK_calc_entry
  real*8,pointer :: ao(:)
  integer :: nd,lp61
  integer :: nond,nofc,number_element_dof,nond_on_face,nint_para_fc,ndble_para_fc
  integer,pointer :: int_para_fc(:,:), face2node(:,:)
  real*8,pointer  :: dble_para_fc(:,:)
  type(coordinate),pointer :: np(:)

  real*8,pointer :: zx(:),zy(:),zz(:)
  end type st_HACApK_calc_entry

public :: HACApK_entry_ij

contains
!***HACApK_entry_ij
  real*8 function HACApK_entry_ij(i, j, zbemv)
  type(st_HACApK_calc_entry) :: zbemv

  HACApK_entry_ij=ppohBEM_matrix_element_ij(i, j, &
                                            zbemv%nond, zbemv%nofc, zbemv%nond_on_face, zbemv%np, &
                                            zbemv%int_para_fc, zbemv%nint_para_fc, zbemv%dble_para_fc, &
                                            zbemv%ndble_para_fc, zbemv%face2node)

  if(zbemv%lp61==3) HACApK_entry_ij=HACApK_entry_ij*zbemv%ao(i)*zbemv%ao(j)

end function HACApK_entry_ij

endmodule m_HACApK_calc_entry_ij


!> This module contains the necessary subroutines
!! and functions to deal with Hamiltonians in the diabatic basis
!! and will be extended in a future version to deal with adiabatic
!! basis
MODULE hamiltonians
  USE kinds
  IMPLICIT NONE
  REAL(dp), ALLOCATABLE :: hel(:,:)

CONTAINS

  !> Allocates the electronic (system) Hamiltonian to
  !! be a matrix of size nstate X nstate
  SUBROUTINE initialize_hel
    USE input_output
    IMPLICIT NONE

    ALLOCATE( hel(nstate,nstate) )

  END SUBROUTINE initialize_hel

  !> Reads the input electronic (or system) Hamiltonian
  !! from a file called "hel.in"
  SUBROUTINE read_hel
    USE input_output
    IMPLICIT NONE
    INTEGER :: i,j

    OPEN(UNIT=10, FILE=INPHEL)
    DO i=1,nstate
       READ(10,*) ( hel(j,i), j=1, nstate)
    END DO
    CLOSE(10)

  END SUBROUTINE read_hel

  !> Deallocates the electronic (system) Hamiltonian
  SUBROUTINE finalize_hel
    USE input_output
    IMPLICIT NONE

    DEALLOCATE( hel )

  END SUBROUTINE finalize_hel

  !> Takes the bath position and uses electronic hamiltonian to calculate hel + V(x_bath)
  !! including the harmonic potential energy of the bath.
  FUNCTION diabatic_bilinear_coupling_hamiltonian(x_b,coupling_matrix) RESULT(res)
    USE kinds
    USE input_output
    USE harmonic_bath
    IMPLICIT NONE
    INTEGER :: i,j
    REAL(dp), INTENT(in) :: x_b(:)
    REAL(dp), INTENT(in) :: coupling_matrix(:,:)
    REAL(dp) :: res(nstate, nstate)

    res = hel
    DO i=1, nstate
       DO j=1, nbath*nosc
          res(i, i) = res(i, i) + coupling_matrix(j,i) * x_b(j) !+ 0.5_dp * omega(j)**2 * x_b(j)**2
       END DO
    END DO

  END FUNCTION diabatic_bilinear_coupling_hamiltonian

END MODULE hamiltonians


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
subroutine init_Et
  use global_variables
  implicit none
  real(8) :: tt,xx
  integer :: it

  Et = 0d0
  do it = 0,Nt
    tt = dt*it
    if(tt <= Tpulse)then
      xx = tt - 0.5d0*Tpulse
      Et(3,it) = E0*sin(omega0*xx)*cos(pi*xx/Tpulse)**2
    end if
  end do

end subroutine init_Et


program euler_551
   use EulerCommon
   integer(int64), parameter :: iMax=10**15
   integer(int64) :: i=1, total=0

   print *,a(iMax)

contains
   recursive function a(n) result(R)
      integer(int64), intent(in) :: n
      integer(int64)  :: R, k
      if (n<=1) then
         R = 1
      else
         k = a(n-1)
         R = k + ???
      end if
   end function

end program euler_551


      subroutine readdiskdf(filename1,ibuf)

      include 'commonblocks'

      integer*4 ibuf(15),jbuf(15),kbuf(15)
      character*30 filename, filename1

      common /fileroot/ filename

      filename1 = 'dbh.dat'

      call readharmfile(filename1,ibuf,jbuf,kbuf)
      filename = filename1

c
c Read in the correction functions
c
      open(17,file='cordbh.dat',status='old')
      read(17,'(2x, 2g17.7,1x,i4)') sigr0,disksr,nrspl
      do i=0,nrspl
         read(17,*) rr(i),fdrat(i),fszrat(i)
      enddo
      close(17)
      call splined(rr(0),fdrat(0),nrspl+1,1.e32,1.e32,drat2(0))
      call splined(rr(0),fszrat(0),nrspl+1,1.e32,1.e32,szrat2(0))

      rfid = 2.5*rdisk
      call omekap(rfid,fom,fka)
      sigr = sqrt(sigr2(rfid))
      sigden = diskdensf(rfid,0.0)*2.0*zdisk

c
c a close estimate of the disk surface density
c
      sigrcrit = 3.36*sigden/fka
      qtoomre = sigr/sigrcrit

C      open(12,file='toomre.dat',status='unknown')
      ntoomre = int((outdisk + 2*drtrunc)/dr)
      xlindbladmax = 0.
      x50 = 0.
      do i=0, ntoomre
         rtoomre = float(i)*dr
         call omekap(rtoomre,fom,fka)
         sigr = sqrt(sigr2(rtoomre))
         sigden = diskdens(rtoomre,0.0)*2.0*zdisk
         sigrcrit = 3.36*sigden/fka
         qtoomre = sigr/sigrcrit
         xparam = fka*fka*rtoomre/6.283/sigden
         rcrise = fka*fka/2./fom/fom - 1.
         xlindblad = fom - fka/2.
         if(xlindblad.gt.xlindbladmax.and.i.gt.1) then
            xlindbladmax = xlindblad
            rxlindblad = rtoomre
         endif
C         write(12,666) rtoomre, qtoomre, xparam, fom,fka,rcrise
      enddo
C      close(12)
 666  format(6f16.3)
C      open(file='stability2.out',unit=10,status='replace')
C      write(10,*) xlindbladmax,rxlindblad,x50
C      close(10)

      return

      end


submodule (calculus) gradient

implicit none (type, external)

contains

module procedure grad3D1_curv_3
! grad3D1_curv_3(f,x,lbnd1,ubnd1,lbnd2,ubnd2,lbnd3,ubnd3)
!------------------------------------------------------------
!-------COMPUTE A 3D GRADIENT ALONG THE 1-DIMENSION.  IT IS EXPECTED THAT
!-------GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
!-------THEY ARE PASSED INTO THIS ROUTINE - EXCEPT FOR THE GRID.
!-------STRUCTURE.
!-------
!-------FOR THIS AND FOLLOWING CURV DERIVATIVE PROCEDURES THE UPPER
!-------AND LOWER BOUNDS FOR DIFFERENTIATION CANNOT BE DETERMINED
!-------WITHOUT ADDITIONAL ARGUMENTS SINCE STRUCTURE X CANNOT BE
!-------BE TRIMMED IN THE SAME WAY AS A NORMAL ARRAY.  ESSENTIALLY
!-------THE INPUT ARRAY "F" AND GRID NEED TO BE INDEXED DIFFERENTLY, LEADING
!-------TO TWO SEPARATE SETS ON INDICES THROUGHOUT THIS AND SIMILAR ROUTINES.
!-------
!-------ONE ISSUE ADDRESSED HERE IS THAT THE METRIC FACTORS NEED TO KNOW
!-------WHAT PART OF THE GRID THAT THEY ARE BEING USED OVER...  IE
!-------IF ANY OF THESE IS FULL GRID THEN THE HALL VERSIONS SHOUDL
!-------SHOULD BE USED FOR THE METRIC FACTORS...
!------------------------------------------------------------

integer :: ix2,ix3,lx1,lx2,lx3

!    real(wp), dimension(1:size(f,1),1:size(f,2),1:size(f,3)) :: h1,h2,h3
!! local references to the metric factors to be used in the derivative
!    real(wp), dimension(1:size(f,1)) :: dx1
!! local reference to the backward difference
real(wp), dimension(:,:,:), pointer :: h1
!! local references to the metric factors to be used in the derivative
real(wp), dimension(:), pointer :: dx1
!! local reference to the backward difference

lx1=size(f,1)
lx2=size(f,2)
lx3=size(f,3)

!! ERROR CHECKING TO MAKE SURE DIFFRENCING IS DONE OVER A CONSISTENTLY-SIZED GRID
if (lx1 /= ubnd1-lbnd1+1 .or. lx2 /= ubnd2-lbnd2+1 .or. lx3 /= ubnd3-lbnd3+1) then
  error stop '!!!  Inconsistent array and mesh sizes in grad3D1 gradient function.'
  !! just bail on it and let the user figure it out
end if

!CHOOSE THE METRIC FACTORS VARIABLES BASED ON THE SIZE OF THE X3-VARIABLE, ALSO RECAST SO THE
!INDICES USED FOR F CAN ALSO BE USED IN THE METRIC FACTOR AND DX VARIABLE
!Can avoid wasting memory and copying of metric factor arrays by recoding with pointers
!Unfortunately a pointer is not gauranteed to be contiguous in memory so I'm not sure this is the way to go
if (lx3<=x%lx3+4) then
  h1=>x%h1(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
else if (lx3<=x%lx3all+4) then
  h1=>x%h1all(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
  print *,   '! Accessing root-only grid information'
else
  error stop '!!!  Array size is larger full mesh.'
end if
dx1=>x%dx1(lbnd1:ubnd1)

!! NOW EXECUTE THE FINITE DIFFERENCES -
!! NOTE THAT LOOP INDICES ARE MEANT TO INDEX ARRAY BEING DIFFERENCED AND NOT THE MESH STRUCTURE,
!! WHICH USES INPUT BOUNDS.  TO KEEP THE CODE CLEAN I'VE ALIASED THE GRID VARS SO THAT THEY MAY BE ACCESSED BY LOOP INDEX.
do ix3=1,lx3
  do ix2=1,lx2
    grad3D1_curv_3(1,ix2,ix3) = (f(2,ix2,ix3)-f(1,ix2,ix3))/dx1(1)/h1(1,ix2,ix3)
    !! fwd diff. at beginning, note that h1 is cell-centered
    grad3D1_curv_3(2:lx1-1,ix2,ix3) = (f(3:lx1,ix2,ix3)-f(1:lx1-2,ix2,ix3)) &
                             /(dx1(3:lx1)+dx1(2:lx1-1))/h1(2:lx1-1,ix2,ix3)
    !! centered diff. in the middleq
    grad3D1_curv_3(lx1,ix2,ix3) = (f(lx1,ix2,ix3)-f(lx1-1,ix2,ix3))/dx1(lx1)/h1(lx1,ix2,ix3)
    !! backward diff. at end
  end do
end do
end procedure grad3D1_curv_3

module procedure grad3D1_curv_23
! grad3D1_curv_23(f,x,lbnd1,ubnd1,lbnd2,ubnd2,lbnd3,ubnd3)
!------------------------------------------------------------
!-------COMPUTE A 3D GRADIENT ALONG THE 1-DIMENSION.  IT IS EXPECTED THAT
!-------GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
!-------THEY ARE PASSED INTO THIS ROUTINE - EXCEPT FOR THE GRID.
!-------STRUCTURE.
!-------
!-------FOR THIS AND FOLLOWING CURV DERIVATIVE PROCEDURES THE UPPER
!-------AND LOWER BOUNDS FOR DIFFERENTIATION CANNOT BE DETERMINED
!-------WITHOUT ADDITIONAL ARGUMENTS SINCE STRUCTURE X CANNOT BE
!-------BE TRIMMED IN THE SAME WAY AS A NORMAL ARRAY.  ESSENTIALLY
!-------THE INPUT ARRAY "F" AND GRID NEED TO BE INDEXED DIFFERENTLY, LEADING
!-------TO TWO SEPARATE SETS ON INDICES THROUGHOUT THIS AND SIMILAR ROUTINES.
!-------
!-------ONE ISSUE ADDRESSED HERE IS THAT THE METRIC FACTORS NEED TO KNOW
!-------WHAT PART OF THE GRID THAT THEY ARE BEING USED OVER...  IE
!-------IF ANY OF THESE IS FULL GRID THEN THE HALL VERSIONS SHOUDL
!-------SHOULD BE USED FOR THE METRIC FACTORS...
!------------------------------------------------------------

integer :: ix2,ix3,lx1,lx2,lx3

!    real(wp), dimension(1:size(f,1),1:size(f,2),1:size(f,3)) :: h1,h2,h3
!! local references to the metric factors to be used in the derivative
!    real(wp), dimension(1:size(f,1)) :: dx1
!! local reference to the backward difference
real(wp), dimension(:,:,:), pointer :: h1
!! local references to the metric factors to be used in the derivative
real(wp), dimension(:), pointer :: dx1
!! local reference to the backward difference

lx1=size(f,1)
lx2=size(f,2)
lx3=size(f,3)

!ERROR CHECKING TO MAKE SURE DIFFRENCING IS DONE OVER A CONSISTENTLY-SIZED GRID
if (lx1 /= ubnd1-lbnd1+1 .or. lx2 /= ubnd2-lbnd2+1 .or. lx3 /= ubnd3-lbnd3+1) then
  error stop '!!!  Inconsistent array and mesh sizes in grad3D1 gradient function.'
  !! just bail on it and let the user figure it out
end if

!CHOOSE THE METRIC FACTORS VARIABLES BASED ON THE SIZE OF THE X3-VARIABLE, ALSO RECAST SO THE
!INDICES USED FOR F CAN ALSO BE USED IN THE METRIC FACTOR AND DX VARIABLE
!Can avoid wasting memory and copying of metric factor arrays by recoding with pointers
!Unfortunately a pointer is not gauranteed to be contiguous in memory so I'm not sure this is the way to go
if (lx3<=x%lx3+4) then
  h1=>x%h1(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
else if (lx3<=x%lx3all+4) then
  h1=>x%h1all(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
  print *,   '! Accessing root-only grid information'
else
  error stop '!!!  Array size is larger full mesh.'
end if
dx1=>x%dx1(lbnd1:ubnd1)

!! NOW EXECUTE THE FINITE DIFFERENCES
!! NOTE THAT LOOP INDICES ARE MEANT TO INDEX ARRAY BEING DIFFERENCED AND NOT THE MESH STRUCTURE,
!! WHICH USES INPUT BOUNDS.  TO KEEP THE CODE CLEAN I'VE ALIASED THE GRID VARS SO THAT THEY MAY BE ACCESSED BY LOOP INDEX.
do ix3=1,lx3
  do ix2=1,lx2
    grad3D1_curv_23(1,ix2,ix3) = (f(2,ix2,ix3)-f(1,ix2,ix3))/dx1(1)/h1(1,ix2,ix3)
    !! fwd diff. at beginning, note that h1 is cell-centered
    grad3D1_curv_23(2:lx1-1,ix2,ix3) = (f(3:lx1,ix2,ix3)-f(1:lx1-2,ix2,ix3)) &
                             /(dx1(3:lx1)+dx1(2:lx1-1))/h1(2:lx1-1,ix2,ix3)
    !! centered diff. in the middleq
    grad3D1_curv_23(lx1,ix2,ix3) = (f(lx1,ix2,ix3)-f(lx1-1,ix2,ix3))/dx1(lx1)/h1(lx1,ix2,ix3)
    !! backward diff. at end
  end do
end do
end procedure grad3D1_curv_23

module procedure grad3D2_curv_3
! grad3D2_curv_3(f,x,lbnd1,ubnd1,lbnd2,ubnd2,lbnd3,ubnd3)
!------------------------------------------------------------
!-------COMPUTE A 3D GRADIENT ALONG THE 2-DIMENSION.  IT IS EXPECTED THAT
!-------GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
!-------THEY ARE PASSED INTO THIS ROUTINE
!------------------------------------------------------------

integer :: ix1,ix3,lx1,lx2,lx3

real(wp), dimension(:,:,:), pointer :: h2   !local references to the metric factors to be used in the derivative
real(wp), dimension(:), pointer :: dx2    !local reference to the backward difference

lx1=size(f,1)
lx2=size(f,2)
lx3=size(f,3)

if (lx2>1) then    !if we have a singleton dimension then we are doing a 2D run and the derivatives in this direction are zero

  !ERROR CHECKING TO MAKE SURE DIFFRENCING IS DONE OVER A CONSISTENTLY-SIZED GRID
  if (lx1 /= ubnd1-lbnd1+1 .or. lx2 /= ubnd2-lbnd2+1 .or. lx3 /= ubnd3-lbnd3+1) then
    error stop '!!!  Inconsistent array and mesh sizes in gradient function.'   !just bail on it and let the user figure it out
  end if

  !CHOOSE THE METRIC FACTORS VARIABLES BASED ON THE SIZE OF THE X3-VARIABLE, ALSO RECAST SO THE
  !INDICES USED FOR F CAN ALSO BE USED IN THE METRIC FACTOR AND DX VARIABLE
  if (lx3<=x%lx3+4) then
    h2=>x%h2(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
  else if (lx3<=x%lx3all+4) then
    h2=>x%h2all(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
    print *,   '! Accessing root-only grid information'
  else
    error stop '!!!  Array size is larger full mesh.'
  end if
  dx2=>x%dx2(lbnd2:ubnd2)

  !DIFFERENCING
  do ix3=1,lx3
    do ix1=1,lx1
      grad3D2_curv_3(ix1,1,ix3)=(f(ix1,2,ix3)-f(ix1,1,ix3))/dx2(2)/h2(ix1,1,ix3)
      grad3D2_curv_3(ix1,2:lx2-1,ix3)=(f(ix1,3:lx2,ix3)-f(ix1,1:lx2-2,ix3)) &
                               /(dx2(3:lx2)+dx2(2:lx2-1))/h2(ix1,2:lx2-1,ix3)
      grad3D2_curv_3(ix1,lx2,ix3)=(f(ix1,lx2,ix3)-f(ix1,lx2-1,ix3))/dx2(lx2)/h2(ix1,lx2,lx3)
    end do
  end do
else
  grad3D2_curv_3=0._wp
end if
end procedure grad3D2_curv_3

module procedure grad3D2_curv_23
! grad3D2_curv_23(f,x,lbnd1,ubnd1,lbnd2,ubnd2,lbnd3,ubnd3)
!------------------------------------------------------------
!-------COMPUTE A 3D GRADIENT ALONG THE 2-DIMENSION.  IT IS EXPECTED THAT
!-------GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
!-------THEY ARE PASSED INTO THIS ROUTINE
!------------------------------------------------------------

integer :: ix1,ix3,lx1,lx2,lx3

real(wp), dimension(:,:,:), pointer :: h2   !local references to the metric factors to be used in the derivative
real(wp), dimension(:), pointer :: dx2    !local reference to the backward difference

lx1=size(f,1)
lx2=size(f,2)
lx3=size(f,3)

if (x%lx2>1) then    !if we have a singleton dimension then we are doing a 2D run and the derivatives in this direction are zero

  !ERROR CHECKING TO MAKE SURE DIFFRENCING IS DONE OVER A CONSISTENTLY-SIZED GRID
  if (lx1 /= ubnd1-lbnd1+1 .or. lx2 /= ubnd2-lbnd2+1 .or. lx3 /= ubnd3-lbnd3+1) then
    error stop '!!!  Inconsistent array and mesh sizes in gradient function.'
    !! just bail on it and let the user figure it out
  end if

  !CHOOSE THE METRIC FACTORS VARIABLES BASED ON THE SIZE OF THE X3-VARIABLE, ALSO RECAST SO THE
  !INDICES USED FOR F CAN ALSO BE USED IN THE METRIC FACTOR AND DX VARIABLE
  if (lx3<=x%lx3+4) then     !this is a derivative over a slab region (subgrid)
    h2=>x%h2(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
    dx2=>x%dx2(lbnd2:ubnd2)
  else if (lx3<=x%lx3all+4) then
    !! if a larger dimension was specified for x3 then assume that we are differentiating over x2all and x3all
    h2=>x%h2all(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
    dx2=>x%dx2all(lbnd2:ubnd2)
    print *,   '! Accessing root-only grid information, while taking derivative in 2-direction'
  else
    error stop '!!!  Array size is larger full mesh.'
  end if

  !DIFFERENCING
  do ix3=1,lx3
    do ix1=1,lx1
      grad3D2_curv_23(ix1,1,ix3)=(f(ix1,2,ix3)-f(ix1,1,ix3))/dx2(2)/h2(ix1,1,ix3)
      grad3D2_curv_23(ix1,2:lx2-1,ix3)=(f(ix1,3:lx2,ix3)-f(ix1,1:lx2-2,ix3)) &
                               /(dx2(3:lx2)+dx2(2:lx2-1))/h2(ix1,2:lx2-1,ix3)
      grad3D2_curv_23(ix1,lx2,ix3)=(f(ix1,lx2,ix3)-f(ix1,lx2-1,ix3))/dx2(lx2)/h2(ix1,lx2,lx3)
    end do
  end do
else
  grad3D2_curv_23=0._wp
end if
end procedure grad3D2_curv_23

module procedure grad3D3_curv_3
! grad3D3_curv_3(f,x,lbnd1,ubnd1,lbnd2,ubnd2,lbnd3,ubnd3)
!------------------------------------------------------------
!-------COMPUTE A 3D GRADIENT ALONG THE 3-DIMENSION.  IT IS EXPECTED THAT
!-------GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
!-------THEY ARE PASSED INTO THIS ROUTINE
!-------
!-------AN EXTRA STEP IS NEEDED IN THIS ROUTINE SINCE WE HAVE
!-------TO DETERMINE WHETHER THIS IS A FULL-GRID OR SUBGRID
!-------DERIVATIVE.
!------------------------------------------------------------

integer :: ix1,ix2,lx1,lx2,lx3

real(wp), dimension(:,:,:), pointer :: h3   !local references to the metric factors to be used in the derivative
real(wp), dimension(:), pointer :: dx3    !local reference to the backward difference

lx1=size(f,1)
lx2=size(f,2)
lx3=size(f,3)

!ERROR CHECKING TO MAKE SURE DIFFRENCING IS DONE OVER A CONSISTENTLY-SIZED GRID
if (lx1 /= ubnd1-lbnd1+1 .or. lx2 /= ubnd2-lbnd2+1 .or. lx3 /= ubnd3-lbnd3+1) then
  error stop '!!!  Inconsistent array and mesh sizes in gradient function.'   !just bail on it and let the user figure it out
end if

!CHOOSE THE METRIC FACTORS VARIABLES BASED ON THE SIZE OF THE X3-VARIABLE, ALSO RECAST SO THE
!INDICES USED FOR F CAN ALSO BE USED IN THE METRIC FACTOR AND DX VARIABLE
!Can avoid wasting memory and copying of metric factor arrays by recoding with pointers
!Unfortunately a pointer is not gauranteed to be contiguous in memory so I'm not sure this is the way to go
if (lx3<=x%lx3+4) then
  h3=>x%h3(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
  dx3=>x%dx3(lbnd3:ubnd3)
else if (lx3<=x%lx3all+4) then
  h3=>x%h3all(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
  dx3=>x%dx3all(lbnd3:ubnd3)
  print *,   '! Accessing root-only grid information'
else
  error stop '!!!  Array size is larger than full mesh.'
end if

!FINITE DIFFERENCING
do ix2=1,lx2
  do ix1=1,lx1
    grad3D3_curv_3(ix1,ix2,1)=(f(ix1,ix2,2)-f(ix1,ix2,1))/dx3(2)/h3(ix1,ix2,1)
    grad3D3_curv_3(ix1,ix2,2:lx3-1)=(f(ix1,ix2,3:lx3)-f(ix1,ix2,1:lx3-2)) &
                             /(dx3(3:lx3)+dx3(2:lx3-1))/h3(ix1,ix2,2:lx3-1)
    grad3D3_curv_3(ix1,ix2,lx3)=(f(ix1,ix2,lx3)-f(ix1,ix2,lx3-1))/dx3(lx3)/h3(ix1,ix2,lx3)
  end do
end do

end procedure grad3D3_curv_3

module procedure grad3D3_curv_23
! grad3D3_curv_23(f,x,lbnd1,ubnd1,lbnd2,ubnd2,lbnd3,ubnd3)
!------------------------------------------------------------
!-------COMPUTE A 3D GRADIENT ALONG THE 3-DIMENSION.  IT IS EXPECTED THAT
!-------GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
!-------THEY ARE PASSED INTO THIS ROUTINE
!-------
!-------AN EXTRA STEP IS NEEDED IN THIS ROUTINE SINCE WE HAVE
!-------TO DETERMINE WHETHER THIS IS A FULL-GRID OR SUBGRID
!-------DERIVATIVE.
!------------------------------------------------------------

integer :: ix1,ix2,lx1,lx2,lx3

real(wp), dimension(:,:,:), pointer :: h3   !local references to the metric factors to be used in the derivative
real(wp), dimension(:), pointer :: dx3    !local reference to the backward difference

lx1=size(f,1)
lx2=size(f,2)
lx3=size(f,3)

if (x%lx3>1) then    !only differentiate if we have non-singleton dimension, otherwise set to zero
  !ERROR CHECKING TO MAKE SURE DIFFRENCING IS DONE OVER A CONSISTENTLY-SIZED GRID
  if (lx1 /= ubnd1-lbnd1+1 .or. lx2 /= ubnd2-lbnd2+1 .or. lx3 /= ubnd3-lbnd3+1) then
    error stop '!!!  Inconsistent array and mesh sizes in gradient function.'   !just bail on it and let the user figure it out
  end if

  !CHOOSE THE METRIC FACTORS VARIABLES BASED ON THE SIZE OF THE X3-VARIABLE, ALSO RECAST SO THE
  !INDICES USED FOR F CAN ALSO BE USED IN THE METRIC FACTOR AND DX VARIABLE
  !Can avoid wasting memory and copying of metric factor arrays by recoding with pointers
  !Unfortunately a pointer is not gauranteed to be contiguous in memory so I'm not sure this is the way to go
  if (lx3<=x%lx3+4) then
    h3=>x%h3(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
    dx3=>x%dx3(lbnd3:ubnd3)
  else if (lx3<=x%lx3all+4) then
    h3=>x%h3all(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
    dx3=>x%dx3all(lbnd3:ubnd3)
    print *,   '! Accessing root-only grid information while differentiating in x3'
  else
    error stop '!!!  Array size is larger than full mesh.'
  end if

  !FINITE DIFFERENCING
  do ix2=1,lx2
    do ix1=1,lx1
      grad3D3_curv_23(ix1,ix2,1)=(f(ix1,ix2,2)-f(ix1,ix2,1))/dx3(2)/h3(ix1,ix2,1)
      grad3D3_curv_23(ix1,ix2,2:lx3-1)=(f(ix1,ix2,3:lx3)-f(ix1,ix2,1:lx3-2)) &
                               /(dx3(3:lx3)+dx3(2:lx3-1))/h3(ix1,ix2,2:lx3-1)
      grad3D3_curv_23(ix1,ix2,lx3)=(f(ix1,ix2,lx3)-f(ix1,ix2,lx3-1))/dx3(lx3)/h3(ix1,ix2,lx3)
    end do
  end do
else
  grad3D3_curv_23=0._wp
end if

end procedure grad3D3_curv_23

end submodule gradient