program double_quantum_well

   implicit none

   integer,  parameter :: dp = selected_real_kind(8)
   real(dp), parameter :: Zero = 0.d0, Half = 0.5d0, One = 1.d0, Two = 2.d0
   real(dp), parameter :: pi = acos(-One)

   integer,  parameter :: N = 200         ! discretization of x
   integer,  parameter :: N_basis = 500   ! number of basis functions
   real(dp), parameter :: Range_of_X = 6.d0, x0 = 1.5d0
   real(dp) :: V_pot(-N:N), X(-N:N), dx, E, Y(-N:N)

   integer :: i, Idx

   ! ... executable ...
   dx = Range_of_X/N

   ! generate the potential data
   do i = -N, N
      X(i) = dx*i
      V_pot(i) = Half*( (x(i)**2 - x0**2)**2/Two/Two/x0**2 - X(i)**2 )
   end do

   open(unit=1, file='Vpot.dat', status = 'unknown')
   do i = -N, N
      write(1, '(2f12.6)') X(i), V_pot(i)
   end do
   close(1)

   ! calculate with numeral approach
   E = -1.5d0
   call Numerov(N, X, V_pot, E, Y)
   Y = Zero
   !

   do Idx = 1, 2
      call Matrix_diagonalization(Idx, N, N_basis, X, V_pot)
   end do

contains
   !----------------------------------------------------------------------
   subroutine Numerov(Nx, X, Vpot, E, Y)
      !
      ! Purpose
      ! =======
      !   Solving one-dimensional Schrodinger equation with Numerov method.
      !
      integer,  intent(in)  :: Nx
      real(dp), intent(in)  :: X(-Nx:Nx), Vpot(-Nx:Nx)
      real(dp), intent(out) :: Y(-Nx:Nx)
      real(dp), intent(inout) :: E

      ! ... local vars ...
      integer  :: ite, i
      real(dp) :: f(-Nx:Nx), g(-Nx:Nx), dx, fac, Y_old, Emin, Emax, dE, temp(-Nx:Nx)
      logical  :: bisection = .false.

      ! ... executable ...
      write(*, *) 'Numerov calculation starts ...'
      dx = X(2) - X(1)
      Y = Zero

      ! set boundary condition at Y(-Nx) and Y(-Nx+1)

      Emin = -200.d0
      Emax =  200.d0

   iteration: do ite = 1, 10000000

         Y = Zero
         Y(-Nx) = 0.d0
         Y(-Nx+1) = 0.00001d0
         dE   = 0.0001d0

         do i = -Nx, Nx
            g(i) = 2.d0*(E - Vpot(i))
            f(i) = 1.d0 + g(i)/12.d0*dx*dx
         end do

         ! Nomerov's method
         do i = -Nx+1, Nx-1
            Y(i+1) = ((12.d0 - 10.d0*f(i))*Y(i) - f(i-1)*Y(i-1))/f(i+1)
         end do

         ! normalize the wave function Y(x)
         do i = -Nx, Nx
            Temp(i) = Y(i)**2
         end do
         call Simpson(Temp(-Nx:Nx), 2*Nx+1, dx, fac)
         Y = Y/sqrt(fac)

         if (ite == 1) Y_old = Y(Nx)

         ! monitor the boundary value of Y(Nx)
         if (ite == 1) write(*, *) 'Iteration, energy and boundary value'
         write(*, '(i10, f20.12, 4x, f20.12)') ite, E, Y(Nx)

         if (.NOT. bisection) then
            if (Y_old*Y(Nx) >= 0.d0) then
               Emin = E
               E = E + dE
               Y_old = Y(Nx)
            else
               Emax = E
               Emin = E-de
               bisection = .true.
               E = 0.5d0*(Emin+Emax)
            end if
         else
            if (Y_old*Y(Nx) >= 0 ) then
               Emin = E
               Y_old = Y(Nx)
            else
               Emax = E
            end if
            E = 0.5d0*(Emax + Emin)
            if (abs(Y(Nx)) < 1.d-8) exit
         end if

      end do iteration

      open(unit = 1, file='wave_Numerov.dat', status='unknown')
      do i = -Nx, Nx
         write(1, '(2f12.6)') X(i), Y(i)
      end do
      close(1)

   end subroutine Numerov

   !----------------------------------------------------------------------
   subroutine Matrix_diagonalization(Idx, Nx, N_basis, X, Vpot)
      !
      ! Purpose
      ! =======
      !   By using basis funtion to express the Hamiltonian in matrix form and
      ! calculate the ground state energy by diagonalizing it.
      !
      integer,  intent(in)  :: Idx, Nx, N_basis
      real(dp), intent(in)  :: X(-Nx:Nx), Vpot(-Nx:Nx)

      ! local vars
      integer   :: i, j, k, INFO, LWORK
      real(dp)  :: basis(2*Nx+1, N_basis), Ham(N_basis, N_basis), WORK(10*N_basis), W(N_basis)
      real(dp)  :: Xmax, V0, Temp(2*Nx+1)
      character(len=30) :: FLE

      Xmax = X(Nx)
      dx   = X(2) - X(1)

      ! step[1]: generating the basis functions
      basis = 0.d0
      call basis_generation(Idx, Nx, N_basis, basis)

      ! step[2]: generating the Hamiltonian matrix
      Ham = 0.d0
      do i = 1, N_basis
         do j = i, N_basis

            select case (Idx)
            case(1)
               ! eigenvectors of inifite quantum well as basis
               do k = -Nx, Nx
                  Temp(k+Nx+1) = Vpot(k)*basis(k+Nx+1, i)*basis(k+Nx+1, j)
               end do
               call Simpson(Temp, 2*Nx+1, dx, V0)
               Ham(i, j) = V0

               if (i == j) then
                  Ham(i, i) = Ham(i, i) + (dble(i)*pi)**2/8.d0/Xmax/Xmax
               end if
            case(2)
               ! eigenvectors of quantum harmonic oscillator as basis
               do k = -Nx, Nx
                  Temp(k+Nx+1) = (Vpot(k)-Half*X(k)**2)*basis(k+Nx+1, i)*basis(k+Nx+1, j)
               end do
               call Simpson(Temp, 2*Nx+1, dx, V0)
               Ham(i, j) = V0

               if (j == i)   Ham(i, i) = Ham(i, i) + 0.5d0 + dble(j-1)
            end select
            Ham(j, i) = Ham(i, j)
         end do
      end do

      LWORK = 10*N_basis
      call DSYEV( 'V', 'U', N_basis, Ham, N_basis, W, WORK, LWORK, INFO)

      if (INFO == 0) then
         write(FLE, '(a,i1,a)') 'eigenvalue-', Idx, '.dat'
         open(unit=1, file=FLE, status='unknown')

         ! multiply the coefficient (which is stored in Ham now) with the basis function
         ! to get the wave functions.
         basis = matmul(basis, Ham)  ! use basis to store Psi(x) = Sum_n c_n * Phi_n(x)

         ! renormalize the wave function
         do i = 1, N_basis
            call Simpson(basis(1:2*Nx+1, i)**2, 2*Nx+1, dx, V0)
            basis(1:2*Nx+1, i) = basis(1:2*Nx+1, i)/sqrt(V0)
         end do

         ! output results
         do i = 1, N_basis
            write(1, '(i4, f20.12)') i, W(i)
         end do
         close(1)

         write(FLE, '(a,i1,a)') 'wavefunction-', Idx, '.dat'
         open(unit=2, file=FLE, status='unknown')
         do i = 1, 2*Nx+1
            write(2, '(f12.6)', advance='no') X(i-Nx-1)
            do j = 1, N_basis
               write(2, '(f12.6)', advance='no') basis(i, j)
            end do
            write(2, *)
         end do
         close(2)
      else
         write(*, *) 'Diagonalization went wrong! aborting ...'
         stop
      end if

   end subroutine Matrix_diagonalization

   !--------------------------------------------------------------------
   subroutine basis_generation(Idx, Nx, N_basis, basis)

      integer,  intent(in)  :: Idx
      integer,  intent(in)  :: Nx, N_basis
      real(dp), intent(out) :: basis(2*Nx+1, N_basis)
      !
      ! Purposes
      ! =========
      !   This subroutine generates the basis functions for the Hamiltonian matrix.
      ! Here, two different eigenvectors can be selected by sepecifying the switcher
      ! Idx = 1  --- eigenvectors of the infinite quantum Well
      ! Idx = 2  --- eigenvectors of the quantum harmonic oscillator
      !

      ! ... local vars ...
      integer  :: i, j

      open(unit = 1, file = 'basis_function.dat', status='unknown')

      select case(Idx)
      case(1)
         write(*, *) 'case 1: eigenvector of infinite quantum well as basis functions'
         do i = 1, 2*Nx+1   ! coordinate index
            do j = 1, N_basis  ! order of basis function
               if (mod(j, 2) /= 0) then
                  ! j is odd
                  basis(i, j) = sqrt(1.d0/X(Nx))*cos(dble(j)*pi*X(i-Nx-1)/2.d0/X(Nx))
               else
                  ! j is even
                  basis(i, j) = sqrt(1.d0/X(Nx))*sin(dble(j)*pi*X(i-Nx-1)/2.d0/X(Nx))
               end if
            end do
         end do
      case(2)
         write(*, *) 'case 2: eigenvectors of quantum harmonic oscillator as basis functions'
         basis = 0.d0
         do i = 1, 2*Nx + 1   ! order of basis function
            basis(i, 1) = (1.d0/pi)**0.25*exp(-X(i-Nx-1)**2/2.d0)
            basis(i, 2) = (1.d0/pi)**0.25*exp(-X(i-Nx-1)**2/2.d0)*X(i-Nx-1)*sqrt(Two)
         end do

         do i = 1, 2*Nx + 1
            write(1, '(3f12.6)', advance='no') X(i-Nx-1), basis(i, 1), basis(i, 2)
            do j = 3, N_basis ! coordinate index
               basis(i, j) = (Two*X(i-Nx-1)*basis(i, j-1) - sqrt(Two*(j-2))*basis(i,j-2))/sqrt(Two*(j-1))
               write(1, '(f12.6)', advance='no') basis(i, j)
            end do
            write(1, *)
         end do
      end select

      close(1)

   end subroutine basis_generation

   !--------------------------------------------------------------------
   subroutine Simpson(Func, nL, h, solution)

      implicit none
      integer, intent(in)   :: nL
      real(dp), intent(in)  :: Func(nL), h
      real(dp), intent(out) :: solution

      integer :: i

     if (Mod(nL, 2) == 0) then
         print*, "nL must be odd!"
         stop
      endif

      solution = (Func(1) + Func(nL))
      do i = 2, nL-1, 2
         solution = solution + 4.d0 * Func(i)
      enddo
      do i = 3, nL-2, 2
         solution = solution + 2.d0 * Func(i)
      enddo
      solution = solution * h/3.d0

      end subroutine Simpson

end program double_quantum_well


program variables
    real :: a, b, c !entrada
    real :: d ! operación
    character(16) :: msj_salida
    character(2) :: dun ! unidad distancia

    msj_salida = "El promedio es:"
    dun = "km"
    !a = 29.0
    !b = 4.0
    !c = 6.0
    print*, "Ingrese los valores de a, b y c en ", dun
    read*, a, b, c

    d= (a + b + c) / 3.0

    print*, msj_salida, d, dun

end program variables


! { dg-do run }
program nint_1
  if (int(anint(8388609.0)) /= 8388609) call abort
  if (int(anint(0.49999997)) /= 0) call abort
  if (nint(8388609.0) /= 8388609) call abort
  if (nint(0.49999997) /= 0) call abort
  if (int(dnint(4503599627370497.0d0),8) /= 4503599627370497_8) call abort
  if (int(dnint(0.49999999999999994d0)) /= 0) call abort
  if (int(anint(-8388609.0)) /= -8388609) call abort
  if (int(anint(-0.49999997)) /= 0) call abort
  if (nint(-8388609.0) /= -8388609) call abort
  if (nint(-0.49999997) /= 0) call abort
  if (int(dnint(-4503599627370497.0d0),8) /= -4503599627370497_8) call abort
  if (int(dnint(-0.49999999999999994d0)) /= 0) call abort
end program nint_1


c ======================================================================
c User Subroutine VUMAT for Abaqus visco elastic material
c All rights of reproduction or distribution in any form are reserved.
c By Irfan Habeeb CN (PhD, Technion - IIT)
c using the formulation https://imechanica.org/files/Kelvin-Voigt-Code-Development_0.pdf
c ======================================================================
      subroutine vumat(
C Read only -
     1     nblock, ndir, nshr, nstatev, nfieldv, nprops, lanneal,
     2     stepTime, totalTime, dt, cmname, coordMp, charLength,
     3     props, density, strainInc, relSpinInc,
     4     tempOld, stretchOld, defgradOld, fieldOld,
     5     stressOld, stateOld, enerInternOld, enerInelasOld,
     6     tempNew, stretchNew, defgradNew, fieldNew,
C Write only -
     7     stressNew, stateNew, enerInternNew, enerInelasNew)
c
      include 'vaba_param.inc'
c
      dimension props(nprops), density(nblock), coordMp(nblock,*),
     1  charLength(nblock), strainInc(nblock,ndir+nshr),
     2  relSpinInc(nblock,nshr), tempOld(nblock),
     3  stretchOld(nblock,ndir+nshr),
     4  defgradOld(nblock,ndir+nshr+nshr),
     5  fieldOld(nblock,nfieldv), stressOld(nblock,ndir+nshr),
     6  stateOld(nblock,nstatev), enerInternOld(nblock),
     7  enerInelasOld(nblock), tempNew(nblock),
     8  stretchNew(nblock,ndir+nshr),
     8  defgradNew(nblock,ndir+nshr+nshr),
     9  fieldNew(nblock,nfieldv),
     1  stressNew(nblock,ndir+nshr), stateNew(nblock,nstatev),
     2  enerInternNew(nblock), enerInelasNew(nblock)
c
      character*80 cmname

      integer i, k1, k2

      real*8 E, nu, rho, eta, lambda, mu, D1(ndir+nshr,ndir+nshr),
     1 D2(ndir+nshr,ndir+nshr), D3(ndir+nshr,ndir+nshr)

c material properties
      E = props(1)            ! Young's modulus
      nu = props(2)           ! Poisson's ratio
      rho = props(3)          ! density
      eta = props(4)          ! visco-elastic coef.

      do 10 i = 1, nblock

c lame's parameters
        lambda = E*nu/((1.0d0+nu)*(1.0d0-2.0d0*nu))
        mu = E/(2.0d0*(1.0d0+nu))

c stiffness matrix with viscous effects
        D1 = 0.d0
        D2 = 0.d0
        D3 = 0.d0

        if (stepTime .gt. 0.d0) then
          do k1 = 1, ndir
            do k2 = 1, ndir
              D1(k1, k2) = lambda*(1.0d0 + 3.0d0*eta/(E*dt))
              D2(k1, k2) = lambda
            end do
            D1(k1, k1) = lambda*(1.0d0 + 3.0d0*eta/(E*dt)) +
     1        2.0d0*mu*(1.0d0 + eta/(mu*dt))
            D2(k1, k1) = lambda + 2.0d0*mu
            D3(k1, k1) = -1.0d0
          end do
c shear stress
          do k1 = ndir+1, ndir+nshr
            D1(k1, k1) = mu*(1.0d0 + eta/(mu*dt))
            D2(k1, k1) = mu
            D3(k1, k1) = -1.0d0
          end do
        else
          do k1 = 1, ndir
            do k2 = 1, ndir
              D1(k1, k2) = lambda
              D2(k1, k2) = lambda
            end do
            D1(k1, k1) = lambda + 2.0d0*mu
            D2(k1, k1) = lambda + 2.0d0*mu
            D3(k1, k1) = -1.0d0
          end do
          do k1 = ndir+1, ndir+nshr
            D1(k1, k1) = mu
            D2(k1, k1) = mu
            D3(k1, k1) = -1.0d0
          end do
        end if

c updating the state variable (old stress)
        stateNew(i, 1:ndir+nshr) = stressOld(i, 1:ndir+nshr)

c stress increment
        do k1 = 1, ndir+nshr
          do k2 = 1, ndir+nshr
            stateNew(i, k1) = stateNew(i, k1) +
     1        D1(k1, k2) * strainInc(i, k2) +
     2        D2(k1, k2) * stateOld(i,k2+ 12) +
     3        D3(k1, k2) * stressOld(i, k2)
          end do
        end do

c updating stress from statevariables
        stressNew(i, 1:ndir+nshr) = stateNew(i, 1:ndir+nshr)

c Total strain stateNew(i,13-18) = total strain
        stateNew(i, 13:ndir+nshr) = stateOld(i, 13:ndir+nshr) +
     1    strainInc(i, 1:ndir+nshr)

c updating the internal energy
        enerInternNew(k) = enerInternOld(k) +
     1    dot_product( 0.5d0*(stressOld(k, 1:ndir+nshr) +
     2    stressNew(k, 1:ndir+nshr)), strainInc(k, 1:ndir+nshr)) / rho

  10  continue
      return
      end


program pi_main

  use timer
  use omp_lib

  ! Local variables
  integer, parameter :: num_steps = 100000000 ! number of steps over which to estimate pi
  real(kind=8) :: step                        ! the step size
  integer :: ii                               ! genereric counter
  real(kind=8) :: x                           ! intermediate value
  real(kind=8) :: pi = 0.0_8                  ! overall estimate
  real(kind=8), allocatable :: sum(:)         ! variable to store partial sum
  real(kind=8) :: start, end                  ! timers
  integer :: nthreads                         ! number of OpenMP threads
  integer :: tid                              ! thread id

  real(kind=8), parameter :: PI_8 = 4.0_8 * atan(1.0_8)

  ! Get number of OpenMP threads
  !$omp parallel
  nthreads = omp_get_num_threads()
  !$omp end parallel

  allocate(sum(nthreads))

  ! step size is dependent upon the number of steps
  step = 1.0_8/num_steps

  ! Start timer
  call wtime(start)

  ! main loop
  !$omp parallel private(x,tid)
  tid = omp_get_thread_num()
  sum(tid+1) = 0.0_8
  !$omp do
  do ii = 1, num_steps
    x = (ii-0.5_8)*step
    sum(tid+1) = sum(tid+1) + (4.0_8/(1.0_8+x*x))
    !$omp flush(sum)
  end do
  !$omp end do
  !$omp end parallel

  ! Total partial sums serially
  do ii = 1, nthreads
    pi = pi + sum(ii)
  end do
  pi = pi * step

  ! Stop timer
  call wtime(end)

  ! Print result
  write(*,"(A)")         "------------------------------------"
  write(*,"(A,F19.16)") "pi is:    ", pi
  write(*,"(A,F19.16)") "error is: ", abs(pi - PI_8)
  write(*,"(A,F10.3)")   "runtime:  ", end-start
  write(*,"(A)")         "------------------------------------"

  deallocate(sum)

end program pi_main


! 7.2a в учебнике

program ex_7_2a
    implicit none

    integer                 :: size = 0, negatives = 0, Out = 0, In = 0, i = 0, minpos = 0
    integer, allocatable    :: Arr(:)
    logical, allocatable    :: mask(:)
    character(*), parameter :: output_file = "output.txt", &
                               input_file = "../data/input.txt"

    open (file=input_file, newunit=In)
        read(In, *) size
        allocate(Arr(size))
        read(In, *) Arr(:)
    close (In)

    mask = Arr < 0

    negatives = count(mask)

    Arr = [pack(Arr, mask), pack(Arr, .not. mask)]

    do i = 1, negatives
        minpos = minloc(Arr(i:negatives), 1)
        if (minpos /= 1) then
            Arr(i:negatives) = cshift(Arr(i:negatives), minpos - 1)
        endif
    enddo

    open (file=output_file, newunit=Out)
        write(Out, *) Arr(:)
    close (Out)

end program ex_7_2a


! { dg-do run }
! PR41807  data statement with nested type constructors
! Test case provided by Steve Kargl
  implicit none

  type :: a
     real :: x(3)
  end type a

  integer, parameter :: n = 3

  type(a) :: b(n)

  real, parameter :: d1(3) = (/1., 2., 3./)
  real, parameter :: d2(3) = (/4., 5., 6./)
  real, parameter :: d3(3) = (/7., 8., 9./)

  integer :: i, z(n)

  data (b(i), i = 1, n) /a(d1), a(d2), a(d3)/
  data (z(i), i = 1, n) / 1, 2, 3/

  if (any(z.ne.[1, 2, 3])) call abort
  if (any(b(1)%x.ne.[1, 2, 3]) .or. &
      any(b(2)%x.ne.[4, 5, 6]) .or. &
      any(b(3)%x.ne.[7, 8, 9])) call abort
end


! { dg-do run }
! { dg-require-effective-target fortran_large_real }
program main
  integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1)
  character(len=90) line
  real(k) :: a(3,3)
  real(k) :: b(9)
  a = 1.0_k
  a(1,3) = 0.0_k
  write (line,'(9G10.6)') transpose(a)
  write (line,'(9G10.6)') reshape(a,shape(b))
end


      program trnkey

c   TRNKEY -- program to make a numerical version of a transpostion
c     key for use (most likely) in a (cryptographic) transposition
c     cipher.  The input is a character string.
c
c   The way this works is as follows:
c     The user inputs a character string containing any ASCII
c     characters.  The characters are mapped to upper-case and
c     any non-alphabetic characters are eliminated.
c     The letters in the resulting string are then numbered
c     alphabetically, with duplicate letters being numbered from
c     left to right.
c   For instance:
c     JOANN  yields the numerical sequence 2-5-1-3-4.
c     For classical cryptographic applications, 2-5-1-3-4 would be
c     the resultant numerical version of the key.
c     For computer applications, an "inverted" form of the key, with
c     the ordinal number of "1" first, the ordinal number of "2"
c     second, etc., might be more useful.
c
c   Written by Mark Riordan   27 September 1986

      integer nkeymx
      parameter(nkeymx=160)
      integer nkey,j,inew,iold,tint
      logical debug,qchng
      character key(nkeymx)*1,tchar
      integer numkey(nkeymx)

      debug = .false.
cc	write(*,9000)
cc9000	format(' Please input the key string:')
      read(*,8000,end=666) (key(j),j=1,nkeymx)
8000  format(160a)

      inew = 0
      do 120 iold = 1, nkeymx
	if(key(iold).ge.'a' .and. key(iold).le.'z') then
	  key(iold) = char(ichar(key(iold))-32)
	endif
	if(key(iold).ge.'A' .and. key(iold).le.'Z') then
	  inew = inew + 1
	  key(inew) = key(iold)
	endif
120   continue
      nkey = inew
      if(nkey .le. 0) then
	write(*,*) 'No legal key characters were input.'
	go to 999
      endif

      if(debug) then
	write(*,9200) (key(j),j=1,inew)
9200	format(' ',160a)
      endif

c   Create an array of ordinal positions.  The sorted version of
c   this array will be the numerical version of the key.
c   Initially, for this algorithm, we start out with 1-2-3-...
c   in this array.

      do 140 j = 1, nkey
	numkey(j) = j
140   continue

c   Sort the key characters, and drag their ordinal numbers along
c   to keep track of things.

160   continue
      qchng = .false.
	do 200 j = 1, nkey-1
	  if(key(j) .gt. key(j+1)) then
	    tchar = key(j)
	    key(j) = key(j+1)
	    key(j+1) = tchar
	    tint = numkey(j)
	    numkey(j) = numkey(j+1)
	    numkey(j+1) = tint
	    qchng = .true.
	  endif
200	continue
      if(qchng) go to 160

c   The key is now sorted.

      if(debug) then
	write(*,9220) (numkey(j), j=1,nkey)
9220	format(' Row #''s in ordinal order:',40i4)
      endif

cc	open(12,file='tordkey.txt')
cc	rewind 12
      write(*,9030) (numkey(j),j=1,nkey)
9030  format(40i4)

      goto 999
666   continue
	write(*,*) 'Premature end-of-file encountered.'
	go to 999

999   continue
      end
      end


program test_henon
  ! This program just tries the code written for the assigment.
  use henondim
  use lsq
  use precision
  implicit none
  real(DP) :: d
  integer :: j,Neps
  real(DP), dimension(:), allocatable  :: eps, N

  Neps=10
  allocate(N(Neps),eps(Neps))
  eps = (/(2d0**j, j=-21,-12) /)

  call basin_alg(Neps,eps,d)
  print *, " "
  print *, "d =",d

end program test_henon


! Program to test elemental functions.
program test_elemental
   implicit none
   integer, dimension (2, 4) :: a
   integer, dimension (2, 4) :: b
   integer(kind = 8), dimension(2) :: c

   a = reshape ((/2, 3, 4, 5, 6, 7, 8, 9/), (/2, 4/))
   b = 0
   b(2, :) = e_fn (a(1, :), 1)
   if (any (b .ne. reshape ((/0, 1, 0, 3, 0, 5, 0, 7/), (/2, 4/)))) call abort
   a = e_fn (a(:, 4:1:-1), 1 + b)
   if (any (a .ne. reshape ((/7, 7, 5, 3, 3, -1, 1, -5/), (/2, 4/)))) call abort
   ! This tests intrinsic elemental conversion functions.
   c = 2 * a(1, 1)
   if (any (c .ne. 14)) call abort

   ! This triggered bug due to building ss chains in the wrong order.
   b = 0;
   a = a - e_fn (a, b)
   if (any (a .ne. 0)) call abort

   ! Check expressions involving constants
   a = e_fn (b + 1, 1)
   if (any (a .ne. 0)) call abort
contains

elemental integer(kind=4) function e_fn (p, q)
   integer, intent(in) :: p, q
   e_fn = p - q
end function
end program


!! This module makes a bimodal distribution using two maxwellians
!! one maxwellian on the left and another on the right and some sort of linear? switching in between...
!! IN 3D in velocity space and 1D in physical space...

!DIMENSIONLESS SEE NOTES FOR THE REDUCTION FORMULAS
module DGV_distributions_mod
use nrtype ! contains kind parameters (DP), (DP), (I4B) etc.

implicit none
   interface maxwelveldist
     module procedure maxwelveldist, maxwelveldist_T_vector, maxwelveldist_u_vectors, &
                                     maxwelveldist_T_vector_u_vectors
   end interface

   interface ESBGK
     module procedure ESBGK_f0
   end interface

!!!!!!!!!!!!! parameters and global variables
real (DP), parameter, private :: pi25DT = 3.141592653589793238462643d0
!!!!!!!!!!

contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! maxwelveldist (T,u_0,n,u) result (y)
!
! This function evauates the 3D velocity dimensionless maxwellian equilibrium distribution with given temperature and average velocity
! Temperature and average velocity can be arrays (corresponding to different points in x variable
!
! This function evaluates
! f_{M}(t,x,u)=(\pi T(t,x))^{-1/2} \exp(-\frac{(u-\bar{u})^2}{2RT})
!
! This is a reloadable function
!!!!!!!!!!!!!!!!!!!!!!!
!
! this is the copy when T is vector and u is scalar
function maxwelveldist_T_vector_u_vectors (T,u_0,v_0,w_0,n,u,v,w) result (y)
   real (DP), dimension (:), intent (in) :: T    ! temperature parameter (may depend on x)
   real (DP), dimension (:), intent (in) :: n    ! density parameter (may depend on x)
   real (DP), dimension (:), intent (in) :: u_0,v_0,w_0  ! average velocity (may depend on x)
   !!! T,n,u_0 must be the same size !!!
   real (DP), dimension (:), intent (in) :: u,v,w    ! value of the velocity variable
   real (DP), dimension (size(T),size(u))  :: y ! value of the dencity for this values of u and T
!!!
   real (DP), dimension (size(T))  :: beta ! local variable  to keep temporary results
   integer (I4B) :: i ! local counter
!!!
beta=sqrt(pi25DT*T)*(pi25DT*T)
do i=1,size(u)
 y(:,i) = n*exp(-((u(i)-u_0)*(u(i)-u_0)+(v(i)-v_0)*(v(i)-v_0)+&
                   (w(i)-w_0)*(w(i)-w_0))/max(T,0.0000001_DP))/beta
end do
end function maxwelveldist_T_vector_u_vectors

! this is the copy when T is vector and u is scalar
function maxwelveldist_T_vector (T,u_0,v_0,w_0,n,u,v,w) result (y)
   real (DP), dimension (:), intent (in) :: T    ! temperature parameter (may depend on x)
   real (DP), dimension (:), intent (in) :: n    ! density parameter (may depend on x)
   real (DP), dimension (:), intent (in) :: u_0, v_0,w_0  ! average velocity (may depend on x)
   !!! T,n,u_0 must be the same size !!!
   real (DP), intent (in) :: u,v,w    ! value of the velocity variable
   real (DP), dimension (size(T))  :: y ! value of the dencity for this values of u and T
!!!
   real (DP), dimension (size(T))  :: beta ! local variable  to keep temporary results
beta=sqrt(pi25DT*T)*(pi25DT*T)
y = n*exp(-((u-u_0)*(u-u_0)+(v-v_0)*(v-v_0)+&
                  (w-w_0)*(w-w_0))/max(T,0.0000001_DP))/beta
end function maxwelveldist_T_vector

! this is the copy when T is scalar and u is vector
function maxwelveldist_u_vectors (T,u_0,v_0,w_0,n,u,v,w) result (y)
   real (DP), intent (in) :: T    ! temperature parameter (scalar)
   real (DP), intent (in) :: u_0,v_0,w_0  ! average velocity (scalar)
   real (DP), intent (in) :: n    ! density parameter (scalar)
   real (DP), dimension (:), intent (in) :: u,v,w    ! values of the velocity variable
   real (DP), dimension (size(u))  :: y ! value of the dencity for this values of u and T
!!!
   real (DP)  :: beta ! local variable  to keep temporary results
beta=sqrt(pi25DT*T)*(pi25DT*T)
y = n*exp(-((u-u_0)*(u-u_0)+(v-v_0)*(v-v_0)+&
                  (w-w_0)*(w-w_0))/max(T,0.0000001_DP))/beta
end function maxwelveldist_u_vectors

! this is the copy when both T and u are scalars
function maxwelveldist (T,u_0,v_0,w_0,n,u,v,w) result (y)
   real (DP), intent (in) :: T    ! temperature parameter (may depend on x)
   real (DP), intent (in) :: u_0,v_0,w_0  ! average velocity (scalar)
   real (DP), intent (in) :: n    ! density parameter (scalar)
   real (DP), intent (in) :: u,v,w    ! value of the velocity variable
   real (DP)  :: y ! value of the dencity for this values of u and T
!!!
   real (DP)  :: beta ! local variable  to keep temporary results
beta=sqrt(pi25DT*T)*(pi25DT*T)
y = n*exp(-((u-u_0)*(u-u_0)+(v-v_0)*(v-v_0)+&
                  (w-w_0)*(w-w_0))/max(T,0.0000001_DP))/beta
end function maxwelveldist

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! ESBGK_f0
!
! This function evauates the 3D ES-BGK equilibrium distribution with given temperature and average velocity.
! Note that the parameters are dependent on time and velocity but not in the spacial variable x
!
! This function evaluates
! f_0(t,u)=\frac{n(t)}{\sqrt{(\pi^3 det(\mathbb{T})}} \exp(-c'\mathbb{T}c)
!
!!!!!!!!!!!!!!!!!!!!!!!

function ESBGK_f0 (TensorInv,Determinant,n,u_0,v_0,w_0,nodes_u,nodes_v,nodes_w) result (f0)
! Evaluate f0 for ESBGK
real (DP), dimension(3,3), intent (in) :: TensorInv ! The inverse of the tensor matrix
real (DP), intent (in) :: u_0, v_0, w_0 ! These are the bulk velocities
real (DP), intent (in) :: Determinant ! This is the Determinant of the Tensor matrix
real (DP), intent (in) :: n ! this is the number density
real (DP), dimension(:), intent (in) :: nodes_u,nodes_v,nodes_w ! These are the velocity nodes
integer (I4B) :: Unodes ! the number of nodes in velocity space
real (DP), dimension(3) :: Left, c ! c-v vector
real (DP), parameter :: PI25DT = 3.141592653589793238462643d0
integer :: loc_alloc_stat
real (DP), dimension (:), allocatable  :: Prod ! This is the component that goes into the argument of the exponent
real (DP), dimension (1:size(nodes_u,1)) :: f0 ! result -- the ES-BGK distribution function
!real (DP), dimension(1:size(nodes_u,1)) :: nodes_cu, nodes_cv, nodes_cw
integer (I4B) :: i,j,k ! these are local counters

Unodes = size(nodes_U)   !  Get the number of elements of each of the nodes

allocate (Prod(1:size(nodes_u,1)), stat=loc_alloc_stat)
if (loc_alloc_stat >0) then
 print *, "ESBGK_f0: Allocation error for variables (Prod)"
 stop
end if

! from here, the component in the exponent's argument is computed

do i=1,Unodes
   ! c = \vec{u} - \vec{bar{u}}
   c(1) = nodes_u(i) - u_0
   c(2) = nodes_v(i) - v_0
   c(3) = nodes_w(i) - w_0

   ! used as part of the left operation (i.e. c'*TensorInv)
   Left(1) = c(1)*TensorInv(1,1) + c(2)*TensorInv(2,1) + c(3)*TensorInv(3,1)
   Left(2) = c(1)*TensorInv(1,2) + c(2)*TensorInv(2,2) + c(3)*TensorInv(3,2)
   Left(3) = c(1)*TensorInv(1,3) + c(2)*TensorInv(2,3) + c(3)*TensorInv(3,3)

   Prod(i) = Left(1)*c(1) + Left(2)*c(2) + Left(3)*c(3)! final computation of c'*TensorInv*c
end do

f0 = n/sqrt((PI25DT)**3*Determinant) * exp(-Prod)

deallocate (Prod)

end function ESBGK_f0

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Shakhov_f0
!
! This function evauates the dimensionless 3D Shakhov equilibrium distribution function
! with given temperature and average velocity and the
! give Prandtl number.
!
!Note that the parameters are dependent on time and velocity but not in the spacial variable x
!
! This function evaluates
! f_0(t,u)=f_{M}(t,u)(1+(4/5)(1-Pr)S_{a}c^{a}(c_{a}c^{a}-5/2)) where c_a=(u_a-\bar{u}_a)/\sqrt{T}
! S_a=q_{a}/(nT^{3/2}), q_{a} = \int f (u_{a}-\bar(u)_{a})|u-\bar{u}|^2 du
!
!!!!!!!!!!!!!!!!!!!!!!!

function Shakhov_f0 (alpha,n,u_0,v_0,w_0,T,S_u,S_v,S_w,nodes_u,nodes_v,nodes_w) result (f0)
! Evaluate f0 for Shakhov model
real (DP), intent (in) :: alpha ! the Prandtl number
real (DP), intent (in) :: T ! This is the temperature of the local maxwellian
real (DP), intent (in) :: n ! this is the number density
real (DP), intent (in) :: u_0, v_0, w_0 ! These are the bulk velocities of the local maxwellian
real (DP), dimension(:), intent (in) :: S_u,S_v,S_w ! These are the components of the vector S in the shakov model

real (DP), dimension(:), intent (in) :: nodes_u,nodes_v,nodes_w ! These are the velocity nodes
real (DP), dimension (1:size(nodes_u,1)) :: f0 ! the Shakhov distribution function -- the result
!
!
real (DP), parameter :: PI25DT = 3.141592653589793238462643d0
real (DP), dimension (:), allocatable :: ShCorr,c_u, c_v, c_w! This are useful arrays,
integer (I4B) :: i,j,k,loc_alloc_stat ! these are local counters

allocate (ShCorr(1:size(nodes_u,1)),c_u(1:size(nodes_u,1)),c_v(1:size(nodes_u,1)),&
                  c_w(1:size(nodes_u,1)), stat=loc_alloc_stat)
if (loc_alloc_stat >0) then
 print *, "Shakhov_f0: Allocation error for variables (ShCorr,c_u,c_v,c_w)"
 stop
end if

! first, we compute the components of vector c:
c_u = (nodes_u-u_0)/sqrt(T)
c_v = (nodes_v-v_0)/sqrt(T)
c_w = (nodes_w-w_0)/sqrt(T)
! Next we compute the Shakhov correction term
ShCorr = (S_u*c_u+S_v*c_v+S_w*c_w)*((c_u*c_u+c_v*c_v+c_w*c_w)-5.0_DP/2.0_DP)
ShCorr = (1+4.0_DP/5.0_DP*((-1)*alpha)/(1-alpha)*ShCorr)
!!!!!!!!
f0 = maxwelveldist(T,u_0,v_0,w_0,n,nodes_u,nodes_v,nodes_w)*ShCorr

deallocate (ShCorr,c_u,c_v,c_w)

end function Shakhov_f0

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!EvalGrad13f0
!
!Evaluates the 13 moment grad function
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

function EvalGrad13f0(n,p,sigma,q,u_0,v_0,w_0,nodes_u,nodes_v,nodes_w) result(f0)

real (DP), intent (in) :: p    ! Pressure, scalar
real (DP), intent (in) :: n    ! density parameter (scalar)
real (DP), intent (in) :: u_0,v_0,w_0  ! average velocity (may depend on x)
real (DP), dimension(:), intent (in) :: nodes_u,nodes_v,nodes_w ! These are the velocity nodes
!!! T,u_0 must be the same size !!!
real (DP), dimension(3,3), intent(in) :: sigma !The traceless stress tensor
real (DP), dimension(3), intent(in) :: q !The heatflux

real (DP), dimension (1:size(nodes_u,1)) :: f0 ! result -- the 13 moment grad function

real (DP), dimension(3) :: Left, c ! c-v vector
real (DP) :: T !Temperature, derived from the density and the pressure
real (DP) :: trace_c !A varaible to store the trace of the velocity
integer (I4B) :: Unodes ! the number of nodes in velocity space
integer (I4B) :: i,j,k ! these are local counters

Unodes = size(nodes_u)
T=2*p/n

do i=1,Unodes
   c(1) = nodes_u(i) - u_0
   c(2) = nodes_v(i) - v_0
   c(3) = nodes_w(i) - w_0

   trace_c=sum(c*c)

   f0(i)=(sigma(1,1)*(c(1)*c(1) - trace_c/3.0_DP) + 2*sigma(1,2)*c(1)*c(2) + 2*sigma(1,3)*c(1)*c(3) + &
        sigma(2,2)*(c(2)*c(2) - trace_c/3.0_DP) + 2*sigma(2,3)*c(2)*c(3) + sigma(3,3)*(c(3)*c(3) - trace_c/3.0_DP))/(p*T)

   f0(i)=f0(i)+ 4.0_DP/(5.0_DP*p*T)*(trace_c / T - 5.0_DP/2.0_DP)*(q(1)*c(1)+q(2)*c(2)+q(3)*c(3))

   f0(i)=f0(i)+1

   f0(i)=maxwelveldist(T,u_0,v_0,w_0,n,nodes_u(i),nodes_v(i),nodes_w(i))*f0(i)

end do

end function EvalGrad13f0

end module DGV_distributions_mod


subroutine dens_unes(temp, salt, rhouns, rhods, rhodt)
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: dens_unes.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/flow2d3d/packages/kernel/src/compute/dens_unes.f90 $
!!--description-----------------------------------------------------------------
!
!    Function: Computes water density from temperature and
!              salinity using equation of state (rhowat).
!
! Method used: Equation of state following UNESCO, (UNESCO,
!              Algorithms for computation of fundamental
!              properties of seawater, UNESCO technical papers
!              in marine science, 1983)
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
!
    use precision
    implicit none
!
! Global variables
!
    real(fp), intent(in)     :: salt
    real(fp), intent(in)     :: temp
    real(fp), intent(out)    :: rhouns
    real(fp), intent(out)    :: rhods
    real(fp), intent(out)    :: rhodt
!
! Local variables
!
    real(fp)                            :: s
    real(fp)                            :: sq
    real(fp)                            :: rhwa
    real(fp)                            :: asal
    real(fp)                            :: bsal
    real(fp), dimension(5)              :: t
    real(fp), dimension(0:5), parameter :: cf = &
    (/ 999.842594_fp   ,&
         6.793952e-2_fp  ,&
        -9.095290e-3_fp  ,&
         1.001685e-4_fp  ,&
        -1.120083e-6_fp  ,&
         6.536332e-9_fp  /)
    real(fp), dimension(0:4), parameter :: ca = &
    (/   8.24493e-1_fp ,&
        -4.0899e-3_fp  ,&
         7.6438e-5_fp  ,&
        -8.2467e-7_fp  ,&
         5.3875e-9_fp  /)
    real(fp), dimension(0:2), parameter :: cb = &
    (/  -5.72466e-3_fp  ,&
         1.0227e-4_fp   ,&
        -1.6546e-6_fp   /)
    real(fp)                , parameter :: csal = 4.8314e-4_fp
!
!! executable statements -------------------------------------------------------
!
    t(1)   = temp
    t(2)   = temp*t(1)
    t(3)   = temp*t(2)
    t(4)   = temp*t(3)
    t(5)   = temp*t(4)
    !
    s      = salt
    sq     = sqrt(max(0.0_fp,s))
    !
    rhwa   = cf(0) + cf(1)*t(1) + cf(2)*t(2) + cf(3)*t(3) + cf(4)*t(4) &
           &       + cf(5)*t(5)
    asal   = ca(0) + ca(1)*t(1) + ca(2)*t(2) + ca(3)*t(3) + ca(4)*t(4)
    bsal   = cb(0) + cb(1)*t(1) + cb(2)*t(2)
    !
    rhouns = rhwa + (asal+bsal*sq+csal*s) * s
    !
    rhods  = asal + 1.5_fp*bsal*sq + 2.0_fp*csal*s
    !
    rhodt  = cf(1) +  2.0_fp*cf(2)*t(1) + 3.0_fp*cf(3)*t(2) &
           &       +  4.0_fp*cf(4)*t(3) + 5.0_fp*cf(5)*t(4) &
           &       + (ca(1) + 2.0_fp*ca(2)*t(1) + 3.0_fp*ca(3)*t(2) &
           &       +  4.0_fp*ca(4)*t(3)) * s &
           &       + (cb(1) + 2.0_fp*cb(2)*t(1)) * sq * s
end subroutine dens_unes


module feril
!****************************************************************************
! feril = fortran electron repulsion integral (ERI) library
!
! The main function to be used is coulomb_rep4, a 4-center ERI calculator
! for Gaussian type orbitals (GTOs). Also includes a 2-center ERI,
! coulomb_rep2, which is a wrapper for coulomb_rep4.
! This work is based off of the pyquante2 code.
!   https://github.com/rpmuller/pyquante2/blob/master/pyquante2/ints/two.py
! which is a python implementation of:
!    'Gaussian Expansion Methods for Molecular Orbitals' H. Taketa,
!    S. Huzinaga & K. O-ohata. H. Pys. Soc. Japan, 21, 2313, 1966.
! Special functions are based off of
!  -Gamma & Incomplete Gamma Functions:
!    'Computation of Special Functions' by S. Zhang & J. Jin
!  -Boys Function:
!    'Molecular Electronic-Structure Theory' by T. Helgaker, P. Jorgensen
!                                               & J. Olsen
!
! Author:          Date:           Version:
! Aaron Mahler     04Nov2018            0.0
!****************************************************************************

! @TODO: add timing to see what takes the longest

  use kinds, only : dp
  use constants, only: pi
  implicit none

  ! Hard coded limit so b_arrays can be on the stack.
  ! INT(KIND=8) limit is @ vmax_am_tot=29, because fact_ratio2 is maxed
  ! @ (28,14). It also disagrees with pyquante2 when vmax_am_tot = 25 by
  ! ~0.2% for maxed out input angular momentum.
  integer, parameter :: vmax_am_tot = 21 ! 4*5 + 1 (4 h-type orbitals)
  real(dp), dimension(vmax_am_tot)   :: bax, bay, baz
  real(dp), dimension(0:vmax_am_tot) :: fbar ! array of fboys evaluations
  real(dp) :: ericoef = 2.0_dp * (pi**2.5_dp)
  real(dp), parameter :: taytol = 0.01_dp  ! tolerance to eval fboys with Taylor series
  real(dp), parameter :: anatol = 150.0_dp ! tol to analytical eval fboys for big arg

  contains
function fboys(nin, xin) result(ret)
!****************************************************************************
! fboys evaluates the Boys function(n,x) := \int_0^1 exp(-xt^2)t^(2n) dt
!
!  for small x<0.01, Taylor series at x=0
!  for large x>150, analytic form of \int_0^\infty exp(-xt^2)t^(2n) dt
!  for intermediate range use F_n(x) = \gamma(n+1/2,x) / ( 2x^(n+1/2) ),
!    where \gamma is the lower incomplete gamma function
!
!  Parameters:
!    Input, real(dp) :: nin, xin ! both inputs should be >= 0
!    Output, real(dp) :: ret ! Boys func, range is 1/(2n+1) >= F_n(x) > 0
!****************************************************************************
  use kinds, only : dp
  use constants, only : pi
  implicit none
  ! Params
  real(dp), intent(in) :: nin, xin
  ! Locals
  real(dp) :: r1
  integer  :: ii
  ! Return
  real(dp) :: ret

  ! input error checking, change nin to int type?
  if ( (xin .lt. 0.0_dp) .or. (nin .lt. 0.0_dp) ) then
    write(6,'("ERR in fboys, negative input not allowed")')
    ret = -1.0_dp
    return
  end if

  if ( xin .lt. taytol ) then
  ! Use truncated series expansion at x=0 for small x
  ! F_n(x) = \sum_{k=0}^{\infty} (-x)^k / ( k! (2n+2k+1) )

    ret = 1.0_dp / ( 2.0_dp*nin + 1.0_dp )
    !r1 = 1.0_dp
    !do ii = 1, 5 ! loop method for testing different truncation lengths
    !  r1 = real(ii, dp)*r1
    !  ret = ret + (-xin)**ii / (r1 * (2.0_dp*nin + 2.0_dp*ii + 1.0_dp))
    !end do
    ! manually unroll loop
    ! truncation at k=5 tested against Mathematica up to n=50 for x=0.01
    ret = ret - xin / (2.0_dp*nin + 3.0_dp)
    ret = ret + xin**2 / (4.0_dp*nin + 10.0_dp)
    ret = ret - xin**3 / (12.0_dp*nin + 42.0_dp)
    ret = ret + xin**4 / (48.0_dp*nin + 216.0_dp)
    ret = ret - xin**5 / (240.0_dp*nin + 1320.0_dp)
    !write(6,*) 'fboys taylor'
    return

  else if ( xin .gt. anatol ) then
  ! F_n(x) \approx (2n-1)!! / 2^(n+1) * Sqrt( \pi / x^(2n+1) ); for large x
  ! tested against Mathematica up to n=50 for x=150
    r1 = 1.0_dp
    if ( nin .ge. 2.0_dp ) then ! double factorial
        do ii = 2*int(nin)-1, 1, -2
            r1 = r1 * real(ii, dp)
        end do
    end if
    ret = r1 * 2.0_dp**(-nin-1) * sqrt( pi * xin**(-2*nin-1) )
   ! write(6,*) 'fboys large'
    return

  end if

  ! else use incomplete gamma func
  r1 = nin + 0.5_dp
  ret = incgaml(r1, xin) / ( 2.0_dp * xin**r1 )
 ! write(6,*) 'fboys incgaml'

  return
end function fboys

function gam_zj(xin) result(ga)
!****************************************************************************
! gam_zj evaluates the Gamma Function(n) :=
!    \int_0^{\infty} exp(-t) t^{n-1) dt
!
!  Reference:
!    Shanjie Zhang, Jianming Jin,
!    Computation of Special Functions,
!    Wiley, 1996, ISBN: 0-471-11963-6, LC: QA351.C45
! https://people.sc.fsu.edu/~jburkardt/f_src/special_functions/special_functions.f90
!
!  Parameters:
!    Input, real (dp) Xin, the argument.
!    Xin must not be 0, or any negative integer.
!    Output, real (dp) GA, the value of the Gamma function.
!****************************************************************************
  use kinds, only : dp
  use constants, only : pi

  implicit none
  ! Params
  real(dp), intent(in) :: xin
  ! Locals
  real(dp), dimension (26) :: gra = (/ &
    1.0E+00_dp, &
    0.5772156649015329E+00_dp, &
   -0.6558780715202538E+00_dp, &
   -0.420026350340952E-01_dp, &
    0.1665386113822915E+00_dp, &
   -0.421977345555443E-01_dp, &
   -0.96219715278770E-02_dp, &
    0.72189432466630E-02_dp, &
   -0.11651675918591E-02_dp, &
   -0.2152416741149E-03_dp, &
    0.1280502823882E-03_dp, &
   -0.201348547807E-04_dp, &
   -0.12504934821E-05_dp, &
    0.11330272320E-05_dp, &
   -0.2056338417E-06_dp, &
    0.61160950E-08_dp, &
    0.50020075E-08_dp, &
   -0.11812746E-08_dp, &
    0.1043427E-09_dp, &
    0.77823E-11_dp, &
   -0.36968E-11_dp, &
    0.51E-12_dp, &
   -0.206E-13_dp, &
   -0.54E-14_dp, &
    0.14E-14_dp, &
    0.1E-15_dp /)

  real(dp) :: gr, rr, rz
  integer  :: ik, im, im1
  ! Return
  real(dp) :: ga

  ifgam1: if ( xin == aint(xin) ) then

    if ( 0.0_dp < xin ) then
      ga = 1.0_dp
      im1 = int(xin) - 1
      do ik = 2, im1
        ga = ga * real(ik, dp)
      end do
    else
      ga = 1.0E+300_dp
    end if

  else ifgam1

    if ( 1.0_dp < abs(xin) ) then
      rz = abs(xin)
      im = int(rz)
      rr = 1.0_dp
      do ik = 1, im
        rr = rr * ( rz - real(ik, kind=dp) )
      end do
      rz = rz - real(im, kind=dp)
    else
      rz = xin
    end if

    gr = gra(26)
    do ik = 25, 1, -1
      gr = gr * rz + gra(ik)
    end do

    ga = 1.0_dp / ( gr * rz )

    if ( 1.0_dp < abs(xin) ) then
      ga = ga * rr
      if ( xin < 0.0_dp ) then
        ga = - pi / ( xin * ga * sin(pi*xin) )
      end if
    end if

  end if ifgam1

  return
end function gam_zj

function incgaml(ain, xin) result(gout)
!****************************************************************************
! incgaml evaluates the Lower Incomplete Gamma Function(a,x) :=
!   \int_0^x exp(-t) t^{n-1) dt
!
! Reference:
!    Shanjie Zhang, Jianming Jin,
!    Computation of Special Functions,
!    Wiley, 1996, ISBN: 0-471-11963-6, LC: QA351.C45.
! https://people.sc.fsu.edu/~jburkardt/f_src/special_functions/special_functions.f90
!
!  Parameters:
!    Input, real ( kind = 8 ) ain, the parameter.
!    Input, real ( kind = 8 ) xin, the argument.
!    Output, real(dp) gout
!****************************************************************************
  use kinds, only : dp
  implicit none
  ! Params
  real(dp), intent(in) :: ain, xin
  ! Locals
  real(dp) :: rr, rs
  real(dp) :: t0, xam
  integer :: ik
  ! Return
  real(dp) :: gout

  xam = -xin + ain*log(xin)

  if ( 700.0_dp < xam .or. 170.0_dp < ain ) then
    write(6, '(/,a)') 'ERR (incgaml), arg(s) too large! returning 0.0'
    gout = 0.0_dp
    return
  end if

  if ( xin .lt. 1.0e-50_dp ) then
  ! Tested against Mathematica, Gamma[1,0,10^-50] = 10e-50
  ! which is small enough to cutoff for this module
    gout = 0.0_dp

  else if ( xin .le. (1.0_dp+ain) ) then
    rs = 1.0_dp / ain
    rr = rs
    dok1: do ik = 1, 60
      rr = rr * xin / ( ain + real(ik, dp) )
      rs = rs + rr
      if ( abs(rr/rs) .lt. 1.0E-15_dp ) then
          exit dok1
      end if
    end do dok1
    gout = exp(xam) * rs

  else if ( (1.0_dp+ain) .lt. xin ) then
    t0 = 0.0_dp
    do ik = 60, 1, -1
      t0 = ( real(ik,dp) - ain ) / ( 1.0_dp + real(ik, dp)/(xin+t0) )
    end do
    gout = gam_zj(ain) - ( exp(xam) / (xin+t0) )
    !gout = gamma(ain) - ( exp(xam) / (xin+t0) )

  else ! usually a NaN
    write(*,*) 'ERR (incgaml) undefined for requested input'
    write(*,*) 'xin: ', xin
    write(*,*) 'ain: ', ain
    stop 4 ! SIGILL: illegal instruction
  end if

  return
end function incgaml

function fact_ratio2(ain, bin) result(ret)
!****************************************************************************
! Factorial ratio 2 := a! / ( b! (a-2b)! )
!****************************************************************************
  implicit none
  ! Params
  integer, intent(in) :: ain, bin ! ain >= 2bin
  ! Locals
  integer :: i1, imx, imn
  ! Return
  integer(kind=8) :: ret

  if ( (ain.eq.0) .or. (ain.eq.1) .or. &
       (bin.eq.0) ) then
      ret =  1
      return
  else if (ain.gt.28) then
      write(6,'("ERR, fact_ratio2 cannot handle numbers > 28")')
      ret = 0
      return
  end if

  imx = max(bin, ain - 2*bin)
  imn = min(bin, ain - 2*bin)

  ret = 1
  do i1 = imx+1, ain
      ret = ret * int(i1, 8)
  end do
  if ( imn .gt. 1) then
      do i1 = 2, imn
          ret = ret / int(i1, 8)
      end do
  end if

  return
end function fact_ratio2

function binomcof(ain, bin) result(ret)
!****************************************************************************
! binomial coefficient := a! / ( b! (a-b)! )
!****************************************************************************
  implicit none
  ! Params
  integer, intent(in) :: ain, bin
  ! Locals
  integer :: i1, imx, imn
  ! Return
  integer :: ret

  if ( (ain.eq.0) .or. (ain.eq.1) .or. &
       (bin.eq.0) ) then
      ret =  1
      return
  end if

  imx = max(bin, ain - bin)
  imn = min(bin, ain - bin)

  ret = 1
  do i1 = imx+1, ain
      ret = ret * i1
  end do
  if ( imn .gt. 1) then
      do i1 = 2, imn
          ret = ret / i1
      end do
  end if

  return
end function binomcof

function binom_prefac_v2(si, iai) result(ret)
!****************************************************************************
! integral prefactor with the binom coefficient from Augspruger & Dykstra
! adapted from
! https://github.com/rpmuller/pyquante2/blob/master/pyquante2/ints/one.py
!****************************************************************************
  use kinds, only : dp
  implicit none
  ! Params
  integer,  intent(in) :: si, iai
  ! Return
  real(dp) :: ret

  ret = real(binomcof(iai, si), dp)
  return
end function binom_prefac_v2

function binom_prefac(si, iai, ibi, xpai, xpbi) result(ret)
!****************************************************************************
! integral prefactor with the binom coefficient from Augspruger & Dykstra
! adapted from
! https://github.com/rpmuller/pyquante2/blob/master/pyquante2/ints/one.py
!****************************************************************************
  use kinds, only : dp
  implicit none
  ! Params
  integer,  intent(in) :: si, iai, ibi
  real(dp), intent(in) :: xpai, xpbi
  ! Locals
  integer :: i1
  ! Return
  real(dp) :: ret

  ret = 0.0_dp
  do i1 = 0, si
    if ( ((si-iai).le.i1) .and. (i1.le.ibi) ) then
      ret = ret + real(binomcof(iai, si-i1), dp) * &
                  real(binomcof(ibi, i1), dp) * &
                  xpai ** (iai - si + i1) * &
                  xpbi ** (ibi - i1)
    end if
  end do

  return
end function binom_prefac

function fb_v2(l1in, rin, gin) result(ret)
!****************************************************************************
! @TODO: combine with b0, rename to something more relevant
!****************************************************************************
  use kinds, only : dp
  implicit none
  ! Params
  integer,  intent(in) :: l1in, rin
  real(dp), intent(in) :: gin
  ! Locals
  real(dp) :: r1
  ! Return
  real(dp) :: ret

  ret = 0.0_dp
      !write(6,*) 'yee', i1, iin, l1in
  !if (iin.le.l1in) then !.and. (i1.le.0) ) then
  !if (iin.eq.l1in) then !.and. (i1.le.0) ) then
    !r1 = real(binomcof(l1in, iin), dp) * &
    !       0.0_dp ** (l1in - iin) !* &
    ret = real(fact_ratio2(l1in, rin), dp) * (4.0_dp*gin)**(rin-l1in)
  !end if

  return
end function fb_v2

function b0(iin, rin, gin) result(ret)
!****************************************************************************
  use kinds, only : dp
  implicit none
  ! Params
  integer,  intent(in) :: iin, rin
  real(dp), intent(in) :: gin
  ! Return
  real(dp) :: ret

  ret = real(fact_ratio2(iin, rin), dp) * (4.0_dp*gin)**(rin-iin)

  return
end function b0

function fb(iin, l1in, l2in, pin, ain, bin, rin, gin) result(ret)
!****************************************************************************
! @TODO: combine with b0, rename to something more relevant
!****************************************************************************
  use kinds, only : dp
  implicit none
  ! Params
  integer,  intent(in) :: iin, l1in, l2in, rin
  real(dp), intent(in) :: pin, ain, bin, gin
  ! Return
  real(dp) :: ret

  ret = b0(iin, rin, gin) * &
        binom_prefac(iin, l1in, l2in, pin-ain, pin-bin)

  return
end function fb

function b_term(i1i, i2i, r1i, r2i, ui, l1i, l2i, l3i, l4i, pxi, axi, &
                bxi, qxi, cxi, dxi, gam1, gam2, deli) result(ret)
!****************************************************************************
! Logic for filling elements of b_array
!****************************************************************************
   use kinds, only : dp
   implicit none
   ! Params
   integer,  intent(in) :: i1i, i2i, r1i, r2i, ui
   integer,  intent(in) :: l1i, l2i, l3i, l4i
   real(dp), intent(in) :: pxi, axi, bxi
   real(dp), intent(in) :: qxi, cxi, dxi
   real(dp), intent(in) :: gam1, gam2, deli
   ! Locals
   real(dp) :: sgn1, p1, p2, fb1, fb2, frat
   ! Return
   real(dp) :: ret

   sgn1 = real( (-1)**(i2i+ui), dp)
   p1 = (qxi-pxi) ** (i1i + i2i - 2*(r1i+r2i+ui))
   p2 = deli ** (i1i + i2i - ui - 2*(r1i+r2i))
   fb1 = fb(i1i, l1i, l2i, pxi, axi, bxi, r1i, gam1)
   fb2 = fb(i2i, l3i, l4i, qxi, cxi, dxi, r2i, gam2)
   frat = real( fact_ratio2( i1i + i2i - 2*(r1i+r2i), ui), dp)

   ret = fb1 * fb2 * frat * sgn1 * p1 / p2

   return
end function b_term

subroutine b_array(l1i, l2i, l3i, l4i, pin, ain, bin, qin, cin, din, &
                   g1i, g2i, deli, bout)
!****************************************************************************
! @TODO: combine with b_term
!****************************************************************************
  use kinds, only : dp
  implicit none
  ! Params
  integer,  intent(in) :: l1i, l2i, l3i, l4i
  real(dp), intent(in) :: pin, ain, bin
  real(dp), intent(in) :: qin, cin, din
  real(dp), intent(in) :: g1i, g2i, deli
!  real(dp), allocatable, intent(out) :: bout(:)
  real(dp), intent(out) :: bout(vmax_am_tot)
  ! Locals
  integer :: i1, i2, ir1, ir2, iu, ij
  integer :: imax

!  if ( allocated(bout) ) deallocate(bout)
  imax = l1i + l2i + l3i + l4i + 1
!  allocate( bout(imax) )

  bout(:) = 0.0_dp
  do i1  = 1, l1i + l2i + 1
  do i2  = 1, l3i + l4i + 1
  do ir1 = 1, (i1-1)/2 + 1
  do ir2 = 1, (i2-1)/2 + 1
  do iu  = 1, (i1+i2-2)/2 - ir1 - ir2 + 3
    ij = i1 + i2 - 2*(ir1+ir2-2) - iu ! +4 for 1-based indexing
    bout(ij) = bout(ij) + b_term(i1-1, i2-1, ir1-1, ir2-1, iu-1, &
                                 l1i, l2i, l3i, l4i, &
                                 pin, ain, bin, qin, cin, din, &
                                 g1i, g2i, deli)
!    write(6,'(2x,6(i2,x,","))') i1-1, i2-1, ir1-1, ir2-1, iu-1, ij-1
  end do
  end do
  end do
  end do
  end do

end subroutine b_array

subroutine gauss_prod_center(alpa, acen, alpb, bcen, ocen)
!****************************************************************************
! fill ocen with the center of the combined gaussians
!****************************************************************************
  use kinds, only : dp
  implicit none
  ! Params
  real(dp), intent(in)  :: alpa, alpb       ! exponents
  real(dp), intent(in)  :: acen(3), bcen(3) ! centers
  real(dp), intent(out) :: ocen(3)          ! output center
  ! Locals
  real(dp) :: alpab

  alpab = 1.0_dp / (alpa + alpb)
  ocen(1) = (alpa*acen(1) + alpb*bcen(1)) * alpab
  ocen(2) = (alpa*acen(2) + alpb*bcen(2)) * alpab
  ocen(3) = (alpa*acen(3) + alpb*bcen(3)) * alpab

end subroutine gauss_prod_center

function diff3_norm2(vec1, vec2) result(ret)
!****************************************************************************
! find norm^2 of the difference of two 3d vectors
!****************************************************************************
  use kinds, only : dp
  implicit none
  ! Params
  real(dp), intent(in) :: vec1(3), vec2(3)
  ! Return
  real(dp) :: ret

  ret = ( vec1(1) - vec2(1) )**2 + &
        ( vec1(2) - vec2(2) )**2 + &
        ( vec1(3) - vec2(3) )**2

  return
end function diff3_norm2

subroutine b_array_v2(l1i, l3i, cmain, g1i, g2i, deli, bout)
!****************************************************************************
! b_array just for 2 center, all functions inlined for speed
!****************************************************************************
  use kinds, only : dp
  implicit none
  ! Params
  integer,  intent(in) :: l1i, l3i
  real(dp), intent(in) :: cmain ! cin - ain
  real(dp), intent(in) :: g1i, g2i, deli
  real(dp), intent(out) :: bout(vmax_am_tot)
  ! Locals
  integer :: ir1, ir2, iu, ij
  integer :: l1p3
  real(dp) :: sgn1, p1, p2, fb1, fb2, frat
  real(dp) :: fg1, fg2

  bout(:) = 0.0_dp

  l1p3 = l1i + l3i
  fg1 = 4.0_dp * g1i
  fg2 = 4.0_dp * g2i

  do ir1 = 0, l1i/2
  do ir2 = 0, l3i/2
  do iu  = 0, (l1i+l3i)/2 - ir1 - ir2
    ij = l1i + l3i - 2*(ir1+ir2) - iu + 1

    sgn1 = real( (-1)**(l3i+iu), dp )
    p1 = cmain ** (l1p3 - 2*(ir1+ir2+iu))
    p2 = deli ** (l1p3 - iu - 2*(ir1+ir2))
    fb1 = real(fact_ratio2(l1i, ir1), dp) * fg1**(ir1-l1i)
    fb2 = real(fact_ratio2(l3i, ir2), dp) * fg2**(ir2-l3i)
    frat = real( fact_ratio2( l1p3 - 2*(ir1+ir2), iu), dp)

    bout(ij) = bout(ij) + ( fb1 * fb2 * frat * sgn1 * p1 / p2 )
  end do
  end do
  end do

  return
end subroutine b_array_v2

function coulomb_rep2_v2( acen, amom, alpa, &
                          ccen, cmom, alpc ) result(ret)
!****************************************************************************
! 2-center ERI, rewritten from coulomb_rep4, not just a wrapper
! take advantage of 2-center to speed up b_array
! switch to downward recursion of fboys so only eval once
!
! Parameters:
!  Input, real(dp), dim(3) :: acen, ccen ! origins of the GTOs
!  Input, real(dp) :: alpa, alpc         ! alpha(abcd), exponents
!  Input, integer, dim(3) :: amom, cmom  ! ang. mom. of GTOs
!  Output, real(dp) :: ret               ! the value of the ERI
!****************************************************************************
  use kinds, only : dp
  use constants, only : pi
  implicit none
  ! Params
  real(dp), intent(in) :: acen(3), ccen(3) ! origins
  real(dp), intent(in) :: alpa, alpc       ! exponents
  integer,  intent(in) :: amom(3), cmom(3) ! ang. mom.
  ! Locals
  real(dp), parameter :: rtol = 1.0e-8_dp
  integer :: ii, jj, kk
  real(dp) :: rpq2
  real(dp) :: delt, fbarg, fbnum
!  real(dp), dimension(vmax_am_tot) :: bax, bay, baz
!  real(dp), dimension(0:vmax_am_tot) :: fbar
  integer  :: fbarsz
  ! Return
  real(dp) :: ret

  call start_clock('crep2v2')

  ret = 0.0_dp
  rpq2 = diff3_norm2(acen, ccen)                 ! find p & q diff norm
  delt = 0.25_dp * ( 1.0_dp/alpa + 1.0_dp/alpc ) ! b_array arg
  fbarg = 0.25_dp * rpq2 / delt                  ! fboys arg

  if ( (alpa.lt.rtol) .or. (alpc.lt.rtol) .or. (delt.lt.rtol) ) then
      write(6,'("ERR (coulomb_rep2), invalid input, returning 0")')
      ret = 0.0_dp
      return
  end if

  !call start_clock('barrays')
  call b_array_v2(amom(1), cmom(1), ccen(1)-acen(1), alpa, alpc, delt, bax)
  call b_array_v2(amom(2), cmom(2), ccen(2)-acen(2), alpa, alpc, delt, bay)
  call b_array_v2(amom(3), cmom(3), ccen(3)-acen(3), alpa, alpc, delt, baz)
  !call stop_clock('barrays')

  !call start_clock('fboys comp')
  fbarsz = sum( amom + cmom )
  if ( (fbarg.lt.taytol) .or. (fbarg.gt.anatol) ) then
      ! taylor series and analytical are fast, go ahead and calculate
      do ii = 0, fbarsz
          fbar(ii) = fboys( real(ii,dp), fbarg )
      end do
  else ! use downward recursion
      fbar(fbarsz) = fboys( real(fbarsz,dp), fbarg )
      if ( fbarsz .gt. 0 ) then
          do ii = fbarsz-1, 0, -1
              fbar(ii) = 2*fbarg*fbar(ii+1) + exp(-fbarg)
              fbar(ii) = fbar(ii) / real( 2*ii + 1, dp )
          end do
      end if
  end if
  !call stop_clock('fboys comp')

  !call start_clock('fboys contract')
  if ( fbarsz .gt. 0 ) then
      do ii = 1, amom(1) + cmom(1) + 1
      do jj = 1, amom(2) + cmom(2) + 1
      do kk = 1, amom(3) + cmom(3) + 1
        ret = ret + bax(ii)*bay(jj)*baz(kk)*fbar(ii+jj+kk-3)
      end do
      end do
      end do
  else ! s-types, no need to contract
      ! I can't tell from run times if eval'ing s-types separately is any faster
      ret = bax(1)*bay(1)*baz(1)*fbar(0)
  end if
  !call stop_clock('fboys contract')

  ret = ret * ericoef / ( alpa*alpc*sqrt(alpa+alpc) )

  call stop_clock('crep2v2')
  return
end function coulomb_rep2_v2

function coulomb_rep4(acen, amom, alpa, bcen, bmom, alpb, &
                      ccen, cmom, alpc, dcen, dmom, alpd) result(ret)
!****************************************************************************
! 4-center ERI, adapted from pyquante2/ints/two.py
!
! Parameters:
!  Input, real(dp), dim(3) :: acen, bcen, ccen, dcen ! origins of the GTOs
!  Input, real(dp) :: alpa, alpb, alpc, alpd ! alpha(abcd), exponents
!  Input, integer, dim(3) :: amom, bmom, cmom, dmom ! ang. mom. of GTOs
!  Output, real(dp) :: ret ! the value of the ERI
!****************************************************************************
  use kinds, only : dp
  use constants, only : pi
  implicit none
  ! Params
  real(dp), intent(in) :: acen(3), bcen(3), ccen(3), dcen(3) ! origins
  real(dp), intent(in) :: alpa, alpb, alpc, alpd             ! exponents
  integer,  intent(in) :: amom(3), bmom(3), cmom(3), dmom(3) ! ang. mom.
  ! Locals
  real(dp), parameter :: rtol = 1.0e-8_dp
  integer :: ii, jj, kk
  real(dp) :: rab2, rcd2, rpq2
  real(dp) :: gam1, gam2, delt, fbarg, fbnum
  real(dp) :: pcen(3), qcen(3)
!  real(dp), allocatable :: bax(:), bay(:), baz(:)

!  real(dp), dimension(vmax_am_tot) :: bax, bay, baz
!  real(dp), dimension(0:vmax_am_tot) :: fbar
  integer  :: fbarsz
  ! Return
  real(dp) :: ret

  call start_clock('coulomb_rep4')

  ret = 0.0_dp

  ! Combine a & b => p
  rab2 = diff3_norm2(acen, bcen)
  gam1 = alpa + alpb
  call gauss_prod_center(alpa, acen, alpb, bcen, pcen)

  ! Combine c & d => q
  rcd2 = diff3_norm2(ccen, dcen)
  gam2 = alpc + alpd
  call gauss_prod_center(alpc, ccen, alpd, dcen, qcen)

  rpq2 = diff3_norm2(pcen, qcen)                 ! find p & q diff norm
  delt = 0.25_dp * ( 1.0_dp/gam1 + 1.0_dp/gam2 ) ! b_array arg
  ! @TODO?
!  delt = 0.25_dp * ( gam1**-1 + gam2**-1 ) ! b_array arg
  fbarg = 0.25_dp * rpq2 / delt                  ! fboys arg

  if ( (gam1.lt.rtol) .or. (gam2.lt.rtol) .or. (delt.lt.rtol) ) then
      write(6,'("ERR (coulomb_rep4), invalid input, returning 0")')
      ret = 0.0_dp
      return
  end if

  call start_clock('barrays')
  call b_array(amom(1), bmom(1), cmom(1), dmom(1), &
               pcen(1), acen(1), bcen(1), qcen(1), ccen(1), dcen(1), &
               gam1, gam2, delt, bax)
  call b_array(amom(2), bmom(2), cmom(2), dmom(2), &
               pcen(2), acen(2), bcen(2), qcen(2), ccen(2), dcen(2), &
               gam1, gam2, delt, bay)
  call b_array(amom(3), bmom(3), cmom(3), dmom(3), &
               pcen(3), acen(3), bcen(3), qcen(3), ccen(3), dcen(3), &
               gam1, gam2, delt, baz)
  call stop_clock('barrays')

  call start_clock('fboys contract')

  fbarsz = sum( amom + bmom + cmom + dmom )
  do ii = 0, fbarsz
      fbar(ii) = fboys( real(ii,dp), fbarg )
  end do

  do ii = 1, amom(1) + bmom(1) + cmom(1) + dmom(1) + 1
  do jj = 1, amom(2) + bmom(2) + cmom(2) + dmom(2) + 1
  do kk = 1, amom(3) + bmom(3) + cmom(3) + dmom(3) + 1
    !fbnum = real( ii + jj + kk - 3, dp )
    !ret = ret + bax(ii)*bay(jj)*baz(kk)*fboys(fbnum, fbarg)
    ret = ret + bax(ii)*bay(jj)*baz(kk)*fbar(ii+jj+kk-3)
  end do
  end do
  end do
  call stop_clock('fboys contract')

  ret = ret * 2.0_dp * (pi**2.5_dp) / ( gam1*gam2*sqrt(gam1+gam2) ) * &
        exp( -alpa * alpb * rab2 / gam1 ) * &
        exp( -alpc * alpd * rcd2 / gam2 )

  call stop_clock('coulomb_rep4')
  return
end function coulomb_rep4

function coulomb_rep2(acen, amom, alpa, bcen, bmom, alpb) result(ret)
!****************************************************************************
! 2-center ERI, wrapper for coulomb_rep4
!****************************************************************************
  use kinds, only : dp
  implicit none
  ! Params
  real(dp), intent(in) :: acen(3), bcen(3) ! origins
  real(dp), intent(in) :: alpa, alpb       ! exponents
  integer,  intent(in) :: amom(3), bmom(3) ! ang. mom.
  ! Locals
  integer :: am0(3)
  real(dp) :: alp0
  ! Return
  real(dp) :: ret

  am0 = (/ 0, 0, 0 /)
  alp0 = 0.0_dp

  ret = coulomb_rep4(acen, amom, alpa, acen, am0, alp0, &
                     bcen, bmom, alpb, bcen, am0, alp0)

  return
end function coulomb_rep2

end module feril


module geometry_t_interface
  !! Model the propellent grain as a cylinder burning radially outward from its
  !! evacuated axial core and axially inward towards its cross-sectional mid-plane.
  !! The outer diameter is inhibited by the surroundin casing as the propellent was
  !! poured into the tube/chamber so that only the inner diameter burns when ignited.
  use constants, only : dp
  implicit none

  private

  type, public :: geometry_t
    !! Encapsulate the grain geometry and burnout condition
    private
    real(dp) vol_     !! volume
    real(dp) id_      !! inner diameter
    real(dp) od_      !! outer diameter
    real(dp) length_  !! axial length
  contains
    procedure :: surf
    procedure :: vol
    procedure :: burnout
  end type

  interface geometry_t
    module procedure new_geometry_t, incremented_geometry_t
  end interface

  interface

    pure module function new_geometry_t(vol, id, od, length)
      !! Result is a new geometry_t object defined by the actual arguments
      implicit none
      real(dp), intent(in) :: vol    !! volume
      real(dp), intent(in) :: id     !! inner diameter
      real(dp), intent(in) :: od     !! outer diameter
      real(dp), intent(in) :: length !! axial length
      type(geometry_t) :: new_geometry_t
    end function

    pure module function incremented_geometry_t(old_geometry_t, volume_increment)
      !! Result is an updated cylinder after one time step of burning from the inner
      !! diameter outward and from both ends inward along the axial length.
      implicit none
      type(geometry_t), intent(in) :: old_geometry_t
      real(dp), intent(in) :: volume_increment
      type(geometry_t) incremented_geometry_t
    end function

    pure module function surf(this, burn_depth)
      !! Result is the annular grain surface area
      implicit none
      class(geometry_t), intent(in) :: this
      real(dp), intent(in) :: burn_depth !! surface-normal distance burned
      real(dp) surf
    end function

    pure module function vol(this)
      !! Result is the annular grain volume
      implicit none
      class(geometry_t), intent(in) :: this
      real(dp) vol
    end function

    pure module function burnout(this, db)
      !! Result is .true. if all grain has been depleted and .false. otherwise
      implicit none
      class(geometry_t), intent(in) :: this
      real(dp), intent(in) :: db !! burn depth
      logical burnout
    end function

  end interface

end module geometry_t_interface


        Read (*,*)x1,x2
        pi=3.1456
        y1=1/sqrt(pi)*exp(-x1**2)/2
        y2=1/sqrt(pi)*exp(-x2**2)/2
        write(*,*)x1,x2,y1,y2
        stop
        end


program twodintx
use twod_quad
REAL*8 X(3,2),Y(3,2),DATA(450),RES,ERR,s(3)
INTEGER IWORK(100),NU,ND,NEVALS,IFLAG
EXTERNAL F
X(1,1)=0.
Y(1,1)=0.
X(2,1)=1.
Y(2,1)=0.
X(3,1)=1.
Y(3,1)=1.
X(1,2)=0.
Y(1,2)=0.
X(2,2)=1.
Y(2,2)=1.
X(3,2)=0.
Y(3,2)=1.
NU=0
ND=0
IFLAG=1
CALL TWODQ(F,2,X,Y,1.E-08,1,50,4000,RES,ERR,NU,ND, NEVALS,IFLAG,DATA,IWORK)
PRINT*,RES,ERR,NEVALS,IFLAG
!CALL twodqd(f, 2, x, y, 1.e-04, 1, 50, 4000, result,  &
!                  error, nu, nd, nevals, iflag)
!PRINT*,RES,ERR,NEVALS,IFLAG
end program twodintx

real*8 FUNCTION F(X,Y)
real*8 x,y
F=dCOS(X+Y)
RETURN
END


      subroutine initialize(mx,my,meqn,mbc,blockno,
     &      xlower,ylower,dx,dy,q)
      implicit none

      integer meqn, mbc, mx, my, blockno
      double precision xlower, ylower, dx, dy
      double precision q(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn)

      integer i, j, mq, ichoice
      double precision xlow, ylow,wl

      common /com_init/ ichoice

c     # ichoice = 1 : One large circle only
c     # ichocie = 2 : One large circle and several satellite circles
      ichoice = 2

      do mq = 1,meqn
         do i = 1-mbc,mx+mbc
            xlow = xlower + (i-1)*dx
            do j = 1-mbc,my+mbc
               ylow = ylower + (j-1)*dy

               call cellave2(blockno,xlow,ylow,dx,dy,wl)
               q(i,j,mq) = wl
            enddo
         enddo
      enddo

      return
      end

      double precision function fdisc(blockno,xc,yc)
      implicit none

      double precision xc,yc, r
      double precision xp, yp, zp, rp, th, x0
      double precision y0, pi
      integer m, ichoice, blockno
      logical fclaw2d_map_is_used

      integer*8 cont, get_context

      common /com_init/ ichoice

      cont = get_context()

      pi = 4.d0*atan(1.d0)

      if (fclaw2d_map_is_used(cont)) then
         call fclaw2d_map_c2m(cont,
     &         blockno,xc,yc,xp,yp,zp)
      else
         xp = xc
         yp = yc
      endif

      fdisc = -1
      rp = sqrt((xp)**2 + (yp)**2)

c     # Large inner circle
      if (rp .lt. 0.4d0) then
         fdisc = 1.d0
      endif

      if (ichoice .eq. 1) then
         fdisc = -fdisc
         return
      endif

c     # Smaller surrounding circles
      do m = 1,4
c        # Larger circles
         th = (m-1)*pi/2.d0
         x0 = 0.6*cos(th)
         y0 = 0.6*sin(th)
         rp = sqrt((xp - x0)**2 + (yp-y0)**2)
         if (rp .lt. 0.2) then
            fdisc = 1.d0
         endif

c        # Smaller circles
         th = pi/4.d0 + (m-1)*pi/2.d0
         x0 = 0.55*cos(th)
         y0 = 0.55*sin(th)
         rp = sqrt((xp - x0)**2 + (yp-y0)**2)
         if (rp .lt. 0.15) then
            fdisc = 1.d0
         endif
      enddo
      fdisc = -fdisc

      end


!      Ken Klare, LANL P-4      (c)1990,1991
!***********************************************************************
!********************* 3.5 Piecewise Polynomial ************************
!-----------------------------------------------------------------------
      Real*8 Function DPPVAL(x,korder,nintv,break,c)
      Real*8      x      !input, the point to evaluate
      Integer      korder      !input, the order of the polynomial (degree+1)
      Integer nintv      !input, the number of polynomial pieces
      Real*8      break(*)!input, [nintv+1] breakpoints
      Real*8      c(*)      !input, [korder,nintv] polynomial coefficients
!+Evaluate a piecewise polynomial
      Real*8      DPPDER
      DPPVAL = DPPDER(0,x,korder,nintv,break,c)
      End
!-----------------------------------------------------------------------
      Real*8 Function DPPDER(ideriv,x,korder,nintv,break,c)
      Integer ideriv      !input, the order of deriavtive to be evaluated
      Real*8      x      !input, the point to evaluate
      Integer      korder      !input, the order of the polynomial (degree+1)
      Integer nintv      !input, the number of polynomial pieces
      Real*8      break(*)!input, [nintv+1] breakpoints
      Real*8      c(korder,*)!input, [korder,nintv] polynomial coefficients
!+Evaluate derivative of a piecewise polynomial
      Integer j,m,keep
      Real*8      h
      Data      keep/1000000/
! can only take so many derivatives
      If (ideriv.ge.korder) Then
          DPPDER = 0
      Else
! look up the place
          Call DSRCH(nintv,x,break,1,keep)
          If (keep.gt.0) Then
            DPPDER = c(ideriv+1,keep)
          Else
            j = -1-keep
            if (j.le.0) j = 1
            h = x - break(j)
            DPPDER = c(korder,j)
            Do m = korder-ideriv-1, 1, -1
                DPPDER = DPPDER*h/m + c(m+ideriv,j)
            Enddo
          Endif
      Endif
      End
!-----------------------------------------------------------------------
      Real*8 Function DPPITG(a,b,korder,nintv,break,c)
      Real*8      a,b      !input, the range to evaluate
      Integer      korder      !input, the order of the polynomial (degree+1)
      Integer nintv      !input, the number of polynomial pieces
      Real*8      break(*)!input, [nintv] breakpoints
      Real*8      c(korder,*)!input, [korder,nintv] polynomial coefficients
!+Evaluate the integral of a piecewise polynomial
      Integer      ia, ib, j
      Real*8      DP9ITG
        data ia /999999/
      data ib /999999/
      Call DSRCH(nintv,b,break,1,ib)
      If (ib.gt.0) Then
            DPPITG = 0
      Else
            ib = -1-ib
            if (ib.le.0) ib = 1
            DPPITG = DP9ITG(b-break(ib),korder,c(1,ib))
      Endif
      Call DSRCH(nintv,a,break,1,ia)
      If (ia.le.0) Then
            ia = -1-ia
            if (ia.le.0) ia = 1
            DPPITG = DPPITG - DP9ITG(a-break(ia),korder,c(1,ia))
      Endif
      Do j = ia,ib-1
            DPPITG = DPPITG + DP9ITG(break(j+1)-break(j),korder,c(1,j))
      Enddo
      Do j = ib,ia-1
            DPPITG = DPPITG - DP9ITG(break(j+1)-break(j),korder,c(1,j))
      Enddo
      End
!-----------------------------------------------------------------------
      Real*8 Function DP9ITG(h,korder,c)
      Real*8      h      !input, offset point
      Integer      korder      !input, number of terms, degree+1
      Real*8      c(*)      !input, [korder] value and derivatives
      Integer      j
!+Evaluate integral of single polynomial
      DP9ITG = 0
      Do j = korder,1,-1
            DP9ITG = (DP9ITG*h + c(j))/j
      Enddo
      DP9ITG = DP9ITG*h
      End
!-----------------------------------------------------------------------
      Subroutine DPCOEF(ndata,xdata,fdata,cof)
      Integer      ndata      !input, polynomial order (degree+1)
      Real*8      xdata(*)!input, [ndata] the ordinates, must be distinct
      Real*8      fdata(*)!input, [ndata] the abscissae
      Real*8      cof(*)      !input, [ndata] the polynomial coeff
!+Create single piecewise polynomial, value and derivatives at first
! Not an IMSL routine. Method of G.Rybicki from Numerical Recipes POLCOE
      Integer      nmax
      Parameter (nmax=15)
      Integer      i,j,k,n
      Real*8      xx,s(nmax),b,ff,phi,fact(3:nmax)
      Data      fact/2,6,24,120,720,5040,40320,362880,3628800,39916800,
     1 479001600,6227020800E0,87178291200E0/

      n=ndata
      Do i=1,n
          cof(i)=0
          s(i)=0
      Enddo
!      s(n)=-(xdata(1)-xdata(1))
! recurrence
      Do i=2,n
          xx=xdata(i)-xdata(1)
          Do j=n+1-i,n-1
            s(j)=s(j)-xx*s(j+1)
          Enddo
          s(n)=s(n)-xx
      Enddo
      Do j=1,n
          xx=xdata(j)-xdata(1)
          phi=n
! phi=product(xj-xk) for j.ne.k
          Do k=n-1,1,-1
            phi=k*s(k+1)+xx*phi
          Enddo
          ff=fdata(j)/phi
          b=1
          Do k=n,1,-1
            cof(k)=cof(k)+b*ff
            b=s(k)+xx*b
          Enddo
      Enddo
      Do k=3,n
          cof(k)=cof(k)*fact(k)
      Enddo
      End
!***********************************************************************
!********************* Extension for vectors ***************************
!-----------------------------------------------------------------------
      Subroutine DPPVALV(nx,x,korder,nintv,break,c,y)
      Integer      nx      !input, the number of points
      Real*8      x(*)      !input, the [nx] points to evaluate
      Integer      korder      !input, the order of the polynomial (degree+1)
      Integer nintv      !input, the number of polynomial pieces
      Real*8      break(*)!input, [nintv+1] breakpoints
      Real*8      c(*)      !input, [korder,nintv] polynomial coefficients
      Real*8      y(*)      !output, the evaluated points
!+Evaluate a piecewise polynomial
      Call DPPDERV(0,nx,x,korder,nintv,break,c,y)
      End
!-----------------------------------------------------------------------
      Subroutine DPPDERV(ideriv,nx,x,korder,nintv,break,c,y)
      Integer ideriv      !input, the order of deriavtive to be evaluated
      Integer      nx      !input, the number of points
      Real*8      x(*)      !input, the [nx] points to evaluate
      Integer      korder      !input, the order of the polynomial (degree+1)
      Integer nintv      !input, the number of polynomial pieces
      Real*8      break(*)!input, [nintv+1] breakpoints
      Real*8      c(korder,*)!input, [korder,nintv] polynomial coefficients
      Real*8      y(*)      !output, the evaluated points
!+Evaluate derivative of a piecewise polynomial
      Integer j
      Real*8      DPPDER
      Do j=1,nx
          y(j) = DPPDER(ideriv,x(j),korder,nintv,break,c)
      Enddo
      End
!-----------------------------------------------------------------------
      Subroutine DPPITGV(na,a,nb,b,korder,nintv,break,c,y)
      Integer      na      !input, the number of points
      Real*8      a(*)      !input, the [na] points to evaluate from first
      Integer      nb      !input, the number of points
      Real*8      b(*)      !input, the [nb] points to evaluate from first
      Integer      korder      !input, the order of the polynomial (degree+1)
      Integer nintv      !input, the number of polynomial pieces
      Real*8      break(*)!input, [nintv] breakpoints
      Real*8      c(korder,*)!input, [korder,nintv] polynomial coefficients
      Real*8      y(*)      !output, the evaluated points
!+Evaluate the integral of a piecewise polynomial
      Real*8      DPPITG
      Integer j,ja,jb,n,inca,incb
      n = min(na,nb)
      If (na.eq.1) n = nb
      inca = 0
      incb = 0
      If (na.gt.1) inca = 1
      If (nb.gt.1) incb = 1
      ja = 1
      jb = 1
      Do j=1,n
          y(j) = DPPITG(a(ja),b(jb),korder,nintv,break,c)
          ja = ja + inca
          jb = jb + incb
      Enddo
      End


program lagrange_main

implicit none
real(8),allocatable :: x(:),y(:),L(:),xvg(:),yvg(:),xpl(:),ypl(:),er(:)
real(8)::xu,xl,delX, xg, yg,era,DP(6)
integer :: i,j,k,n,m,p

n=10 !(n-1) is the order of polynomial (this means that there should atleast be n+1 values to create a polynomial)
!m=100 !number of values to interpolate after creating the polynomial

do i=1,6
  DP(i)=10**i
end do

do p=1,6
m=DP(p)  !number of values to interpolate after creating the polynomial
allocate(x(n+1),y(n+1),L(n+1),xvg(m),yvg(m),xpl(m),ypl(m),er(6))

  xl=-1.0
  xu=+1.0
  delX=(xu-xl)/(n+1)

 do i=1,n+1
    if (i==1) then
      x(i)=xl
    else
      x(i)=x(i-1)+delX
    end if
    !y(i)=(x(i)**2)-(4*x(i))+4
    !print *,x(i)
    !print *,y(i)
  end do

!enter the equation here
!y=(x**2)-(4*x)+4
y=1/(1+(25*(x**2)))
!y=cos(x*3.14159265359)
!print *, x
!print *, y

delX=(xu-xl)/(m+1)
  do i=1,m
    if (i==1) then
      xvg(i)=xl
    else
      xvg(i)=xvg(i-1)+delX
    end if
    !print *,xvg(i)
  end do
!print *, xvg
!print *,yvg
xpl=xvg

!enter the equation here again
!ypl=(xpl**2)-(4*xpl)+4
ypl=1/(1+(25*(xpl**2)))
!ypl=cos(xpl*3.14159265359)

yvg=0.0
do k=1,size(xvg)
xg=xvg(k)
do i=1,n
    L(i)=1
        do j=1,n
        if (j.ne.i) then
            L(i)=L(i)*(xg-x(j))/(x(i)-x(j))
        end if
        end do
!print *,i,L(i)
yg=yg+L(i)*y(i)
end do
!print *, "Value of y at", xg, "is",yg
yvg(k)=yg
yg=0.0  !!for error not to propagate
end do
era=abs((sum(yvg)/size(yvg))-(sum(ypl)/size(ypl)))

er(p)=era
era=0.0

print*, DP(p),er(p)

deallocate(x,y,L,xvg,yvg,xpl,ypl,er)
end do  !!for the p loop

!open(99, file='eqn1.dat')
!do i=1,m
!  write(99,*) xpl(i),ypl(i),xvg(i),yvg(i)
  !print *, xpl(i),ypl(i),xvg(i),yvg(i)
!end do
close(99)

end program


C--  File port_rand.F: Portable random number generator functions
C--   Contents
C--   o PORT_RAND
C--   o PORT_RANARR
C--   o PORT_RAND_NORM

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP
C     !ROUTINE: PORT_RAND
C     !INTERFACE:
      real*8 FUNCTION PORT_RAND(seed)

C     !DESCRIPTION:
C     Portable random number generator
C      seed >=0 :: initialise using this seed ; and return 0
C      seed < 0 :: if first call then initialise using the default seed (=mseed)
C                  and always return a random number

C     !USES:
      IMPLICIT NONE

C     !INPUT PARAMETERS:
      real*8  seed
CEOP

C     !LOCAL VARIABLES:
      INTEGER nff,idum
      PARAMETER(nff=55)
      PARAMETER(idum=-2)
      real*8 fac
      real*8 mbig,mseed,mz
      PARAMETER (mbig=4000000.,mz=0.,fac=1.d0/mbig)
      real*8 mj,mk,ma(nff)
      DATA mseed/1618033./
      LOGICAL firstCall
      INTEGER i,ii,inext,inextp,k
      DATA firstCall /.true./
      SAVE firstCall,inext,inextp,ma

C-    Initialise the random number generator
      IF (firstCall .OR. seed.GE.mz) THEN
        IF (seed.GE.mz) mseed = seed
        firstCall=.false.
        mj=mseed-iabs(idum)
        mj=mod(mj,mbig)
        ma(nff)=mj
        mk=1
        DO i=1,nff-1
          ii=mod(21*i,nff)
          ma(ii)=mk
          mk=mj-mk
          IF (mk.LT.mz) mk=mk+mbig
          mj=ma(ii)
        ENDDO
        DO k=1,4
          DO i=1,nff
            ma(i)=ma(i)-ma(1+mod(i+30,nff))
            IF (ma(i).LT.mz) ma(i)=ma(i)+mbig
          ENDDO
        ENDDO
        inext=0
        inextp=31
      ENDIF

C-    Compute a random number (only if seed < 0)
      IF (seed.GE.mz) THEN
        port_rand=0.d0
      ELSE
        inext=mod(inext,nff)+1
        inextp=mod(inextp,nff)+1
        mj=ma(inext)-ma(inextp)
        IF (mj.LT.mz) mj=mj+mbig
        ma(inext)=mj
        port_rand=mj*fac
      ENDIF

      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

CBOP
C     !ROUTINE: PORT_RANARR
C     !INTERFACE:
      SUBROUTINE PORT_RANARR(n,arr)

C     !DESCRIPTION:
C     Portable random number array generator

C     !USES:
      IMPLICIT NONE

C     !INPUT PARAMETERS:
      INTEGER n
      real*8 arr(n)
CEOP

C     !LOCAL VARIABLES:
      INTEGER i
      real*8 port_rand
      real*8  seed
      seed=-1.d0
c     seed=1618033.0d0
      DO i=1,n
       arr(i)=port_rand(seed)
      ENDDO

      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP
C     !ROUTINE: PORT_RAND_NORM
C     !INTERFACE:
      real*8 FUNCTION PORT_RAND_NORM()

C     !DESCRIPTION:
C     This function generates a normally distributed random number with
C     the so called polar algorithm. The algorithm actually generates 2
C     numbers, but only 1 is returned for maximum compatibility with old
C     code.  The most obvious way to improve this function would be to
C     make sure that the second number is not wasted.

C     Changed: 2004.09.06 antti.westerlund@fimr.fi

C     !USES:
      IMPLICIT NONE
CEOP

C     !LOCAL VARIABLES:
      real*8 port_rand
      real*8 x1, x2, xs, t

      real*8  seed
      seed=-1.d0
c     seed=1618033.0d0

C     first generate 2 equally distributed random numbers (-1,1)
      xs = 0.0
      DO WHILE ( xs.GE.1.0 .OR. xs.EQ.0.0 )
         x1=2.0*port_rand(seed)-1.0
         x2=2.0*port_rand(seed)-1.0
         xs=x1**2+x2**2
      ENDDO

      t = SQRT(-2.0*LOG(xs)/xs)
      port_rand_norm = t*x1

C     also t*x2 would be a gaussian random number and could be returned

      RETURN
      END


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   lor :     The Lorenz Equations
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

       F(1)= PAR(3) * (U(2)- U(1))
       F(2)= PAR(1)*U(1) - U(2) - U(1)*U(3)
       F(3)= U(1)*U(2) -  PAR(2)*U(3)

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

! Parameter values for the starting orbit in lor.dat :
         PAR(1)=280.
         PAR(2)= 8.d0/3.d0
         PAR(3)=10.

      END SUBROUTINE STPNT

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


subroutine ray_lay(r2,r1,v2,v1,p,time,dist)
!     This subroutine computes transit times and delta increase
!     of a ray travelling from radius R2 down to R1 (or to the
!     turning point Rt if R1<Rt<R2), for linear velocity behaviour
!     from V2 (at R2) to V1. Slowness is P. Output: time T (sec)
!     and distance D (rad). Velocity in km/sec, radii in km.
!     Equations from G.Nolet, Linearized inversion of (teleseismic)
!     data. In: R.Cassinis,'The inverse problem in geophysical
!     interpretation',Plenum Press,NY,1981.
common/pi/pi,per
rz=6378

rr=(r2-r1)/r1
vv=(v2-v1)/v1
!kod_sing=0
!if(abs(vv/rr)-1..lt.0.01) then
!	kod_sing=1
!	rzz=rz+1000.
!	p = p * rzz / rz
!	r1=r1+1000.
!	r2=r2+1000.
!	write(*,*)' singularity'
!end if
!write(*,*)' kod_sing=',kod_sing

time=0
dist=0
if(abs(v1*v2).lt.0.000001) return

if(abs(p).lt.0.000001) then
	if(abs(v2-v1).gt.0.000001) then
		time=(log(v2)-log(v1))/dvdr
	else
		time=(r2-r1)/v1
	end if
	return
end if

!vr1=v1/r1
!vr2=v2/r2
!dif_pr=100*(vr2-vr1)/vr1
!write(*,*)' v1/r1=',v1/r1,' v2/r2=',v2/r2,' dif_pr=',dif_pr
!if(abs(dif_pr).lt.0.0001) then
!	sint=p*v1/r1
!	cost=sqrt(1-sint*sint)
!	ds=abs(r2-r1)/cost
!	v=(v2+v1)/2
!	r=(r2+r1)/2
!	time=ds/v
!	dist=ds*sint/r
!	return
!end if

zav=rz-(r2+r1)/2.

!if((zav-150)*(zav-155).lt.0) write(*,*)' z1=',rz-r1,' z2=',rz-r2
!if((zav-150)*(zav-155).lt.0) write(*,*)' v1=',v1,' v2=',v2
!if((zav-150)*(zav-155).lt.0) write(*,*)' v1/r1=',v1/r1,' v2/r2=',v2/r2

!write(*,*)
!write(*,*)' v1/r1=',v1/r1,' v2/r2=',v2/r2,' diff=',diff

diff=100*(v1/r1-v2/r2)/(v1/r1)
if(diff.lt.0.0001) then
	sint=p*v1/r1
	cost=sqrt(1-sint*sint)
	dz=abs(r2-r1)
	ds=dz/cost
	vav=(v1+v2)/2
	time=ds/vav
	dh=ds*sint
	dist=dh/rz
	return
end if

dvdr=(v2-v1)/(r2-r1)
ap = dvdr*p

if(r2.gt.0.0000001) then
	sint2=p*v2/r2
else
	sint2=1.
end if
if(sint2.gt.1.) return

if(r1.gt.0.0000001) then
	sint1=p*v1/r1
else
	sint1=1.
end if
if(sint1.gt.1.) sint1=1

!write(*,*)' sint1=',sint1,' sint2=',sint2

teta1=asin(sint1)
teta2=asin(sint2)

tgt1=TAN(teta1 / 2.)
tgt2=TAN(teta2 / 2.)

if(ap.eq.0.) then
	sntet=0
	c1=1. / TAN(TETA1)
	c2=1. / TAN(TETA2)
	time=p*(c2-c1)
else
	ap2=ap*ap
	sqap=SQRT(abs(1.-ap2))
	if(ap2.eq.1.) then
		sntet1=TAN(.785398132 + ap * .5 * teta1)
		sntet2=TAN(.785398132 + ap * .5 * teta2)
		!write(*,*)' metka2'
	else if(ap2.lt.1.) then
		alfa=acos(-ap)

		sntet1=-.5*log((1.+SIN(alfa+teta1))/(1.-SIN(alfa-teta1)))/sqap
		sntet2=-.5*log((1.+SIN(alfa+teta2))/(1.-SIN(alfa-teta2)))/sqap
		!write(*,*)' teta1=',teta1,' teta2=',teta2,' alfa=',alfa
	else if(ap2.gt.1) then
		aptg1 = -ap * tgt1 + 1.
		aptg2 = -ap * tgt2 + 1.
		sntet1=2.*ATAN(aptg1/sqap)/sqap
		sntet2=2.*ATAN(aptg2/sqap)/sqap
		!write(*,*)' metka222'
	end if
	time = (log(tgt2) - log(tgt1) - sntet2 + sntet1) / dvdr
	dist = teta1-teta2-ap*(sntet2-sntet1)
	!write(*,*)' metka11'
end if

!if(kod_sing.eq.1) then
!	dist=dist*rzz/rz
!	p = p * rz / rzz
!	r1=r1-1000.
!	r2=r2-1000.
!end if

return
end


c
c ---------------------------------------------------------------------
c
      subroutine rmnv(ql,qr,qgdnv)
      implicit double precision (a-h,o-z)
      dimension ql(4), qr(4), qgdnv(4)
      data      itno/2/, small/1.d-6/
c
      gamma = 1.4
      gamma1 = gamma - 1.
      gp1g2i = (gamma+1.d0)/(2.d0*gamma)
c
c     # Riemann solver in x-direction
c     # Given states ql and qr, compute flux at interfaces.

c     # change variables from q1 = rho, q2 = rho*u, ...  to
c     # rho, u, p:
c
         rhol = ql(1)
         rhor = qr(1)
         ul = ql(2)/rhol
         ur = qr(2)/rhor
         utl = ql(3)/rhol
         utr = qr(3)/rhor
         pl = gamma1* (ql(4)- .5d0* (ql(2)*ql(2)/ql(1)
     &      + ql(3)* ql(3)/ql(1)))
         pr = gamma1* (qr(4)- .5d0* (qr(2)*qr(2)/qr(1)
     &      + qr(3)* qr(3)/qr(1)))
c
c     # iterate to find pstar, ustar:
c
      clsl = gamma*rhol*pl
      wm = dsqrt(clsl)
         clsr = gamma*rhor*pr
         wp = wm
         wm = dsqrt(clsr)
         pstar = (wp*pr+ wm*pl- wm*wp
     &      *(ur- ul))/(wp+ wm)
         pstar = dmax1(pstar,small)
c
      do 30 iter = 1, itno
           wsqp = clsl*(1.d0+gp1g2i*(pstar/pl-1.d0))
           wp   = dsqrt(wsqp)
           wsqm = clsr*(1.d0+gp1g2i*(pstar/pr-1.d0))
           wm   = dsqrt(wsqm)
c
           zp = 2.d0*wp*wsqp/(wsqp+clsl)
           zm = 2.d0*wm*wsqm/(wsqm+clsr)
c
           ustarm = ur-(pr-pstar)/wm
           ustarp = ul+(pl-pstar)/wp
           zsum = zp+zm
           epsp = zp*zm*(ustarm-ustarp)/zsum
           pstar = pstar-epsp
           pstar = dmax1(pstar,small)
  30       continue
c
         ustar = (zp*ustarm+zm*ustarp)/zsum
         sein  = -dsign(1.d0,ustar)
	 if (sein .ge. 0.0) then
            uo = ur
            po = pr
            ro = rhor
            utgdnv = utr
	 else
            uo = ul
            po = pl
            ro = rhol
            utgdnv = utl
	 endif
         co = dsqrt(po*gamma/ro)

         dummy = pstar-po
         wo = gamma*ro*po*(1.d0+gp1g2i*dummy/po)
         rstar = ro/(1.d0-ro*dummy/wo)
         wo = dsqrt(wo)
         cstar = dsqrt(gamma*pstar/rstar)
         wso = sein*uo+co
         wsi = sein*ustar+cstar
         ushok = sein*ustar+wo/rstar
	 if (dummy .ge. 0.d0) then
            wsi = ushok
            wso = ushok
	 else
            wsi = wsi
            wso = wso
	 endif

         t4 = (wso+wsi)/dmax1(wso-wsi,wso+wsi,small)
         t4 = .5d0*(t4+1.d0)
         t5  = 1.d0-t4
         t3  = t4*cstar+t5*co
         rgdnv = t4*rstar+t5*ro
         ugdnv = t4*ustar+t5*uo
         pgdnv = t3*t3*rgdnv/gamma

	 if (wso .ge. 0.d0) then
            pgdnv = pgdnv
            rgdnv = rgdnv
            ugdnv = ugdnv
	 else
            pgdnv = po
            rgdnv = ro
            ugdnv = uo
	 endif

	 if (wsi .lt. 0.d0) then
            pgdnv = pgdnv
            rgdnv = rgdnv
            ugdnv = ugdnv
	 else
            pgdnv = pstar
            rgdnv = rstar
            ugdnv = ustar
	 endif

         qgdnv(1) = rgdnv
         qgdnv(2) = rgdnv*ugdnv
         qgdnv(3) = rgdnv*utgdnv
         qgdnv(4) = pgdnv/gamma1+.5*rgdnv*(ugdnv**2+utgdnv**2)
c
      return
      end


!*********************************************************************
! This file is part of Polylogarithm.
!
! Polylogarithm is licenced under the MIT License.
!*********************************************************************

!*********************************************************************
!> @brief Complex polylogarithm \f$\operatorname{Li}_6(z)\f$
!> @param z complex argument
!> @return \f$\operatorname{Li}_6(z)\f$
!> @author Alexander Voigt
!*********************************************************************
double complex function cdli6(z)
  implicit none
  double complex :: z, u, u2, u4, u8, c5, lmz, r, fast_pos_cdlog
  double precision :: rz, iz, nz, pz, lnz, arg, sgn
  double precision, parameter :: PI    = 3.1415926535897932D0
  double precision, parameter :: PI2   = 9.8696044010893586D0
  double precision, parameter :: PI4   = 97.409091034002437D0
  double precision, parameter :: PI6   = 961.38919357530444D0
  double precision, parameter :: zeta6 = 1.0173430619844491D0
  double precision, parameter :: c1    = 1.0369277551433699D0 ! zeta(5)
  double precision, parameter :: c2    = 0.54116161685556910D0
  double precision, parameter :: c3    = 0.20034281719326571D0
  double precision, parameter :: c4    = 0.068538919452009435D0
  double precision, parameter :: c6    = -1D0/1440
  double precision, parameter :: bf(18) = (/           &
      1.0D0                 , -31.0D0/64.0D0         , &
      1.5241340877914952D-01, -3.4365555877057613D-02, &
      5.7174797239368999D-03, -6.8180453746570645D-04, &
      4.9960361948734493D-05, -4.9166051196039048D-07, &
     -3.0632975161302164D-07,  1.4414599270849095D-08, &
      3.7272438230924107D-09, -3.7300867345487607D-10, &
     -5.1246526816085832D-11,  9.0541930956636683D-12, &
      6.7381882615512517D-13, -2.1215831150303135D-13, &
     -6.8408811719011698D-15,  4.8691178462005581D-15  /)
  double precision, parameter :: cs(5) = (/            &
     -1.6534391534391534D-05, 2.2964432686654909D-08,  &
     -9.9413128513657614D-11, 6.6912682653423394D-13,  &
     -5.7933058574392549D-15                           /)

  rz = real(z)
  iz = aimag(z)

   if (iz .eq. 0) then
      if (rz .eq. 0) then
         cdli6 = 0
         return
      endif
      if (rz .eq. 1) then
         cdli6 = zeta6
         return
      endif
      if (rz .eq. -1) then
         cdli6 = -31*zeta6/32
         return
      endif
   endif

   nz  = rz**2 + iz**2
   pz  = datan2(iz, rz)
   lnz = 0.5D0*log(nz)

   if (lnz**2 + pz**2 .lt. 1) then ! |log(z)| < 1
      u = dcmplx(lnz, pz) ! log(z)
      u2 = u**2
      c5 = (137D0/60 - fast_pos_cdlog(-u))/120
      cdli6 = zeta6 + u * c1 + &
         u2 * (c2 + u * c3 +   &
         u2 * (c4 + u * c5 +   &
         u2 * (c6 +            &
         u * (cs(1) +          &
         u2 * (cs(2) +         &
         u2 * (cs(3) +         &
         u2 * (cs(4) +         &
         u2 * (cs(5)))))))))
      return
   endif

   if (nz .le. 1) then
      u = -fast_pos_cdlog(1 - z)
      r = 0
      sgn = 1
   else ! nz > 1
      if (pz .gt. 0) then
         arg = pz - PI
      else
         arg = pz + PI
      endif
      lmz = dcmplx(lnz, arg) ! log(-z)
      u = -fast_pos_cdlog(1 - 1/z)
      r = -31*PI6/15120 + lmz**2*(-7*PI4/720 + lmz**2*(-PI2/144 - lmz**2/720))
      sgn = -1
   endif

   u2 = u**2
   u4 = u2**2
   u8 = u4**2

   cdli6 =                                                      &
      r + sgn * (                                               &
         u*bf(1) +                                              &
         u2*(bf(2) + u*bf(3)) +                                 &
         u4*(bf(4) + u*bf(5) + u2*(bf(6) + u*bf(7))) +          &
         u8*(bf(8) + u*bf(9) + u2*(bf(10) + u*bf(11)) +         &
             u4*(bf(12) + u*bf(13) + u2*(bf(14) + u*bf(15)))) + &
         u8*u8*(bf(16) + u*bf(17) + u2*bf(18))                  &
      )

end function cdli6


C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 06.01.01/04                           *
C  *    TEST TITLE : Behavior of matrix composition        *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

      REAL      ACT4X4(4,4), EXP4X4(4,4), AIN4X4(4,4), BIN4X4(4,4)
      REAL      ACT3X3(3,3), EXP3X3(3,3), AIN3X3(3,3), BIN3X3(3,3)
      REAL      INC
      INTEGER   I,J
      LOGICAL   TRNSEQ

      CALL INITGL ('06.01.01/04')

C open PHIGS
      CALL XPOPPH  (ERRFIL, MEMUN)
      CALL SETMSG ('1 2 11', 'The matrix returned by <compose ' //
     1             'matrix 3> should perform the same 3D '      //
     2             'transformation as that resulting from the ' //
     3             'multiplication of the two specified matrices.')

      AIN4X4(1,1) = -2.2
      AIN4X4(1,2) = 3.3
      AIN4X4(1,3) = 4.4
      AIN4X4(1,4) = 5.5
      AIN4X4(2,1) = 0.0023
      AIN4X4(2,2) = -727.12
      AIN4X4(2,3) = 2.09
      AIN4X4(2,4) = 33.33
      AIN4X4(3,1) = 0
      AIN4X4(3,2) = 34
      AIN4X4(3,3) = 54.1
      AIN4X4(3,4) = -0.045
      AIN4X4(4,1) = 7
      AIN4X4(4,2) = 6
      AIN4X4(4,3) = 5
      AIN4X4(4,4) = 4

      INC = 0.0
      DO 401 I = 1,4
      DO 402 J = 1,4
        BIN4X4(I,J) = TAN(-1.56 + INC)
        INC = INC + 3.0/16.0
402   CONTINUE
401   CONTINUE

      CALL PCOM3  (AIN4X4, BIN4X4, ERRIND, ACT4X4)
      CALL CHKINQ ('pcom3', ERRIND)

C  Compute exp4x4 = expected array
      CALL ECOM3  (AIN4X4, BIN4X4, EXP4X4)

C  pass if matrices represent same transformation
      CALL IFPF   (TRNSEQ(4, ACT4X4, EXP4X4))

      CALL SETMSG ('1 2 12', 'The matrix returned by <compose ' //
     1             'matrix> should perform the same 2D '        //
     2             'transformation as that resulting from the ' //
     3             'multiplication of the two specified matrices.')

      AIN3X3(1,1) = -2.2
      AIN3X3(1,2) = 3.3
      AIN3X3(1,3) = 5.5
      AIN3X3(2,1) = 0.0023
      AIN3X3(2,2) = -727.12
      AIN3X3(2,3) = 33.33
      AIN3X3(3,1) = 0
      AIN3X3(3,2) = 34
      AIN3X3(3,3) = -0.045

      INC = 0.0
      DO 301 I = 1,3
      DO 302 J = 1,3
        BIN3X3(I,J) = TAN(-1.56 + INC)
        INC = INC + 3.0/9.0
302   CONTINUE
301   CONTINUE

      CALL PCOM  (AIN3X3, BIN3X3, ERRIND, ACT3X3)
      CALL CHKINQ ('pcom', ERRIND)

C  Compute exp3x3 = expected array
      CALL ECOM  (AIN3X3, BIN3X3, EXP3X3)

C  pass if matrices represent same transformation
      CALL IFPF   (TRNSEQ(3, ACT3X3, EXP3X3))

      CALL ENDIT
      END


PROGRAM LA_CHEEVD_ET_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => SP
   USE F95_LAPACK, ONLY: LA_HEEVD
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
      CHARACTER(LEN=*), PARAMETER :: FMT = '(4(1X,1H(,F7.3,1H,,F7.3,1H):))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   INTEGER :: I, J, INFO, N
!  .. LOCAL ARRAYS ..
   REAL(WP), ALLOCATABLE :: AA(:,:), W(:)
   COMPLEX(WP), ALLOCATABLE :: A(:,:)
!
!  .. EXECUTABLE STATEMENTS ..
!
   WRITE(NOUT,*) 'CHEEVD ET_Example Program Results.'
   READ(NIN,*) ! SKIP HEADING IN DATA FILE
   READ(NIN,*) N
   ALLOCATE ( A(N,N), AA(N,N), W(N) )
      DO I = 1, N
        READ(NIN,*) (AA(I, J), J = 1, N)
      ENDDO
   A=AA
      WRITE(NOUT,*) 'The matrix A:'
      DO I = 1, N
        WRITE(NOUT,FMT) A(I,:)
      ENDDO
!
   WRITE(NOUT,*) '---------------------------------------------------------'
   WRITE(NOUT,*)
   WRITE ( NOUT, * )'Details of LA_CHEEVD LAPACK Subroutine Results.'
   WRITE(NOUT,*)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_HEEVD(A, W, INFO=INFO)'
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A - the original matrix (upper triangular)'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - destroyed matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   CALL LA_HEEVD(A,W,INFO=INFO)
   WRITE(NOUT,*) 'The eigenvalues computed by LA_HEEVD:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'INFO = ',INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_HEEVD(A, W, 'V')"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A - the original matrix (upper triangular)'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - orthonormal eigenvectors of the matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   CALL LA_HEEVD(A,W,'V')
   WRITE(NOUT,*) 'The eigenvalues computed by LA_HEEVD:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'The orthonormal eigenvectors computed by LA_HEEVD:'
   DO I = 1, N
      WRITE(NOUT,FMT) A(I,:)
   END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_HEEVD(A, W, 'V', 'L')"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A - the original matrix (lower triangular)'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - orthonormal eigenvectors of the matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   CALL LA_HEEVD(A,W,'V','L')
   WRITE(NOUT,*) 'The eigenvalues computed by LA_HEEVD:'
   WRITE(NOUT,FMT) W(:)
   WRITE(NOUT,*) 'The orthonormal eigenvectors computed by LA_HEEVD:'
   DO I = 1, N
      WRITE(NOUT,FMT) A(I,:)
   END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_HEEVD(A, W, UPLO='L')"
   WRITE(NOUT,*) 'ON ENTRY: A'
   WRITE(NOUT,*) '   A - the original matrix (lower triangular)'
   WRITE(NOUT,*) 'ON EXIT: A, W'
   WRITE(NOUT,*) '   A - destroyed matrix A'
   WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
   A=AA
   CALL LA_HEEVD(A,W,UPLO='L')
   WRITE(NOUT,*) 'The eigenvalues computed by LA_HEEVD:'
   WRITE(NOUT,FMT) W(:)
!
END PROGRAM LA_CHEEVD_ET_EXAMPLE