C######################################################################|
      module calculate_Dreicer_growthrate
C----------------------------------------------------------------------|
C     This module is used to calculate the Dreicer runaway growth rate.
C
C     Functions:
C       - Dreicer_growthrate_classic
C       - Dreicer_growthrate_CODE_neural_network
C
C     Function arguments:
C       - Z:    atomic number of each ion species
C       - Z0:   net charge of plasma for each ion species
C       - nj:   density of each ion species (m**-3)
C       - nSpe: number of ion species
C       - T:    electron temperature (eV)
C       - Epar: parallel electric field (V/m)
C
C----------------------------------------------------------------------|
      use double
      use collision_frequencies, only :
     >  nu_ee
      use electric_fields, only :
     >  E_c, E_D

      implicit none

      private

      public ::
     >  Dreicer_growthrate_classic,
     >  Dreicer_growthrate_CODE_neural_network

        ! ----- Parameters --------------------------------------------|
      real(kind=dp), parameter ::
     >  pi = 3.1415926535897931_dp

      contains

C======================================================================|
      real(kind=dp) function Dreicer_growthrate_classic(Z, Z0, nj,
     >  nSpecies, T, Epar) result (Gamma_D)
C----------------------------------------------------------------------|
C     The flux of primary electrons to relativistic momenta is
C     calculated according to Eqs. (62)-(64) in
C     J.W. Connor and R.J. Hastie, Nucl. Fusion 15, 415 (1975).
C
C     Input:
C       Z   : atomic number of each ion species
C       Z0  : net charge of plasma for each ion species
C       nj  : density of each ion species (m**-3)
C       nSpe: number of ion species
C           Z, Z0 and nj must be vectors of length nSpecies
C       T   : temperature (eV)
C       Epar: parallel electric field (V/m)
C
C     Output:
C       Gamm: flux of primary runaway electrons (1/s)
C
C----------------------------------------------------------------------|
        ! ----- Parameters --------------------------------------------|
      real(kind=dp), parameter ::
     >  CR = 1.0_dp

        ! ----- Function arguments ------------------------------------|
      integer, intent(in) ::
     >  nSpecies, Z(nSpecies), Z0(nSpecies)

      real(kind=dp), intent(in) ::
     >  Epar, nj(nSpecies), T

        ! ----- Local variables ---------------------------------------|
      integer ::
     >  i

      real(kind=dp) ::
     >  EE_c, EE_D, gam, h, lambda, ne, Zeff

C----------------------------------------------------------------------|
C     Construct required quantities
C----------------------------------------------------------------------|
        ! ----- Free electron density ---------------------------------|
      ne = sum(Z0(:)*nj(:))

        ! ----- Critical electric field -------------------------------|
      EE_c = Epar/E_c(ne, T)

        ! ----- Dreicer electric field --------------------------------|
      EE_D = Epar/E_D(ne, T)

        ! ----- Effective charge --------------------------------------|
      Zeff = sum(Z0(:)**2*nj(:))/ne

C----------------------------------------------------------------------|
C     Calculate growth rate
C----------------------------------------------------------------------|
      Gamma_D = 0._dp
      if (EE_c .le. 1._dp) return

      h = (EE_c - (Zeff-7)/(Zeff+1) + 2*sqrt(EE_c/(EE_c-1))
     >  *(EE_c-2))*(Zeff+1)/(16*(EE_c-1))

      lambda = 8*EE_c**2*(1 - 1._dp/(2*EE_c) - sqrt(1 - 1._dp/EE_c))

      gam = EE_c/2*sqrt((Zeff+1)/(EE_c-1))*(pi/2 - asin(1-2._dp/EE_c))

      Gamma_D = CR*nu_ee(ne, T)*EE_D**(-h)
     >  *exp(-lambda/(4*EE_D) - gam/sqrt(EE_D))

      return
      end function Dreicer_growthrate_classic
C======================================================================|

C======================================================================|
      real(kind=dp) function Dreicer_growthrate_CODE_neural_network(
     >   Z, Z0, nj, nSpecies, T, Epar) result (Gamma_D)
C----------------------------------------------------------------------|
C     The flux of primary electrons to relativistic momenta is
C     calculated according to Eq. (3.3) in L. Hesslow et al., J. Plasma
C     Phys. 85, 475850601 (2019).
C
C     Input:
C       Z   : atomic number of each ion species
C       Z0  : net charge of plasma for each ion species
C       nj  : density of each ion species (m**-3)
C       nSpe: number of ion species
C           Z, Z0 and nj must be vectors of length nSpecies
C       T   : temperature (eV)
C       Epar: parallel electric field (V/m)
C
C     Output:
C       Gamm: flux of primary runaway electrons (1/s)
C
C----------------------------------------------------------------------|
      include 'src/inc/parameters_CODE_neural_network.inc'

        ! ----- Function arguments ------------------------------------|
      integer, intent(in) ::
     >  nSpecies, Z(nSpecies), Z0(nSpecies)

      real(kind=dp), intent(in) ::
     >  Epar, nj(nSpecies), T

        ! ----- Local variables ---------------------------------------|
      real(kind=dp) ::
     >  input(8), ne, ne_tot

C----------------------------------------------------------------------|
C     Construct required quantities
C----------------------------------------------------------------------|
        ! ----- Free electron density ---------------------------------|
      ne   = sum(Z0(:)*nj(:))

        ! ----- Total electron density --------------------------------|
      ne_tot = sum(Z( :)*nj(:))

      input = (/
     >  sum(Z0(:)**2*nj(:))/ne,
     >  sum((Z(:)**2-Z0(:)**2)*nj(:))/ne_tot,
     >  sum(nj(:)*Z0(:)/Z(:))/ne_tot,
     >  sum(Z0(:)*Z(:)*nj(:))/ne_tot,
     >  log(ne),
     >  ne/ne_tot,
     >  Epar/E_D(ne, T),
     >  log(T/510998.946_dp)
     >  /)

        ! Normalize input
      input = (input - input_mean) / input_std

C----------------------------------------------------------------------|
C     Evaluate neural network
C----------------------------------------------------------------------|
      Gamma_D =
     >  dot_product(W5,
     >      tanh(matmul(W4,
     >          tanh(matmul(W3,
     >              tanh(matmul(W2,
     >                  tanh(matmul(W1, input) + b1))
     >              + b2))
     >          + b3))
     >      + b4))
     >  + b5

      Gamma_D = 4._dp/(3*sqrt(pi))*nu_ee(ne, T)
     >  * exp(Gamma_D*output_std + output_mean)

      return
      end function Dreicer_growthrate_CODE_neural_network
C======================================================================|

      end module calculate_Dreicer_growthrate
C######################################################################|


! Program to test AINT and ANINT intrinsics

subroutine real4test (op, res1, res2)
   implicit none
   real(kind=4) :: op
   real(kind=4) :: res1, res2

   if (diff(aint(op), res1) .or. &
       diff(anint(op), res2)) call abort
contains
function diff(a, b)
  real(kind=4) :: a, b
  logical diff

  diff = (abs (a - b) .gt. abs(a * 1e-6))
end function
end subroutine

subroutine real8test (op, res1, res2)
   implicit none
   real(kind=8) :: op
   real(kind=8) :: res1, res2

   if (diff(aint(op), res1) .or. &
       diff(anint(op), res2)) call abort
contains
function diff(a, b)
  real(kind=8) :: a, b
  logical diff

  diff = (abs(a - b) .gt. abs(a * 1e-6))
end function
end subroutine

program aint_aninttest
   implicit none

   call real4test (3.456, 3.0, 3.0)
   call real4test (-2.798, -2.0, -3.0)
   call real4test (3.678, 3.0, 4.0)
   call real4test (-1.375, -1.0, -1.0)
   call real4test (-0.5, 0.0,-1.0)
   call real4test (0.4, 0.0,0.0)

   call real8test (3.456_8, 3.0_8, 3.0_8)
   call real8test (-2.798_8, -2.0_8, -3.0_8)
   call real8test (3.678_8, 3.0_8, 4.0_8)
   call real8test (-1.375_8, -1.0_8, -1.0_8)
   call real8test (-0.5_8, 0.0_8,-1.0_8)
   call real8test (0.4_8, 0.0_8,0.0_8)

   ! Check large numbers
   call real4test (2e34, 2e34, 2e34)
   call real4test (-2e34, -2e34, -2e34)
end program


! qmc_walk_sho.f90
! Quantum MC, random walk, simple harmonic oscillator
PROGRAM qmc_walk_sho

  !------------------------------------------------------------------------------------------------!
  ! This software was written in 2016/17                                                           !
  ! by Michael P. Allen <m.p.allen@warwick.ac.uk>/<m.p.allen@bristol.ac.uk>                        !
  ! and Dominic J. Tildesley <d.tildesley7@gmail.com> ("the authors"),                             !
  ! to accompany the book "Computer Simulation of Liquids", second edition, 2017 ("the text"),     !
  ! published by Oxford University Press ("the publishers").                                       !
  !                                                                                !
  ! LICENCE                                                                                !
  ! Creative Commons CC0 Public Domain Dedication.                                                 !
  ! To the extent possible under law, the authors have dedicated all copyright and related         !
  ! and neighboring rights to this software to the PUBLIC domain worldwide.                        !
  ! This software is distributed without any warranty.                                             !
  ! You should have received a copy of the CC0 Public Domain Dedication along with this software.  !
  ! If not, see <http://creativecommons.org/publicdomain/zero/1.0/>.                               !
  !                                                                                !
  ! DISCLAIMER                                                                                !
  ! The authors and publishers make no warranties about the software, and disclaim liability       !
  ! for all uses of the software, to the fullest extent permitted by applicable law.               !
  ! The authors and publishers do not recommend use of this software for any purpose.              !
  ! It is made freely available, solely to clarify points made in the text. When using or citing   !
  ! the software, you should not imply endorsement by the authors or publishers.                   !
  !------------------------------------------------------------------------------------------------!

  ! Program to calculate the ground state wavefunction
  ! for a particle in a harmonic potential, V=(x**2)/2,
  ! by solving the corresponding diffusion equation in imaginary time.

  ! In atomic units, mass=1, hbar=1, diffusion coefficient D = hbar**2/(2*m) = 1/2,
  ! so root-mean-squared displacement in time step ds is sqrt(2*D*ds) = sqrt(ds)
  ! Walkers are created and destroyed, depending on the potential energy relative to the trial energy et
  ! The program adjusts et to attempt to converge on a target number of walkers
  ! hence obtaining the exact ground state value et = 0.5
  ! This type of simulation is very sensitive to the initial guess for et,
  ! and the resulting time evolution is quite noisy:
  ! results are output as averages over the production period.
  ! The simulated ground state wave function may be compared with the exact result for this simple problem.

  ! Reads several variables and options from standard input using a namelist nml
  ! Leave namelist empty to accept supplied defaults
  ! The default parameters run the simulation with et = 0.5, the exact groundstate energy for this potential.
  ! You can then try, say, et = 0.6 and et = 0.4, observing the behaviour of the number of walkers in each case.

  ! Many of the parameters, and the updating scheme for et, are taken from the following paper:
  ! I Kostin, B Faber and K Schulten, Amer J Phys, 64, 633 (1996)

  USE, INTRINSIC :: iso_fortran_env, ONLY : input_unit, output_unit, error_unit, iostat_end, iostat_eor
  USE               averages_module, ONLY : time_stamp
  USE               maths_module,    ONLY : random_normal

  IMPLICIT NONE

  REAL,    DIMENSION(:), ALLOCATABLE  :: x       ! position of each walker (n_max)
  REAL,    DIMENSION(:), ALLOCATABLE  :: v       ! potential energy of each walker (n_max)
  INTEGER, DIMENSION(:), ALLOCATABLE  :: replica ! number of replicas to make (n_max)
  LOGICAL, DIMENSION(:), ALLOCATABLE  :: alive   ! flags those walkers still alive (n_max)
  INTEGER, DIMENSION(:), ALLOCATABLE  :: bin     ! histogram bins for wavefunction (n_bin)
  REAL,    DIMENSION(:), ALLOCATABLE  :: psi     ! wavefunction (n_bin)

  REAL, PARAMETER :: pi = 4.0 * ATAN ( 1.0 ), const = (1.0/pi) ** (1.0/4.0)

  INTEGER :: n, n_max, n_target, n_add, n_bin, nlive, ibin, ioerr
  INTEGER :: i, production_steps, equilibration_steps, output_interval, step, step_count
  REAL    :: x_max, de, ds, et, k, et_avg, pot_avg, pot
  REAL    :: zeta, dx
  REAL    :: factor, pexact, x_bin

  NAMELIST /nml/ production_steps, equilibration_steps, output_interval, x_max, et, ds, n_bin, n_max, n_target

  WRITE ( unit=output_unit, fmt='(a)') 'qmc_walk_sho'
  WRITE ( unit=output_unit, fmt='(a)') 'Diffusion Monte Carlo simulation of a quantum oscillator'
  WRITE ( unit=output_unit, fmt='(a)') 'Results in atomic units'
  CALL time_stamp

  ! Set up default parameters for the simulation
  n_max               = 2000  ! max number of walkers
  n_target            = 500   ! target number of walkers
  production_steps    = 20000 ! number of steps for production
  equilibration_steps = 20000 ! number of steps for equilibration
  output_interval     = 200   ! output interval
  et                  = 0.5   ! initial estimate of ground state energy in atomic units
  ds                  = 0.1   ! timestep in imaginary time
  x_max               = 10.0  ! half length of the line, centred at x = 0.0
  n_bin               = 200   ! number of bins covering -x_max .. x_max
  READ ( unit=input_unit, nml=nml, iostat=ioerr )
  IF ( ioerr /= 0 ) THEN
     WRITE ( unit=error_unit, fmt='(a,i15)') 'Error reading namelist nml from standard input', ioerr
     IF ( ioerr == iostat_eor ) WRITE ( unit=error_unit, fmt='(a)') 'End of record'
     IF ( ioerr == iostat_end ) WRITE ( unit=error_unit, fmt='(a)') 'End of file'
     STOP 'Error in qmc_walk_sho'
  END IF
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Max number of walkers = ',                   n_max
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Target number of walkers = ',                n_target
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Number of steps for production = ',          production_steps
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Number of steps for equilibration = ',       equilibration_steps
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Output interval = ',                         output_interval
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Initial estimate of ground state energy = ', et
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Time step = ',                               ds
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Max x for wavefunction = ',                  x_max
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Number of bins for wavefunction = ',         n_bin

  dx = 2.0*x_max / REAL(n_bin)  ! Bin interval for calculating the wavefunction
  IF ( n_target > n_max ) THEN
     WRITE ( unit=error_unit, fmt='(a,2i15)' ) 'n_target exceeds n_max at start', n_target, n_max
     STOP 'Error in qmc_walk_sho'
  END IF

  ALLOCATE ( x(n_max), v(n_max), replica(n_max), alive(n_max) )
  ALLOCATE ( psi(n_bin), bin(n_bin) )

  CALL RANDOM_SEED()

  ! Set up an initial delta distribution of walkers at origin
  n = n_target
  x(1:n) = 0.0

  ! Set up energy averages and array for calculating the wave function
  bin(1:n_bin) = 0
  step_count   = 0
  et_avg       = 0.0
  pot_avg      = 0.0

  WRITE ( unit=output_unit, fmt='(a)' ) '           step       nwalkers             e0            <v>'

  DO step = 1, equilibration_steps+production_steps  ! Loop over steps

     ! Move each walker forward by ds in imaginary time
     DO i = 1, n
        x(i) = x(i) + random_normal( 0.0, SQRT(ds) ) ! Brownian dynamics step
     END DO

     ! Calculate potential energy of each walker
     v(1:n) = 0.5 * x(1:n)**2

     ! Calculate the replica number for each walker
     DO i = 1, n
        de = ( v(i) - et ) *  ds           ! scaled energy difference with the trial ground state
        k  = EXP( -de )                    ! new number of replicas
        CALL RANDOM_NUMBER( zeta )
        replica(i) = FLOOR ( k+zeta )      ! integerized number of replicas
        replica(i) = MIN ( replica(i), 3 ) ! guard against too rapid growth
     END DO

     ! Remove walkers with replica = 0
     alive(1:n)       = replica(1:n) > 0
     nlive            = COUNT( alive(1:n) )
     x(1:nlive)       = PACK ( x(1:n),       alive(1:n) )
     v(1:nlive)       = PACK ( v(1:n),       alive(1:n) )
     replica(1:nlive) = PACK ( replica(1:n), alive(1:n) )

     ! Replicate walkers with replica > 1
     n  = nlive
     DO i = 1, nlive
        n_add = replica(i) - 1
        IF ( n_add > 0 ) THEN
           IF ( n + n_add > n_max ) THEN
              WRITE ( unit=error_unit, fmt='(a,3i15)' ) 'n+n_add exceeds n_max', n, n_add, n_max
              STOP 'Error in qmc_walk_sho'
           END IF
           x(n+1:n+n_add) = x(i)
           v(n+1:n+n_add) = v(i)
           n = n + n_add
        END IF
     END DO

     pot = SUM(v(1:n))/REAL(n) ! potential averaged over walkers

     ! Stop if n is too large or too small
     IF ( n < 3 ) THEN
        WRITE ( unit=error_unit, fmt='(a,i15)' ) 'n is too small, increase the value of et', n
        STOP 'Error in qmc_walk_sho'
     ELSE IF (n > (n_max-3) ) THEN
        WRITE ( unit=error_unit, fmt='(a,i15)' ) 'n is too large, decrease the value of et', n
        STOP 'Error in qmc_walk_sho'
     END IF

     ! Periodically write the current number of walkers, trial energy, average potential

     IF( MOD(step,output_interval) == 0 ) THEN
        WRITE ( unit=output_unit, fmt='(i15,i15,2f15.6)') step, n, et, pot
     ENDIF

     ! Calculate the distribution of walkers on the line and energy averages

     IF ( step > equilibration_steps ) THEN

        DO i = 1, n
           ibin = INT( (x(i)+x_max)/dx ) + 1
           IF ( ibin >= 1 .AND. ibin <= n_bin ) THEN
              bin(ibin) = bin(ibin) +  1
           END IF
        END DO

        et_avg     = et_avg     + et
        pot_avg    = pot_avg    + pot
        step_count = step_count + 1

     END IF

     ! Reset trial energy following Kozstin et al (1996)
     et = pot + (1.0-REAL(n)/REAL(n_target))/ds

  ENDDO ! End loop over steps

  ! Normalize the wavefunction so that the integral over psi**2 = 1.0
  psi     = REAL ( bin )         ! un-normalized wave function
  factor  = SUM ( psi**2 ) * dx  ! integral, assuming that -x_max .. +x_max catches everything
  psi     = psi / SQRT( factor ) ! normalizing factor
  et_avg  = et_avg / REAL(step_count)
  pot_avg = pot_avg / REAL(step_count)

  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)') 'Average trial energy = ',     et_avg
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)') 'Average potential energy = ', pot_avg

  ! Print ground state wave function
  WRITE ( unit=output_unit, fmt= '(a)' ) '              x         psi(x)   psi_exact(x)'

  DO i = 1, n_bin
     x_bin  = -x_max + ( REAL(i - 1) + 0.5 ) * dx
     pexact = const * EXP(- 0.5 * x_bin * x_bin)
     WRITE ( unit=output_unit, fmt='(3f15.6)') x_bin, psi(i), pexact
  END DO
  CALL time_stamp

  DEALLOCATE ( x, v, replica, alive, bin, psi )

END PROGRAM qmc_walk_sho


subroutine linsolve(n,nrhs,A,b)
!
!   Copyright 2017, Viktor Reshiak, All rights reserved.
!
!
!   Purpose
!   =======
!   Solve system of linear equations with Gaussian elimination
!
!
!   IN
!   ==
!   1) n    - number of linear equations
!   2) nrhs - number of right hand sides
!   2) A    - matrix
!   3) b    - right hand side
!
!
!   INOUT
!   =====
!   3) b - solution
!
!
	implicit none

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! dummy arguments

    integer(kind=4), intent(in)                       :: n, nrhs
       real(kind=8), intent(in), dimension(n,n)       :: A
       real(kind=8), intent(inout), dimension(n,nrhs) :: b

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    integer(kind=4), dimension(n)  :: ipiv
    integer(kind=4)                :: status

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    call dgesv( n, nrhs, A, n, ipiv, b, n, status )

end subroutine linsolve


      subroutine dnherm3(x,nx,y,ny,z,nz,fherm,nf2,nf3,
     >   ilinx,iliny,ilinz,ier)
C
C  create a data set for Hermite interpolation, based on simple
C  numerical differentiation using the given grid.  The grid should
C  be "approximately" evenly spaced.
C
C  3d routine
C
C  input:
C
C  nf2.get.nx and nf3.ge.ny  expected!
C
      integer nx,ny,nz,nf2,nf3          ! array dimensions
      real x(nx)                        ! x coordinate array
      real y(ny)                        ! y coordinate array
      real z(nz)                        ! z coordinate array
      real fherm(0:7,nf2,nf3,nz)        ! data/Hermite array
C
C  fherm(0,i,j,k) = function value f at x(i),y(j),z(k)  **on input**
C
C  fherm(1,i,j,k) = derivative df/dx at x(i),y(j),z(k)  **on output**
C  fherm(2,i,j,k) = derivative df/dy at x(i),y(j),z(k)  **on output**
C  fherm(3,i,j,k) = derivative df/dz at x(i),y(j),z(k)  **on output**
C  fherm(4,i,j,k) = derivative d2f/dxdy at x(i),y(j),z(k)  **on output**
C  fherm(5,i,j,k) = derivative d2f/dxdz at x(i),y(j),z(k)  **on output**
C  fherm(6,i,j,k) = derivative d2f/dydz at x(i),y(j),z(k)  **on output**
C  fherm(7,i,j,k) = derivative d3f/dxdydz at x(i),y(j),z(k)  **on output**
C
C  additional outputs:
C
C    ilinx = 1  if x is evenly spaced (approximately)
C    iliny = 1  if y is evenly spaced (approximately)
C    ilinz = 1  if z is evenly spaced (approximately)
C
C    ier = 0 if there are no errors
C
C  note possible errors:  x y or z NOT strict ascending
C  nf2.lt.nx   .or.   nf3.lt.ny
C
C----------------------------
C
C
C  error check
C
      ier=0
c
      call splinck(x,nx,ilinx,1.0e-3,ierx)
      if(ierx.ne.0) ier=2
c
      if(ier.eq.2) then
         write(6,'('' ?dnherm3:  x axis not strict ascending'')')
      endif
c
      call splinck(y,ny,iliny,1.0e-3,iery)
      if(iery.ne.0) ier=3
c
      if(ier.eq.3) then
         write(6,'('' ?dnherm3:  y axis not strict ascending'')')
      endif
c
      call splinck(z,nz,ilinz,1.0e-3,ierz)
      if(ierz.ne.0) ier=4
c
      if(ier.eq.4) then
         write(6,'('' ?dnherm3:  z axis not strict ascending'')')
      endif
c
      if(nf2.lt.nx) then
         ier=5
         write(6,*) '?dnherm3:  fherm (x) array dimension too small.'
      endif
c
      if(nf3.lt.ny) then
         ier=6
         write(6,*) '?dnherm3:  fherm (y) array dimension too small.'
      endif
C
      if(ier.ne.0) return
C
C  error check OK
C
      do iz=1,nz
c
         izp=min(nz,iz+1)
         izm=max(1,iz-1)
c
         do iy=1,ny
c
            iyp=min(ny,iy+1)
            iym=max(1,iy-1)
c
            do ix=1,nx
c
               ixp=min(nx,ix+1)
               ixm=max(1,ix-1)
c
c  x diffs in vicinity
c
               zd=(fherm(0,ixp,iy,iz)-fherm(0,ixm,iy,iz))/
     >            (x(ixp)-x(ixm))
c
               fherm(1,ix,iy,iz)=zd
c
c  y diffs in vicinity
c
               zd=(fherm(0,ix,iyp,iz)-fherm(0,ix,iym,iz))/
     >            (y(iyp)-y(iym))
c
               fherm(2,ix,iy,iz)=zd
c
c  z diffs in vicinity
c
               zd=(fherm(0,ix,iy,izp)-fherm(0,ix,iy,izm))/
     >            (z(izp)-z(izm))
c
               fherm(3,ix,iy,iz)=zd
c
c  xy cross derivs
c
               fherm(4,ix,iy,iz)=
     >            (fherm(0,ixp,iyp,iz)-fherm(0,ixm,iyp,iz)
     >            -fherm(0,ixp,iym,iz)+fherm(0,ixm,iym,iz))/
     >            ((x(ixp)-x(ixm))*(y(iyp)-y(iym)))
c
c  xz cross derivs
c
               fherm(5,ix,iy,iz)=
     >            (fherm(0,ixp,iy,izp)-fherm(0,ixm,iy,izp)
     >            -fherm(0,ixp,iy,izm)+fherm(0,ixm,iy,izm))/
     >            ((x(ixp)-x(ixm))*(z(izp)-z(izm)))
c
c  yz cross derivs
c
               fherm(6,ix,iy,iz)=
     >            (fherm(0,ix,iyp,izp)-fherm(0,ix,iym,izp)
     >            -fherm(0,ix,iyp,izm)+fherm(0,ix,iym,izm))/
     >            ((y(iyp)-y(iym))*(z(izp)-z(izm)))
c
c  xyz cross deriv
c
               fherm(7,ix,iy,iz)=
     >            ((fherm(0,ixp,iyp,izp)-fherm(0,ixp,iym,izp)
     >            -fherm(0,ixp,iyp,izm)+fherm(0,ixp,iym,izm))-
     >            (fherm(0,ixm,iyp,izp)-fherm(0,ixm,iym,izp)
     >            -fherm(0,ixm,iyp,izm)+fherm(0,ixm,iym,izm)))/
     >            ((x(ixp)-x(ixm))*(y(iyp)-y(iym))*(z(izp)-z(izm)))
c
            enddo
         enddo
      enddo
C
      return
      end


      function dfapo(tol,rlo,rhi,GMB,AR,GAM,E,L2)
         real*8 tol,rlo,rhi,GMB,AR,GAM,E,L2
         real*8 y0,rm,yy,dfapo
         integer*8 steps

         !TEMP VARS
         !real*8 ri
         !integer*8 i
         !TEMP VARS
         steps=0
         !write(305,*) "Start:", tol, rlo, rhi, GMB, AR, GAM, E, L2

 100     y0=(1/rlo)**2 + 2.0*((-(GMB/AR)*(1.0/(2.0-gam)) *
     &          (1.0- (rlo/(rlo+AR))**(2.0-gam)))    - E)/L2
         rm=(rlo+rhi)/2.d0
         yy=(1/rm)**2 + 2.0*((-(GMB/AR)*(1.0/(2.0-gam)) *
     &          (1.0- (rm/(rm+AR))**(2.0-gam)))    - E)/L2
         steps=steps+1
         !write(305,*) steps
         !write(305,*) rlo, rhi
         !write(305,*) y0, yy, y0*yy
         if (abs(yy*y0).eq.0) goto 101
         if ((yy*y0)<0.d0) then
            rhi=rm
         else if ((yy*y0)>0.d0) then
            rlo=rm
         end if
         !write(305,*) rhi, rlo, rhi-rlo
         if (abs(rhi-rlo)>tol) goto 100
         !write(305,*)
 101     dfapo = rm
      end function


C
C $Id: trn32t.f,v 1.6 2008-07-27 00:17:34 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE TRN32T (U,V,W,XT,YT,ZT,IENT)
C
C THIS ROUTINE IMPLEMENTS THE 3-SPACE TO 2-SPACE TRANSFOR-
C MATION BY KUBER, SZABO AND GIULIERI, THE PERSPECTIVE
C REPRESENTATION OF FUNCTIONS OF TWO VARIABLES. J. ACM 15,
C 2, 193-204,1968.
C TRN32T ARGUMENTS
C U,V,W    ARE THE 3-SPACE COORDINATES OF THE INTERSECTION
C          OF THE LINE OF SIGHT AND THE IMAGE PLANE.  THIS
C          POINT CAN BE THOUGHT OF AS THE POINT LOOKED AT.
C XT,YT,ZT ARE THE 3-SPACE COORDINATES OF THE EYE POSITION.
C
C TRN32 ARGUMENTS
C U,V,W    ARE THE 3-SPACE COORDINATES OF A POINT TO BE
C          TRANSFORMED.
C XT,YT    THE RESULTS OF THE 3-SPACE TO 2-SPACE TRANSFOR-
C          MATION.  WHEN ISCALE=0, XT AND YT ANR IN THE SAME
C          UNITS AS U,V, AND W.  WHEN ISCALE'0, XT AND YT
C          ARE IN PLOTTER COORDINATES.
C ZT       NOT USED.
C
C
      SAVE
C
      COMMON /PWRZ1T/ UUMIN      ,UUMAX      ,VVMIN      ,VVMAX      ,
     1                WWMIN      ,WWMAX      ,DELCRT     ,EYEU       ,
     2                EYEV       ,EYEW
      COMMON /SET31/  ISCALE     ,XMIN       ,XMAX       ,YMIN       ,
     1                YMAX       ,BIGD       ,R0         ,NLX        ,
     2                NBY        ,NRX        ,NTY
C
C DECIDE IF SET OR TRANSLATE CALL
C
      IF (IENT .NE. 1) GO TO  50
C
C STORE THE PARAMETERS OF THE SET CALL
C FOR USE WITH THE TRANSLATION CALL
C
      AU = U
      AV = V
      AW = W
      EU = XT
      EV = YT
      EW = ZT
C
C
C
C
C
      DU = AU-EU
      DV = AV-EV
      DW = AW-EW
      D = SQRT(DU*DU+DV*DV+DW*DW)
      COSAL = DU/D
      COSBE = DV/D
      COSGA = DW/D
      AL = ACOS(COSAL)
      BE = ACOS(COSBE)
      GA = ACOS(COSGA)
      SINGA = SIN(GA)
C
C THE 3-SPACE POINT LOOKED AT IS TRANSFORMED INTO (0,0) OF
C THE 2-SPACE.  THE 3-SPACE W AXIS IS TRANSFORMED INTO THE
C 2-SPACE Y AXIS.  IF THE LINE OF SIGHT IS CLOSE TO PARALLEL
C TO THE 3-SPACE W AXIS, THE 3-SPACE V AXIS IS CHOSEN (IN-
C STEAD OF THE 3-SPACE W AXIS) TO BE TRANSFORMED INTO THE
C 2-SPACE Y AXIS.
C
      JDONE = 2
      IF (ISCALE)  10, 30, 10
   10 X0 = XMIN
      Y0 = YMIN
      X1 = NLX
      Y1 = NBY
      X2 = NRX-NLX
      Y2 = NTY-NBY
      X3 = X2/(XMAX-XMIN)
      Y3 = Y2/(YMAX-YMIN)
      X4 = NRX
      Y4 = NTY
      FACT = 1.
      IF (BIGD .LE. 0.) GO TO  20
      X0 = -BIGD
      Y0 = -BIGD
      X3 = X2/(2.*BIGD)
      Y3 = Y2/(2.*BIGD)
      FACT = R0/D
   20 DELCRT = X2
      JDONE = 1
   30 IF (SINGA .LT. 0.0001) GO TO  40
      R = 1./SINGA
      JUMP = 2
      RETURN
   40 SINBE = SIN(BE)
      R = 1./SINBE
      JUMP = 1
      RETURN
C
C********************  ENTRY TRN32  ************************
C     ENTRY TRN32 (U,V,W,XT,YT,ZT)
C
   50 UU = U
      VV = V
      WW = W
      Q = D/((UU-EU)*COSAL+(VV-EV)*COSBE+(WW-EW)*COSGA)
      GO TO (60, 70), JUMP
   60 UU = ((EW+Q*(WW-EW)-AW)*COSAL-(EU+Q*(UU-EU)-AU)*COSGA)*R
      VV = (EV+Q*(VV-EV)-AV)*R
      GO TO (80, 90), JDONE
   70 UU = ((EU+Q*(UU-EU)-AU)*COSBE-(EV+Q*(VV-EV)-AV)*COSAL)*R
      VV = (EW+Q*(WW-EW)-AW)*R
      GO TO (80, 90), JDONE
   80 XT = X1+X3*(FACT*UU-X0)
      YT = Y1+Y3*(FACT*VV-Y0)
      RETURN
   90 XT = UU
      YT = VV
      RETURN
      END


constant N;

DO t = 1, N

DO j = 2, N
DO i = 1, N
        c(i, j) = c(i, j) - c(i, j - 1) * a(i, j) / b(i, j - 1)
        b(i, j) = b(i, j) - a(i, j) * a(i, j) / b(i, j - 1)
END DO
END DO

DO i = 1, N
c(i, N) = c(i, N) / b(i, N)
END DO

DO j = 1, N-1
DO i = 2, N
c(i, N-j) = ( c(i, N-j) - a(i, N-j + 1) * c(i, N-j + 1) ) / b(i, N-j)
END DO
END DO

DO j = 1, N
DO i = 2, N
c(i, j) = c(i, j) - c(i - 1, j) * a(i, j) / b(i - 1, j)
b(i, j) = b(i, j) - a(i, j) * a(i, j) / b(i - 1, j)
END DO
END DO

DO j = 1, N
c(N, j) = c(N, j) / b(N, j)
END DO

DO j = 1, N
DO i = 1,N-1
c(N-i, j) = ( c(N-i, j) - a(N-i + 1, j) * c(N-i + 1, j) ) / b(N-i, j)
END DO
END DO

END DO


!*******************************************************************
!                                                                  *
      INTEGER FUNCTION IXJTIK (I, J, K, L, M, N)
!                                                                  *
!     CHESKED TRIANGULAR CONDITIONS FOR 6j COEFFICIENT             *
!                                                                  *
!     | I/2  J/2  K/2 |            IXJTIK=1 - IF NOT SATISFY       *
!     | L/2  M/2  N/2 |            IXJTIK=0 - IN OVER CASES        *
!                                                                  *
!   Written by G. Gaigalas,                                        *
!   Vilnius,  Lithuania                             December 1993  *
!   Transform to fortran 90/95 by G. Gaigalas       December 2012  *
!   The last modification made by G. Gaigalas       October  2017  *
!                                                                  *
!*******************************************************************
!
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ittk_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: I, J, K, L, M, N
!-----------------------------------------------
      IXJTIK = 0
      IF (ITTK(I,J,K) == 0) RETURN
      IF (ITTK(I,M,N) == 0) RETURN
      IF (ITTK(L,J,N) == 0) RETURN
      IF (ITTK(L,M,K) == 0) RETURN
      IXJTIK = 1
      RETURN
      END FUNCTION IXJTIK


!-------------------------------------------------------------------------------------------------------------
!< @file	SWCharEst.f90
!<
!< @brief	class SWCharEst:
!<		Estimate values for wilting point, field capacity,
!<		saturated water content, and saturated hydraulic conductivity
!<		from soil texture and organic matter.
!<		Output units are, respectively,
!<		volume fraction, volume fraction, volume fraction, cm/sec.
!<		Uses the equations from Saxton & Rawls, 2006.
!<		Spreadsheet available at:
!<		http://hydrolab.arsusda.gov/soilwater/Index.htm
!<
!< @author	Thomas E. Hilinski <https://github.com/tehilinski>
!< copyright	Copyright 2020 Thomas E. Hilinski. All rights reserved.
!<		This software library, including source code and documentation,
!<		is licensed under the Apache License version 2.0.
!<		See the file "LICENSE.md" for more information.
!-------------------------------------------------------------------------------------------------------------

module SWCharEst
    implicit none

    public  :: Usage, Get
    private :: CheckArgs

    contains

	!< Displays the use of the class.
	subroutine Usage ()

	    print*, "Usage:"
	    print*, "   use SWCharEst"
	    print*, "   Get( sand-fraction, clay-fraction, SOM-percent )"
	    print*, "Arguments:"
	    print*, "   sand-fraction = sand weight fraction *,0-1"
	    print*, "   clay-fraction = clay weight fraction *,0-1"
	    print*, "   SOM-percent   = soil organic matter *,weight %"
	    print*, "Results:"
	    print*, "   WP     = wilting point *,volume %"
	    print*, "   FC     = field capacity *,volume %"
	    print*, "   thetaS = saturated water content *,volume %"
	    print*, "   Ks     = Saturated hydraulic conductivity *,cm/sec"

	end subroutine Usage

	function CheckArgs ( sand, clay, ompc ) result ( ok )

	    real, intent (in) :: sand, clay, ompc
	    logical :: ok

	    ok = .true.
	    if ( sand < 0.0 .or. sand > 1.0 ) then
		ok = .false.
	    end if
	    if ( clay < 0.0 .or. clay > 1.0 ) then
		ok = .false.
	    end if
	    if ( ompc < 0.0 .or. ompc > 70.0 ) then
		ok = .false.
	    end if
	    if ( sand + clay > 1.0 ) then
		ok = .false.
	    end if

	end function CheckArgs

	!< Returns a vector containing WP, FC, thetaS, Ks, in that order.
	!< sand fraction (0-1)
	!< clay fraction (0-1)
	!< organic matter wt %
	function Get ( sand, clay, ompc, DEBUG ) result ( results )

	    real, intent (in) :: sand, clay, ompc
	    logical, intent (in), optional :: DEBUG
	    real :: results(1:4)

	    real :: om, theta1500t, theta1500, theta33t, theta33, &
		    thetaS33t, thetaS33, thetaS, B, lamda, Ks
	    character :: NL =  NEW_LINE('a')

	    results = 0

	    om = min ( 70.0, ompc ) 				! upper limit OM%
	    if ( .not. CheckArgs(sand, clay, om) ) then
		return
	    end if

	    theta1500t = -0.024 * sand + 0.487 * clay + 0.006 * om &
			 + 0.005 * sand * om &
			 - 0.013 * clay * om &
			 + 0.068 * sand * clay &
			 + 0.031

	    theta1500 = max( 0.01, &				! constrain
			     theta1500t + 0.14 * theta1500t - 0.02 )

	    theta33t = -0.251 * sand + 0.195 * clay + 0.011 * om &
		       + 0.006 * sand * om &
		       - 0.027 * clay * om &
		       + 0.452 * sand * clay &
		       + 0.299

	    theta33 = min( &
			0.80, & 					! constrain
			theta33t + 1.283 * theta33t * theta33t - 0.374 * theta33t - 0.015 )

	    theta1500 = min( theta1500, &
			     0.80 * theta33 ) 		! constrain

	    thetaS33t = 0.278 * sand + 0.034 * clay + 0.022 * om &
			- 0.018 * sand * om &
			- 0.027 * clay * om &
			- 0.584 * sand * clay &
			+ 0.078

	    thetaS33 = thetaS33t + 0.636 * thetaS33t - 0.107

	    thetaS = theta33 + thetaS33 - 0.097 * sand + 0.043

	    B = 3.816713 / ( log(theta33) - log(theta1500) )

	    lamda = 1.0 / B

	    Ks = 1930.0 * ( thetaS - theta33 )**( 3.0 - lamda ) / 36000.0

	    if ( present(DEBUG) ) then
		if ( DEBUG ) then
		    print*, "sand, clay, om = ", sand, " ", clay, " ", om, NL, &
			    " theta1500t     = ", theta1500t, NL, &
			    " theta1500      = ", theta1500, NL, &
			    " theta33t       = ", theta33t, NL, &
			    " theta33        = ", theta33, NL, &
			    " thetaS33t      = ", thetaS33t, NL, &
			    " thetaS33       = ", thetaS33, NL, &
			    " thetaS         = ", thetaS, NL, &
			    " B              = ", B, NL, &
			    " lamda          = ", lamda, NL, &
			    " Ks             = ", Ks, NL
		end if
	    end if

	    ! "WP"  "FC"  "thetaS"  "Ks"
	    results = (/ theta1500, theta33, thetaS, Ks  /)

	end function Get

end module SWCharEst


      module bes

      contains
      complex*16 pure function cbesseli(cn,z)
      implicit none
      complex*16 ,intent(in):: cn,z
      cbesseli=(0.d0,1.d0)**cn*cbesselj(cn,dcmplx(imag(z),-dble(z)))
      return
      end

      complex*16 pure function cbesselk(cn,z)
      use macmath
      implicit none
c     Including euler(Euler-Mascheroni constant)/pi symbol
      complex*16 ,intent(in):: cn,z
      cbesselk=-m_pi_2*(0.d0,1.d0)**(1.d0-cn)*(
     $     cbesselj(cn,dcmplx(imag(z),-dble(z)))-
     $     (0.d0,1.d0)*cbessely(cn,dcmplx(imag(z),-dble(z))))
      return
      end

      recursive complex*16 pure function cbessely(cn,z)
     $     result(cb)
      use macmath
      use mathfun
      use gammaf,only:cgamma
      implicit none
c     Including m_pi_2 symbol
      integer*4 i,itmax,m
      parameter (itmax=26)
      complex*16 ,intent(in):: cn,z
      complex*16 cg1,cg2,cgamm1,cgamm2,ca3,
     $     cnf,cp,cq,cr,cs0,cs1,zp,cx,cxp,csigma,
     $     ca1,ca2,cf,cg,cf1,cf2,clogz,zhi,cnfpi,cs,cb2(2)
      real*8 az,xcn,an0,anf,acnf,ak,by,c,s,bj
      if(imag(cn) .eq. 0.d0 .and. imag(z) .eq. 0.d0)then
        if(dble(z) .ge. 0.d0)then
          cb=dcmplx(rrbessely(dble(cn),dble(z)),0.d0)
        else
          by=rrbessely(dble(cn),-dble(z))
          bj=rrbesselj(dble(cn),-dble(z))
          c=cos(m_pi*dble(cn))
          s=sin(m_pi*dble(cn))
          cb=dcmplx(c*by,2.d0*c*bj-s*by)
        endif
        return
      endif
      az=abs(z)
      if(az .gt. 12.2d0)then
        cb2=cbesasym(cn,z)
        cb=cb2(2)
      else
        xcn=dble(cn)
        if(xcn .lt. 0.d0)then
          cb=-sin(m_pi*cn)*cbesselj(-cn,z)+
     $         cos(m_pi*cn)*cbessely(-cn,z)
        else
          an0=aint(xcn)
          anf=xcn-an0
          if(anf .gt. .5d0)then
            anf=anf-1.d0
            an0=an0+1.d0
          endif
          cnf=dcmplx(anf,imag(cn))
          acnf=abs(cnf)
          zhi=2.d0/z
          clogz=log(zhi)
          if(acnf .eq. 0.d0)then
            zp=1.d0
            cp=1.d0/m_pi
            cq=1.d0/m_pi
            cg1=-euler
            cg2=1.d0
            ca1=1.d0
            ca2=1.d0
            ca3=1.d0
            cr=0.d0
          else
            zp=exp(cnf*clogz)
            cgamm1=cgamma(1.d0+cnf)
            cgamm2=cgamma(1.d0-cnf)
            cp=cgamm1*zp/m_pi
            cq=cgamm2/zp/m_pi
            cnfpi=cnf*m_pi
            cr=2.d0/cnf*sin(cnfpi*.5d0)**2
            if(acnf .lt. 1.d-3)then
              cg1=(-euler+cnf**2*(0.042002635034095236d0+
     $             0.042197734555544337d0*cnf**2))
            else
              cg1=(1.d0/cgamm2-1.d0/cgamm1)*.5d0/cnf
            endif
            ca1=cnfpi/sin(cnfpi)
            csigma=cnf*clogz
            if(csigma .eq. (0.d0,0.d0))then
              ca2=(1.d0,0.d0)
            else
              ca2=tcsinh(csigma)/csigma
            endif
            ca3=tccosh(csigma)
            cg2=.5d0*(1.d0/cgamm2+1.d0/cgamm1)
          endif
          cf=2.d0/m_pi*ca1*(ca3*cg1+ca2*clogz*cg2)
          cs0=cf+cr*cq
          cs1=cp
          ak=0.d0
          cx=-(z*.5d0)**2
          cxp=1.d0
          m=min(itmax,max(int(az*2.3d0),10))
          do i=1,m
            ak=ak+1.d0
            cxp=cxp*cx/ak
            cf1=1.d0/(ak-cnf)
            cf2=1.d0/(ak+cnf)
            cf=(ak*cf+cp+cq)*cf1*cf2
            cp=cp*cf1
            cq=cq*cf2
            cg=cf+cr*cq
            cs0=cs0+cxp*cg
            cs1=cs1+cxp*(cp-ak*cg)
          enddo
          if(an0 .eq. 0.d0)then
            cb=-cs0
          elseif(an0 .eq. 1.d0)then
            cb=-cs1*zhi
          else
            cs0=-cs0
            cs1=-cs1*zhi
            do i=1,int(an0)-1
              cnf=cnf+1.d0
              cs=cnf*zhi*cs1-cs0
              cs0=cs1
              cs1=cs
            enddo
            cb=cs1
          endif
        endif
      endif
      return
      end

      recursive real*8 pure function rrbessely(cn,z)
     $     result(cb)
      use macmath
      use mathfun
      implicit none
c     Including m_pi_2 symbol
      integer*4 i,itmax,m
      parameter (itmax=26)
      real*8 ,intent(in):: cn,z
      real*8 cg1,cg2,cgamm1,cgamm2,ca3,
     $     cp,cq,cr,cs0,cs1,zp,cx,cxp,csigma,cx2(2),
     $     ca1,ca2,cf,cg,cf1,cf2,clogz,zhi,anfpi,cs
      real*8 az,an0,anf,aanf,ak
      az=abs(z)
      if(az .gt. 12.2d0)then
        cx2=rrbesasym(cn,z)
        cb=cx2(2)
      else
        if(cn .lt. 0.d0)then
          cb=-sin(m_pi*cn)*rrbesselj(-cn,z)+
     $         cos(m_pi*cn)*rrbessely(-cn,z)
        else
          an0=aint(cn)
          anf=cn-an0
          if(anf .gt. .5d0)then
            anf=anf-1.d0
            an0=an0+1.d0
          endif
          aanf=abs(anf)
          zhi=2.d0/z
          clogz=log(zhi)
          if(aanf .eq. 0.d0)then
            zp=1.d0
            cp=1.d0/m_pi
            cq=1.d0/m_pi
            cg1=-euler
            cg2=1.d0
            ca1=1.d0
            ca2=1.d0
            ca3=1.d0
            cr=0.d0
          else
            zp=exp(anf*clogz)
            cgamm1=gamma(1.d0+anf)
            cgamm2=gamma(1.d0-anf)
            cp=cgamm1*zp/m_pi
            cq=cgamm2/zp/m_pi
            anfpi=anf*m_pi
            cr=2.d0/anf*sin(anfpi*.5d0)**2
            if(aanf .lt. 1.d-3)then
              cg1=(-euler+anf**2*(0.042002635034095236d0+
     $             0.042197734555544337d0*anf**2))
            else
              cg1=(1.d0/cgamm2-1.d0/cgamm1)*.5d0/anf
            endif
            ca1=anfpi/sin(anfpi)
            csigma=anf*clogz
            if(csigma .eq. 0.d0)then
              ca2=1.d0
            else
              ca2=sinh(csigma)/csigma
            endif
            ca3=cosh(csigma)
            cg2=.5d0*(1.d0/cgamm2+1.d0/cgamm1)
          endif
          cf=2.d0/m_pi*ca1*(ca3*cg1+ca2*clogz*cg2)
          cs0=cf+cr*cq
          cs1=cp
          ak=0.d0
          cx=-(z*.5d0)**2
          cxp=1.d0
          m=min(itmax,max(int(az*2.3d0),10))
          do i=1,m
            ak=ak+1.d0
            cxp=cxp*cx/ak
            cf1=1.d0/(ak-anf)
            cf2=1.d0/(ak+anf)
            cf=(ak*cf+cp+cq)*cf1*cf2
            cp=cp*cf1
            cq=cq*cf2
            cg=cf+cr*cq
            cs0=cs0+cxp*cg
            cs1=cs1+cxp*(cp-ak*cg)
          enddo
          if(an0 .eq. 0.d0)then
            cb=-cs0
          elseif(an0 .eq. 1.d0)then
            cb=-cs1*zhi
          else
            cs0=-cs0
            cs1=-cs1*zhi
            do i=1,int(an0)-1
              anf=anf+1.d0
              cs=anf*zhi*cs1-cs0
              cs0=cs1
              cs1=cs
            enddo
            cb=cs1
          endif
        endif
      endif
      return
      end

      recursive complex*16 pure function cbesselj(cn,z)
     $     result(cb)
      use gammaf
      implicit none
      integer*4 nmax,i
      complex*16 ,intent(in):: cn,z
      complex*16 cj,cj1,cj2,cs,zi,cnk,cn2k,cg,cb2(2)
      real*8 az,acn,an,ak,xcn
      if(imag(cn) .eq. 0.d0 .and. imag(z) .eq. 0.d0)then
        if(dble(z) .ge. 0.d0)then
          cb=dcmplx(rrbesselj(dble(cn),dble(z)),0.d0)
        else
          cb=rrbesselj(dble(cn),-dble(z))*dcmplx(-1.d0,0.d0)**dble(cn)
        endif
        return
      endif
c     Initialization to avoid compiler warning
      nmax=0
c
      az=abs(z)
      acn=abs(cn)
      if(az .gt. acn*.25d0+20.d0)then
        cb2=cbesasym(cn,z)
        cb=cb2(1)
      else
        if(az .ne. 0.d0)then
          nmax=int(max(1.d0,20.d0/max(log10(2.d0/az),1.d0),
     $         2.d0*az-dble(cn)))
        endif
        if(cn .eq. (0.d0,0.d0))then
          if(az .eq. 0.d0)then
            cb=1.d0
          else
            cs=1.d-100
            cj2=0.d0
            cj1=1.d-100
            an=nmax*2
            zi=2.d0/z
            do i=2,nmax
              cj2=an*cj1*zi-cj2
              cj1=(an-1.d0)*zi*cj2-cj1
              an=an-2.d0
              cs=cs+cj1
            enddo
            cj=zi*(2.d0*zi*cj1-cj2)-cj1
            cb=cj/(cs*2.d0+cj)
          endif
        else
          xcn=dble(cn)
          if(xcn .lt. 0.d0 .and. cn .eq. anint(xcn))then
            if(mod(-xcn,2.d0) .eq. 0.d0)then
              cb=cbesselj(-cn,z)
            else
              cb=-cbesselj(-cn,z)
            endif
          elseif(az .eq. 0.d0)then
            cb=0.d0
          else
            cj2=0.d0
            cj1=1.d-100
            ak=dble(nmax)
            cnk=cn+ak
            cn2k=cnk+ak
            cg=exp(cloggamma1(cnk)-aloggamma1(ak))/cnk
c            cg=cgamma(cnk)/factorial(ak)
            cs=cn2k*cg*cj1
            zi=2.d0/z
            do i=1,nmax
              cj2=cn2k*cj1*zi-cj2
              cj1=(cn2k-1.d0)*zi*cj2-cj1
              cn2k=cn2k-2.d0
              cnk=cnk-1.d0
              cg=ak*cg/cnk
              ak=ak-1.d0
              cs=cs+cj1*cn2k*cg
            enddo
            cb=cj1*(.5d0*z)**cn/cs
          endif
        endif
      endif
      return
      end

      complex*16 pure function cbesasym(cn,z) result(cx)
      use macmath
      implicit none
c     Including m_pi_2/m_pi_4/m_2_pi symbol
      dimension cx(2)
      complex*16 ,intent(in):: cn,z
      complex*16 cp,cq,cmu,z1,chi,csqrtz,ccoschi,csinchi
      cmu=4.d0*cn**2
      z1=1.d0/64.d0/z**2
      cp=1.d0-(cmu-1.d0)*(cmu-9.d0)*z1/2.d0*
     $     (1.d0-(cmu-25.d0)*(cmu-49.d0)*z1/12.d0*
     $     (1.d0-(cmu-81.d0)*(cmu-121.d0)*z1/30.d0*
     $     (1.d0-(cmu-169.d0)*(cmu-225.d0)*z1/56.d0*
     $     (1.d0-(cmu-289.d0)*(cmu-361.d0)*z1/90.d0*
     $     (1.d0-(cmu-441.d0)*(cmu-529.d0)*z1/132.d0*
     $     (1.d0-(cmu-25.d0**2)*(cmu-27.d0**2)*z1/(13.d0*14.d0)*
     $     (1.d0-(cmu-29.d0**2)*(cmu-31.d0**2)*z1/(15.d0*16.d0)*
     $     (1.d0-(cmu-33.d0**2)*(cmu-35.d0**2)*z1/(17.d0*18.d0)*
     $     (1.d0-(cmu-37.d0**2)*(cmu-39.d0**2)*z1/(19.d0*20.d0)*
     $     (1.d0-(cmu-41.d0**2)*(cmu-43.d0**2)*z1/(21.d0*22.d0)*
     $     (1.d0-(cmu-45.d0**2)*(cmu-47.d0**2)*z1/(23.d0*24.d0)
     $     )))))))))))
      cq=(cmu-1.d0)/8.d0/z*
     $     (1.d0-(cmu-9.d0)*(cmu-25.d0)*z1/6.d0*
     $     (1.d0-(cmu-49.d0)*(cmu-81.d0)*z1/20.d0*
     $     (1.d0-(cmu-121.d0)*(cmu-169.d0)*z1/42.d0*
     $     (1.d0-(cmu-225.d0)*(cmu-289.d0)*z1/72.d0*
     $     (1.d0-(cmu-361.d0)*(cmu-441.d0)*z1/110.d0*
     $     (1.d0-(cmu-23.d0**2)*(cmu-25.d0**2)*z1/(12.d0*13.d0)*
     $     (1.d0-(cmu-27.d0**2)*(cmu-29.d0**2)*z1/(14.d0*15.d0)*
     $     (1.d0-(cmu-31.d0**2)*(cmu-33.d0**2)*z1/(16.d0*17.d0)*
     $     (1.d0-(cmu-35.d0**2)*(cmu-37.d0**2)*z1/(18.d0*19.d0)*
     $     (1.d0-(cmu-39.d0**2)*(cmu-41.d0**2)*z1/(20.d0*21.d0)*
     $     (1.d0-(cmu-43.d0**2)*(cmu-45.d0**2)*z1/(22.d0*23.d0)
     $     )))))))))))
      chi=z-cn*m_pi_2-m_pi_4
      ccoschi=cos(chi)
      csinchi=sin(chi)
      csqrtz=sqrt(m_2_pi/z)
      cx=csqrtz*[cp*ccoschi-cq*csinchi,cp*csinchi+cq*ccoschi]
      return
      end

      recursive real*8 pure function rrbesselj(cn,z)
     $     result(cb)
      use gammaf
      implicit none
      integer*4 nmax,i
      real*8 ,intent(in):: cn,z
      real*8 cj,cj1,cj2,cs,zi,cnk,cn2k,cg,az,acn,an,ak,cx(2)
c     Initialization to avoid compiler warning
      nmax=0
c
      az=abs(z)
      acn=abs(cn)
      if(az .gt. acn*.25d0+20.d0)then
        cx=rrbesasym(cn,z)
        cb=cx(1)
      else
        if(az .ne. 0.d0)then
          nmax=int(max(1.d0,20.d0/max(log10(2.d0/az),1.d0),
     $         2.d0*az-dble(cn)))
        endif
        if(cn .eq. 0.d0)then
          if(az .eq. 0.d0)then
            cb=1.d0
          else
            cs=1.d-100
            cj2=0.d0
            cj1=1.d-100
            an=nmax*2
            zi=2.d0/z
            do i=2,nmax
              cj2=an*cj1*zi-cj2
              cj1=(an-1.d0)*zi*cj2-cj1
              an=an-2.d0
              cs=cs+cj1
            enddo
            cj=zi*(2.d0*zi*cj1-cj2)-cj1
            cb=cj/(cs*2.d0+cj)
          endif
        else
          if(cn .lt. 0.d0 .and. cn .eq. anint(cn))then
            if(mod(-cn,2.d0) .eq. 0.d0)then
              cb=rrbesselj(-cn,z)
            else
              cb=-rrbesselj(-cn,z)
            endif
          elseif(az .eq. 0.d0)then
            cb=0.d0
          else
            cj2=0.d0
            cj1=1.d-100
            ak=dble(nmax)
            cnk=cn+ak
            cn2k=cnk+ak
            cg=exp(aloggamma1(cnk)-aloggamma1(ak))/cnk
c            cg=cgamma(cnk)/factorial(ak)
            cs=cn2k*cg*cj1
            zi=2.d0/z
            do i=1,nmax
              cj2=cn2k*cj1*zi-cj2
              cj1=(cn2k-1.d0)*zi*cj2-cj1
              cn2k=cn2k-2.d0
              cnk=cnk-1.d0
              cg=ak*cg/cnk
              ak=ak-1.d0
              cs=cs+cj1*cn2k*cg
            enddo
            cb=cj1*(.5d0*z)**cn/cs
          endif
        endif
      endif
      return
      end

      real*8 pure function rrbesasym(cn,z) result(cx)
      use macmath
      implicit none
c     Including m_pi_2/m_pi_4/m_2_pi symbol
      dimension cx(2)
      real*8 ,intent(in):: cn,z
      real*8 cp,cq,z1,chi,csqrtz,ccoschi,csinchi,cmu
      cmu=4.d0*cn**2
      z1=1.d0/64.d0/z**2
      cp=1.d0-(cmu-1.d0)*(cmu-9.d0)*z1/2.d0*
     $     (1.d0-(cmu-25.d0)*(cmu-49.d0)*z1/12.d0*
     $     (1.d0-(cmu-81.d0)*(cmu-121.d0)*z1/30.d0*
     $     (1.d0-(cmu-169.d0)*(cmu-225.d0)*z1/56.d0*
     $     (1.d0-(cmu-289.d0)*(cmu-361.d0)*z1/90.d0*
     $     (1.d0-(cmu-441.d0)*(cmu-529.d0)*z1/132.d0*
     $     (1.d0-(cmu-25.d0**2)*(cmu-27.d0**2)*z1/(13.d0*14.d0)*
     $     (1.d0-(cmu-29.d0**2)*(cmu-31.d0**2)*z1/(15.d0*16.d0)*
     $     (1.d0-(cmu-33.d0**2)*(cmu-35.d0**2)*z1/(17.d0*18.d0)*
     $     (1.d0-(cmu-37.d0**2)*(cmu-39.d0**2)*z1/(19.d0*20.d0)*
     $     (1.d0-(cmu-41.d0**2)*(cmu-43.d0**2)*z1/(21.d0*22.d0)*
     $     (1.d0-(cmu-45.d0**2)*(cmu-47.d0**2)*z1/(23.d0*24.d0)
     $     )))))))))))
      cq=(cmu-1.d0)/8.d0/z*
     $     (1.d0-(cmu-9.d0)*(cmu-25.d0)*z1/6.d0*
     $     (1.d0-(cmu-49.d0)*(cmu-81.d0)*z1/20.d0*
     $     (1.d0-(cmu-121.d0)*(cmu-169.d0)*z1/42.d0*
     $     (1.d0-(cmu-225.d0)*(cmu-289.d0)*z1/72.d0*
     $     (1.d0-(cmu-361.d0)*(cmu-441.d0)*z1/110.d0*
     $     (1.d0-(cmu-23.d0**2)*(cmu-25.d0**2)*z1/(12.d0*13.d0)*
     $     (1.d0-(cmu-27.d0**2)*(cmu-29.d0**2)*z1/(14.d0*15.d0)*
     $     (1.d0-(cmu-31.d0**2)*(cmu-33.d0**2)*z1/(16.d0*17.d0)*
     $     (1.d0-(cmu-35.d0**2)*(cmu-37.d0**2)*z1/(18.d0*19.d0)*
     $     (1.d0-(cmu-39.d0**2)*(cmu-41.d0**2)*z1/(20.d0*21.d0)*
     $     (1.d0-(cmu-43.d0**2)*(cmu-45.d0**2)*z1/(22.d0*23.d0)
     $     )))))))))))
      chi=z-cn*m_pi_2-m_pi_4
      ccoschi=cos(chi)
      csinchi=sin(chi)
      csqrtz=sqrt(m_2_pi/z)
      cx=csqrtz*[cp*ccoschi-cq*csinchi,cp*csinchi+cq*ccoschi]
      return
      end

      end module


      double complex function qlI1(m1,mu2,ep)
      implicit none
      include 'qlconstants.f'
      double precision m1,mu2
      integer ep
C     m1=m(i)^2 is the square of the mass of the propagator 1
C     mu2 is the square of the scale mu
C     ep=-2,-1,0 chooses the appropriate coefficienrt in the Laurent series.
      double precision m1o,mu2o
      logical qlzero
      double complex Ival(-2:0)
      data m1o/0d0/
      save Ival,m1o,mu2o

      if (mu2 .le. 0d0) then
      write(6,*) 'stopping because mu2 .le. 0d0 in qlI1, mu2=',mu2
      write(6,*) 'Rerun with positive mu2'
      stop
      endif

C--If we have already calculated, use the saved value
C--else setup the arrays
      if ((m1 .eq. m1o) .and. (mu2 .eq. mu2o)) then
         qlI1=Ival(ep)
         return
      else
         Ival(-2)=czip
         Ival(-1)=czip
         Ival(0)=czip
         if (qlzero(m1)) then
              qlI1=Ival(ep)
         else
              Ival(-1)=dcmplx(m1)
	      Ival( 0)=Ival(-1)*dcmplx(log(mu2/m1)+1d0)
              qlI1=Ival(ep)
         endif
      m1o=m1
      mu2o=mu2
      endif
      return
      end


c****************************************************************
      subroutine svdvecfit(i_mp,i_rd,i_fp,r_vecin,r_vobs,r_cov,
     +     i_np,r_a,r_at2,r_u,r_v,r_w,r_chisq,l_chisq)

c****************************************************************
c**
c**   FILE NAME: svdvecfit.f
c**
c**   DATE WRITTEN: 01/02/95
c**
c**   PROGRAMMER: Scott Hensley
c**
c**   FUNCTIONAL DESCRIPTION: This routine does a least squares fit
c**   to a vector valued observation least squares problem.
c**
c**   ROUTINES CALLED: gaussj,svbksb,svdcmp,funcs
c**
c**   NOTES: funcs is a user supplied function giving the jacobian
c**   of the observation parameters wrt to fit parameters. This routine
c**   is a generalization of Numerical Recipes svdfit. Note that this
c**   routine can also be used in a nonlinear least squares procedure
c**   by iterating properly.
c**
c**   Solves the least problem
c**
c**             T   -1     -1     T   -1
c**    A = (AMAT COV  AMAT)  (AMAT COV  )VOBS
c**
c**    where AMAT is the jacobain of the observations vs parameters,
c**    COV is the covriance matrix of observations
c**    and VOBS is the vector of observations.
c**
c**    r_a should be passed in with current best estimate of values
c**
c**   UPDATE LOG:
c**
c**  4/17/95 - Reversed order of r_vecin, r_vobs, and r_cov    SJS
c**            revmoved r_vt, cleaned up parameter list
c**
c*****************************************************************

      implicit none

c     PARAMETERS:
      integer I_NPE                  !number of parameters to estimate = i_np
      integer I_RDE                  !number of observations per point = i_rd
      real*8 R_TOL,R_LAMBDA
      parameter(I_NPE=7)
      parameter(I_RDE=2)
      parameter(R_TOL=1.0d-20)
      parameter (R_LAMBDA=1.d0)

c     INPUT VARIABLES:
      integer i_mp                   !number of input points
      integer i_rd                   !number of observations each point
      integer i_fp                   !number of input parameters to func
      integer i_np                   !number of parameters to solve for

      real*8  r_vecin(i_fp,i_mp) 	 !vector values for func
      real*8  r_vobs(i_rd,i_mp) 	 !vector of observations
      real*8  r_cov(i_rd,i_rd,i_mp)  !covariance matrix of observation
      real*8  r_chisq(i_rd,0:i_mp) 	 !chisq for solution and fit vs observation
      real*8  r_a(i_np)   			 !solution to least squares
                                     !for each point
      logical l_chisq                !evaluate the chisq for this fit

c     OUTPUT VARIABLES:
      real*8 r_at2(i_np)             !delta to add to previous solution
      real*8 r_u(i_np,i_np)          !svd matrix, orthogonal matrix
      real*8 r_v(i_np,i_np)          !svd matrix, orthogonal matrix
      real*8 r_w(i_np)               !svd matrix, diagonal matrix

c     LOCAL VARIABLES:
      integer i,j,k,i_pts
      real*8  r_covtemp(I_RDE,I_RDE)
      real*8  r_am(I_NPE,I_RDE)
      real*8  r_amat(I_RDE,I_NPE)
      real*8  r_ptot(I_NPE)
      real*8  r_wmax,r_thres,r_b(I_RDE,1),r_chird(I_RDE)

      integer i_paramest(I_NPE),i_usedata(I_RDE)
      common/funcom3/i_paramest,i_usedata

c     DATA STATEMENTS:

C     FUNCTION STATEMENTS:

c     PROCESSING STEPS:

c     init some arrays

c      write(*,*)  ' '
c      write(*,*)  'Inside SVDVECFIT'
c      write(*,*)  ' '

      if (i_rd .ne. I_RDE) then
         write(*,*) 'ERROR - i_rd not equal to I_RDE in SVDVECFIT'
         stop
      end if
      if (i_np .ne. I_NPE) then
         write(*,*) 'ERROR - i_np not equal to I_NPE in SVDVECFIT'
         stop
      end if

      do i=1,i_np
         do j=1,i_np
            r_u(i,j) = 0.0
         enddo
         r_ptot(i) = 0.0
      enddo

c     loop over the input points

      do i_pts=1,i_mp

c         write(*,*)  'i_pts = ',i_pts

c     invert the covariance matrix of the observation

         do i=1,i_rd
            do j=1,i_rd
               r_covtemp(i,j) = r_cov(i,j,i_pts)
            enddo
         enddo

         call gaussj(r_covtemp,i_rd,i_rd,r_b,1,1)

c     get the required jacobian matrix

         call poly_funcs(i_pts,i_rd,i_fp,r_vecin(1,i_pts),i_np,r_a,r_amat)

c         do i=1,i_rd
c            do j=1,i_np
c               write(*,*)  'i,j,r_amat = ',i,j,r_amat(i,j)
c            enddo
c         enddo

c     multiply amat transpose by the inverse cov matrix

         do i=1,i_np
            do j=1,i_rd
               r_am(i,j) = 0.0
               do k=1,i_rd
                  r_am(i,j) = r_am(i,j) + r_amat(k,i)*r_covtemp(k,j)
               enddo
            enddo
         enddo

c         do i=1,i_np
c            do j=1,i_rd
c               write(*,*)  'i,j,r_am = ',i,j,r_am(i,j)
c            enddo
c         enddo

c     multiply am by amat

         do i=1,i_np
            do j=1,i_np
               do k=1,i_rd
                  r_u(i,j) = r_u(i,j) + r_am(i,k)*r_amat(k,j)
               enddo
            enddo
         enddo

c     multilpy am by vobs

c         write(*,*)  'r_vobs,i_pts = ',i_pts,r_vobs(1,i_pts),r_vobs(2,i_pts)
         do i=1,i_np
            do k=1,i_rd
               r_ptot(i) = r_ptot(i) + r_am(i,k)*r_vobs(k,i_pts)
            enddo
         enddo

      enddo   !i_pts

c     find the SVD of the r_u matrix

c         do i=1,i_np
c            do j=1,i_np
c               write(*,*)  'i,j,r_u = ',i,j,r_u(i,j)
c            enddo
c         enddo

      call svdcmp(r_u,i_np,i_np,i_np,i_np,r_w,r_v)

c         do i=1,i_np
c            do j=1,i_np
c               write(*,*)  'i,j,r_u,r_v = ',i,j,r_u(i,j),r_v(i,j)
c            enddo
c         enddo

c         do i=1,i_np
c            write(*,*)  'w = ',i,r_w(i)
c         enddo

c     kill off all the singular values

      r_wmax = 0.0
      do i=1,i_np
         if(r_w(i) .gt. r_wmax)then
            r_wmax = r_w(i)
         endif
      enddo
      r_thres = r_wmax*R_TOL
c      write(*,*)  'r_thres = ',r_thres

      do i=1,i_np
         if(r_w(i) .lt. r_thres)then
            r_w(i) = 0.0
         endif
      enddo

c      do i=1,i_np
c         write(*,*)  'w = ',i,r_w(i)
c      enddo

c     use the svbksb routine to solve for the desired parameters

      call svbksb(r_u,r_w,r_v,i_np,i_np,i_np,i_np,r_ptot,r_at2)

c     update the r_a vector

      do i=1,i_np
         r_at2(i) = -r_at2(i)*i_paramest(i)
         r_a(i) = r_at2(i)/R_LAMBDA + r_a(i)
c         write(*,*) 'a=',i,r_a(i),r_at2(i)
      enddo

c     evaluate the chisq array (linearized version)

      if(l_chisq)then

c     loop over data points

         do i=1,i_rd
            r_chird(i) = 0.
         enddo
         r_chisq(1,0) = 0.0
         do i=1,i_mp

            call poly_funcs(i,i_rd,i_fp,r_vecin(1,i),i_np,r_a,r_amat)

            do j=1,i_rd
               r_chisq(j,i) = 0.0
               do k=1,i_np
                  r_chisq(j,i) = r_chisq(j,i) + r_amat(j,k)*r_at2(k)
               enddo
c               write(*,*)  'r_chisq = ',i,j,r_chisq(j,i),r_vobs(j,i)
               r_chisq(j,i) = r_covtemp(j,j)*(r_chisq(j,i) -
     +              r_vobs(j,i))**2
               r_chisq(1,0) = r_chisq(1,0) + r_chisq(j,i)
               r_chird(j) = r_chird(j) + r_chisq(j,i)
            enddo

         enddo                  !i_pts loop for chisq

         r_chisq(1,0) = sqrt(r_chisq(1,0)/(2.*i_mp))
         write(*,*)  'r_chisq = ',r_chisq(1,0),sqrt(r_chird(1)/i_mp),sqrt(r_chird(2)/i_mp)

      endif

      end

c******************************************************************************

      SUBROUTINE gaussj(a,n,np,b,m,mp)
      INTEGER m,mp,n,np,NMAX
      REAL*8 a(np,np),b(np,mp)
      PARAMETER (NMAX=50)
      INTEGER i,icol,irow,j,k,l,ll,indxc(NMAX),indxr(NMAX),ipiv(NMAX)
      REAL*8 big,dum,pivinv
      do 11 j=1,n
        ipiv(j)=0
11    continue
      do 22 i=1,n
        big=0.
        do 13 j=1,n
          if(ipiv(j).ne.1)then
            do 12 k=1,n
              if (ipiv(k).eq.0) then
                if (abs(a(j,k)).ge.big)then
                  big=abs(a(j,k))
                  irow=j
                  icol=k
                endif
              else if (ipiv(k).gt.1) then
                print *, 'singular matrix in gaussj'
                stop
              endif
12          continue
          endif
13      continue
        ipiv(icol)=ipiv(icol)+1
        if (irow.ne.icol) then
          do 14 l=1,n
            dum=a(irow,l)
            a(irow,l)=a(icol,l)
            a(icol,l)=dum
14        continue
          do 15 l=1,m
            dum=b(irow,l)
            b(irow,l)=b(icol,l)
            b(icol,l)=dum
15        continue
        endif
        indxr(i)=irow
        indxc(i)=icol
        if (a(icol,icol).eq.0.) then
           print *,'singular matrix in gaussj'
           stop
        end if
        pivinv=1./a(icol,icol)
        a(icol,icol)=1.
        do 16 l=1,n
          a(icol,l)=a(icol,l)*pivinv
16      continue
        do 17 l=1,m
          b(icol,l)=b(icol,l)*pivinv
17      continue
        do 21 ll=1,n
          if(ll.ne.icol)then
            dum=a(ll,icol)
            a(ll,icol)=0.
            do 18 l=1,n
              a(ll,l)=a(ll,l)-a(icol,l)*dum
18          continue
            do 19 l=1,m
              b(ll,l)=b(ll,l)-b(icol,l)*dum
19          continue
          endif
21      continue
22    continue
      do 24 l=n,1,-1
        if(indxr(l).ne.indxc(l))then
          do 23 k=1,n
            dum=a(k,indxr(l))
            a(k,indxr(l))=a(k,indxc(l))
            a(k,indxc(l))=dum
23        continue
        endif
24    continue
      return
      END

      SUBROUTINE svdcmp(a,m,n,mp,np,w,v)
      INTEGER m,mp,n,np,NMAX
      REAL*8 a(mp,np),v(np,np),w(np)
      PARAMETER (NMAX=500)
      INTEGER i,its,j,jj,k,l,nm
      REAL*8 anorm,c,f,g,h,s,scale,x,y,z,rv1(NMAX),pythag
      real*8 r_one

      g=0.0
      r_one = 1.d0
      scale=0.0
      anorm=0.0
      do 25 i=1,n
        l=i+1
        rv1(i)=scale*g
        g=0.0
        s=0.0
        scale=0.0
        if(i.le.m)then
          do 11 k=i,m
            scale=scale+abs(a(k,i))
11        continue
          if(scale.ne.0.0)then
            do 12 k=i,m
              a(k,i)=a(k,i)/scale
              s=s+a(k,i)*a(k,i)
12          continue
            f=a(i,i)
            g=-sign(sqrt(s),f)
            h=f*g-s
            a(i,i)=f-g
            do 15 j=l,n
              s=0.0
              do 13 k=i,m
                s=s+a(k,i)*a(k,j)
13            continue
              f=s/h
              do 14 k=i,m
                a(k,j)=a(k,j)+f*a(k,i)
14            continue
15          continue
            do 16 k=i,m
              a(k,i)=scale*a(k,i)
16          continue
          endif
        endif
        w(i)=scale *g
        g=0.0
        s=0.0
        scale=0.0
        if((i.le.m).and.(i.ne.n))then
          do 17 k=l,n
            scale=scale+abs(a(i,k))
17        continue
          if(scale.ne.0.0)then
            do 18 k=l,n
              a(i,k)=a(i,k)/scale
              s=s+a(i,k)*a(i,k)
18          continue
            f=a(i,l)
            g=-sign(sqrt(s),f)
            h=f*g-s
            a(i,l)=f-g
            do 19 k=l,n
              rv1(k)=a(i,k)/h
19          continue
            do 23 j=l,m
              s=0.0
              do 21 k=l,n
                s=s+a(j,k)*a(i,k)
21            continue
              do 22 k=l,n
                a(j,k)=a(j,k)+s*rv1(k)
22            continue
23          continue
            do 24 k=l,n
              a(i,k)=scale*a(i,k)
24          continue
          endif
        endif
        anorm=max(anorm,(abs(w(i))+abs(rv1(i))))
25    continue
      do 32 i=n,1,-1
        if(i.lt.n)then
          if(g.ne.0.0)then
            do 26 j=l,n
              v(j,i)=(a(i,j)/a(i,l))/g
26          continue
            do 29 j=l,n
              s=0.0
              do 27 k=l,n
                s=s+a(i,k)*v(k,j)
27            continue
              do 28 k=l,n
                v(k,j)=v(k,j)+s*v(k,i)
28            continue
29          continue
          endif
          do 31 j=l,n
            v(i,j)=0.0
            v(j,i)=0.0
31        continue
        endif
        v(i,i)=1.0
        g=rv1(i)
        l=i
32    continue
      do 39 i=min(m,n),1,-1
        l=i+1
        g=w(i)
        do 33 j=l,n
          a(i,j)=0.0
33      continue
        if(g.ne.0.0)then
          g=1.0/g
          do 36 j=l,n
            s=0.0
            do 34 k=l,m
              s=s+a(k,i)*a(k,j)
34          continue
            f=(s/a(i,i))*g
            do 35 k=i,m
              a(k,j)=a(k,j)+f*a(k,i)
35          continue
36        continue
          do 37 j=i,m
            a(j,i)=a(j,i)*g
37        continue
        else
          do 38 j= i,m
            a(j,i)=0.0
38        continue
        endif
        a(i,i)=a(i,i)+1.0
39    continue
      do 49 k=n,1,-1
        do 48 its=1,30
          do 41 l=k,1,-1
            nm=l-1
            if((abs(rv1(l))+anorm).eq.anorm)  goto 2
            if((abs(w(nm))+anorm).eq.anorm)  goto 1
41        continue
1         c=0.0
          s=1.0
          do 43 i=l,k
            f=s*rv1(i)
            rv1(i)=c*rv1(i)
            if((abs(f)+anorm).eq.anorm) goto 2
            g=w(i)
            h=pythag(f,g)
            w(i)=h
            h=1.0/h
            c= (g*h)
            s=-(f*h)
            do 42 j=1,m
              y=a(j,nm)
              z=a(j,i)
              a(j,nm)=(y*c)+(z*s)
              a(j,i)=-(y*s)+(z*c)
42          continue
43        continue
2         z=w(k)
          if(l.eq.k)then
            if(z.lt.0.0)then
              w(k)=-z
              do 44 j=1,n
                v(j,k)=-v(j,k)
44            continue
            endif
            goto 3
          endif
          if(its.eq.30) then
             print *, 'no convergence in svdcmp'
             stop
          end if
          x=w(l)
          nm=k-1
          y=w(nm)
          g=rv1(nm)
          h=rv1(k)
          f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y)
          g=pythag(f,r_one)
          f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x
          c=1.0
          s=1.0
          do 47 j=l,nm
            i=j+1
            g=rv1(i)
            y=w(i)
            h=s*g
            g=c*g
            z=pythag(f,h)
            rv1(j)=z
            c=f/z
            s=h/z
            f= (x*c)+(g*s)
            g=-(x*s)+(g*c)
            h=y*s
            y=y*c
            do 45 jj=1,n
              x=v(jj,j)
              z=v(jj,i)
              v(jj,j)= (x*c)+(z*s)
              v(jj,i)=-(x*s)+(z*c)
45          continue
            z=pythag(f,h)
            w(j)=z
            if(z.ne.0.0)then
              z=1.0/z
              c=f*z
              s=h*z
            endif
            f= (c*g)+(s*y)
            x=-(s*g)+(c*y)
            do 46 jj=1,m
              y=a(jj,j)
              z=a(jj,i)
              a(jj,j)= (y*c)+(z*s)
              a(jj,i)=-(y*s)+(z*c)
46          continue
47        continue
          rv1(l)=0.0
          rv1(k)=f
          w(k)=x
48      continue
3       continue
49    continue
      return
      END

      REAL*8 FUNCTION pythag(a,b)
      REAL*8 a,b
      REAL*8 absa,absb
      absa=abs(a)
      absb=abs(b)
      if(absa.gt.absb)then
        pythag=absa*sqrt(1.d0+(absb/absa)**2)
      else
        if(absb.eq.0.)then
          pythag=0.
        else
          pythag=absb*sqrt(1.d0+(absa/absb)**2)
        endif
      endif
      return
      END

      SUBROUTINE svbksb(u,w,v,m,n,mp,np,b,x)
      INTEGER m,mp,n,np,NMAX
      REAL*8 b(mp),u(mp,np),v(np,np),w(np),x(np)
      PARAMETER (NMAX=500)
      INTEGER i,j,jj
      REAL*8 s,tmp(NMAX)
      do 12 j=1,n
        s=0.
        if(w(j).ne.0.)then
          do 11 i=1,m
            s=s+u(i,j)*b(i)
11        continue
          s=s/w(j)
        endif
        tmp(j)=s
12    continue
      do 14 j=1,n
        s=0.
        do 13 jj=1,n
          s=s+v(j,jj)*tmp(jj)
13      continue
        x(j)=s
14    continue
      return
      END

      SUBROUTINE svdvar(v,ma,np,w,cvm,ncvm)
      INTEGER ma,ncvm,np,MMAX
      REAL*8 cvm(ncvm,ncvm),v(np,np),w(np)
      PARAMETER (MMAX=20)
      INTEGER i,j,k
      REAL*8 sum,wti(MMAX)
      do 11 i=1,ma
        wti(i)=0.
        if(w(i).ne.0.) wti(i)=1.d0/(w(i)*w(i))
11    continue
      do 14 i=1,ma
        do 13 j=1,i
          sum=0.
          do 12 k=1,ma
            sum=sum+v(i,k)*v(j,k)*wti(k)
12        continue
          cvm(i,j)=sum
          cvm(j,i)=sum
13      continue
14    continue
      return
      END

c Modify Numerical Recipes program moment.f to compute only
c standard deviation and allow double precision
      SUBROUTINE moment(data,p,sdev)
      Implicit None
      INTEGER p
      REAL*8 adev,ave,curt,sdev,skew,var,data(p)
      INTEGER j
      REAL*8 t,s,ep
      if(p.le.1)then
         print *, 'p must be at least 2 in moment'
         stop
      end if
      s=0.0d0
      do 11 j=1,p
        s=s+data(j)
11    continue
      ave=s/p
      adev=0.0d0
      var=0.0d0
      skew=0.0d0
      curt=0.0d0
      ep=0.
      do 12 j=1,p
        s=data(j)-ave
        t=s*s
        var=var+t
12    continue
      adev=adev/p
      var=(var-ep**2/p)/(p-1)
      sdev=sqrt(var)
      return
      END

c This program is used to find the rotation matrix from the affine matrix
      SUBROUTINE qrdcmp(a,n,np,c,d,sing)
      INTEGER n,np
      REAL*8 a(np,np),c(n),d(n)
      LOGICAL sing
      INTEGER i,j,k
      REAL*8 scale,sigma,sum,tau
      sing=.false.
      scale=0.
      do 17 k=1,n-1
        do 11 i=k,n
          scale=max(scale,abs(a(i,k)))
11      continue
        if(scale.eq.0.)then
          sing=.true.
          c(k)=0.
          d(k)=0.
        else
          do 12 i=k,n
            a(i,k)=a(i,k)/scale
12        continue
          sum=0.
          do 13 i=k,n
            sum=sum+a(i,k)**2
13        continue
          sigma=sign(sqrt(sum),a(k,k))
          a(k,k)=a(k,k)+sigma
          c(k)=sigma*a(k,k)
          d(k)=-scale*sigma
          do 16 j=k+1,n
            sum=0.
            do 14 i=k,n
              sum=sum+a(i,k)*a(i,j)
14          continue
            tau=sum/c(k)
            do 15 i=k,n
              a(i,j)=a(i,j)-tau*a(i,k)
15          continue
16        continue
        endif
17    continue
      d(n)=a(n,n)
      if(d(n).eq.0.)sing=.true.
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software $23#1yR.3Z9.


module m
implicit none
contains
function sqrt_chk_bad(x) result(y)
real, intent(in) :: x
real             :: y
if (x < 0.0) then
   ! line below invalid if function invoked in
   ! PRINT or WRITE
   print*,"need x >= 0 in sqrt_chk_bad"
   y = -1.0
   return
end if
y = sqrt(x)
end function sqrt_chk_bad
!
pure function sqrt_chk(x) result(y)
! note that ERROR STOP is allowed in PURE function
real, intent(in) :: x
real             :: y
if (x < 0.0) error stop "need x >= 0 in sqrt_chk"
y = sqrt(x)
end function sqrt_chk
end module m
!
program main
use m
implicit none
print*,sqrt_chk_bad(-4.0)
end program main
! On Windows, Intel Fortran output:
!  need i >= 0 in sqrt_int
!   -1.000000
! With gfortran the program hangs.
! If the call to sqrt_chk_bad is replaced by a
! call to sqrt_chk, ifort and gfortran say
! need x >= 0 in sqrt_chk


10     PRINT *,' Enter value of step size ( .le. 0 to stop)'
       READ *, H
       IF (H .LE. 0) STOP

       YMINUS=1
       YZERO=1.-H+H**2/2
       NSTEP=6./H
       DO 20 IX=2,NSTEP
          X=IX*H
          YPLUS=YMINUS-2*H*YZERO
          YMINUS=YZERO
          YZERO=YPLUS
          EXACT=EXP(-X)
          PRINT *, X,EXACT,EXACT-YZERO
20     CONTINUE
       GOTO 10
       END


          PROGRAM MAIN
          USE OMP_LIB
          IMPLICIT NONE

          INTEGER :: i, id, nthreads
          INTEGER, PARAMETER :: num_steps=100000000
          REAL*8 x, pi, sum, step
          REAL*8 start_time, run_time

          sum = 0.0
          step = 1.0 / num_steps

          CALL OMP_SET_NUM_THREADS(NTHREADS)
          start_time = OMP_GET_WTIME()

!$OMP PARALLEL DO PRIVATE(i,x) REDUCTION(+:sum)
          DO i = 1, num_steps
             x = (i - 0.5) * step
             sum = sum + 4.0 / (1.0 + x * x)
          ENDDO
!$OMP END PARALLEL DO

          pi = step * sum
          run_time = OMP_GET_WTIME() - start_time
          WRITE(*,100) pi, run_time
100       FORMAT('pi is ',f15.8,' in ',f8.3,' secs')

          END PROGRAM MAIN


! { dg-do run }
! { dg-require-visibility "" }
! Test the fix for PR61459 and PR58883.
!
! Contributed by John Wingate  <johnww@tds.net>
!             and Tao Song  <songtao.thu@gmail.com>
!
module a

   implicit none
   private
   public :: f_segfault, f_segfault_plus, f_workaround
   integer, dimension(2,2) :: b = reshape([1,-1,1,1],[2,2])

contains

   function f_segfault(x)
      real, dimension(:), allocatable :: f_segfault
      real, dimension(:), intent(in)  :: x
      allocate(f_segfault(2))
      f_segfault = matmul(b,x)
   end function f_segfault

! Sefaulted without the ALLOCATE as well.
   function f_segfault_plus(x)
      real, dimension(:), allocatable :: f_segfault_plus
      real, dimension(:), intent(in)  :: x
      f_segfault_plus = matmul(b,x)
   end function f_segfault_plus

   function f_workaround(x)
      real, dimension(:), allocatable :: f_workaround
      real, dimension(:), intent(in)  :: x
      real, dimension(:), allocatable :: tmp
      allocate(f_workaround(2),tmp(2))
      tmp = matmul(b,x)
      f_workaround = tmp
   end function f_workaround

end module a

program main
   use a
   implicit none
   real, dimension(2) :: x = 1.0, y
! PR61459
   y = f_workaround (x)
   if (any (f_segfault (x) .ne. y)) STOP 1
   if (any (f_segfault_plus (x) .ne. y)) STOP 2
! PR58883
   if (any (foo () .ne. reshape([1,2,3,4,5,6,7,8],[2,4]))) STOP 3
contains
  function foo()
    integer, allocatable  :: foo(:,:)
    integer, allocatable  :: temp(:)

    temp = [1,2,3,4,5,6,7,8]
    foo = reshape(temp,[2,4])
  end function
end program main


PROGRAM TEST_ARGSORT_DVEC
! Driver code that tests the function ARGSORT_DVEC from FAST_SORT, using
! data generated by VTMOP.
!
! The inputs are read from sample.dat and the sorted outputs are printed to
! stdout.

! Import the FAST_SORT types and interfaces.
USE FAST_SORT
IMPLICIT NONE

! Output file.
CHARACTER(LEN=20), PARAMETER :: INFILE = "sample.dat"

! Adjust the problem dimensions below. D is the dimension of each vector,
! and N is the number of vectors.
INTEGER, PARAMETER :: D=3, N=1926

! Local variables
INTEGER(KIND=INT64) :: I
LOGICAL :: ERROR

! Allocate inputs
REAL(KIND=REAL64), DIMENSION(D, N) :: VALUES, VALUES_OLD
INTEGER(KIND=INT64), DIMENSION(N) :: INDICES
FORALL (I = 1:N) INDICES(I) = I

! Read the inputs from INFILE.
OPEN(99, FILE=INFILE)
DO I = 1, N
   READ(99,*) VALUES(:, I)
END DO
CLOSE(99)

! Make a copy of values for checking later.
VALUES_OLD(:, :) = VALUES(:, :)

! Sort the inputs.
CALL ARGSORT_DVEC(VALUES, INDICES)
!DO I = 1, N; WRITE(*,*) VALUES(:,I); END DO

! Check VALUES for out-of-order-type errors.
ERROR = .FALSE.
DO I = 2, N
   IF (SUM(VALUES(:, I)) < SUM(VALUES(:, I-1))) THEN
      ERROR = .TRUE.; EXIT
   END IF
END DO
IF (ERROR) THEN
   WRITE(*,*) "An error has occurred in ARGSORT_DVEC: ", &
              "VALUES was not properly sorted."
! VALUES is properly sorted; check that the INDICES are a correct permutation.
ELSE
   IF (ALL(VALUES_OLD(:, INDICES) .EQ. VALUES(:, :))) THEN
      WRITE(*,*) "ARGSORT_DVEC test has passed"
   ELSE
      WRITE(*,*) "An error has occurred in ARGSORT_DVEC: ", &
                 "The INDICES appear to be incorrect"
   END IF
END IF

END PROGRAM TEST_ARGSORT_DVEC


program basic_tests

    use iso_fortran_env
    use sobseq
    use cafut

    type(TestSuite) :: ts

    type(sobol_state) :: rng, rng2
    type(multi_dim_sobol_state) :: md_rng

    integer, parameter :: s=1, a=0, m(1) = (/1/)
    integer, parameter :: N_samples = 17

    real(real64), dimension(:), allocatable :: res, tgt
    real(real64), dimension(:,:), allocatable :: res2, tgt2

    integer :: i

    ts = TestSuite("Single Dimension")

    allocate(res(N_samples), tgt(N_samples))

    tgt = [0.500000000,     &
           0.250000000,     &
           0.750000000,     &
           0.375000000,     &
           0.875000000,     &
           0.125000000,     &
           0.625000000,     &
           0.312500000,     &
           0.812500000,     &
           6.25000000E-02,  &
           0.562500000,     &
           0.187500000,     &
           0.687500000,     &
           0.437500000,     &
           0.937500000,     &
           0.468750000,     &
           0.968750000]

    rng = sobol_state(s,a,m)
    res = [ (rng%skip_ahead(i), i=1, N_samples) ]
    call ts%add(TestRealArrVal("Skip-ahead"), res, tgt)

    rng = sobol_state(s,a,m)
    res = [ (rng%next(), i=1, N_samples) ]
    call ts%add(TestRealArrVal("Next"), res, tgt)

    deallocate(res, tgt)
    allocate(res(0:N_samples), tgt(0:N_samples))

    rng = sobol_state(s,a,m, stride=1)
    res(0) = rng%skip_ahead(0)

    rng2 = sobol_state(s,a,m, stride=1)
    res(1) = rng2%skip_ahead(1)

    do i=2,17
        if (mod(i,2) == 0) then
          res(i) = rng%next()
        else
          res(i) = rng2%next()
        endif
    end do

    tgt = [0.00000000 ,     &
           0.500000000,     &
           0.500000000,     &
           0.250000000,     &
           0.250000000,     &
           0.750000000,     &
           0.750000000,     &
           0.375000000,     &
           0.375000000,     &
           0.875000000,     &
           0.875000000,     &
           0.125000000,     &
           0.125000000,     &
           0.625000000,     &
           0.625000000,     &
           0.312500000,     &
           0.312500000,     &
           0.812500000]

    call ts%add(TestRealArrVal("Next Stride 1"), res, tgt)

    call ts%runTests()

    deallocate(res, tgt)

    ts = TestSuite("Multiple Dimensions")

    allocate(res(N_samples), tgt(N_samples))
    allocate(res2(N_samples, 2), tgt2(N_samples, 2))

    md_rng = multi_dim_sobol_state(2)

    call md_rng%populate(res2)

    tgt2(:,1) = [0.5000000000,     &
                 0.2500000000,     &
                 0.7500000000,     &
                 0.3750000000,     &
                 0.8750000000,     &
                 0.1250000000,     &
                 0.6250000000,     &
                 0.3125000000,     &
                 0.8125000000,     &
                 0.0625000000,     &
                 0.5625000000,     &
                 0.1875000000,     &
                 0.6875000000,     &
                 0.4375000000,     &
                 0.9375000000,     &
                 0.4687500000,     &
                 0.9687500000]

    tgt2(:,2) = [0.5000000000,     &
                 0.2500000000,     &
                 0.7500000000,     &
                 0.6250000000,     &
                 0.1250000000,     &
                 0.8750000000,     &
                 0.3750000000,     &
                 0.9375000000,     &
                 0.4375000000,     &
                 0.6875000000,     &
                 0.1875000000,     &
                 0.3125000000,     &
                 0.8125000000,     &
                 0.0625000000,     &
                 0.5625000000,     &
                 0.4687500000,     &
                 0.9687500000]

    res = res2(:,1)
    tgt = tgt2(:,1)

    call ts%add(TestRealArrVal("Populate Dim 1"), res, tgt)

    res = res2(:,2)
    tgt = tgt2(:,2)

    call ts%add(TestRealArrVal("Populate Dim 2"), res, tgt)

    deallocate(res, tgt, res2, tgt2)

    call ts%runTests()

end program basic_tests


      double complex function B7treea(j1,j2,j3,j4,j5,j6,j7,za,zb)
C---This function in the notation of DKS
c---Multiplied by a factor of (-i)
C---in the natural way this function refers to the process
c---u(2)+dbar(1)-->nu(3)+e^+(3)+b(5)+bbar(6)+g(7)
      implicit none
      include 'constants.f'
      include 'sprods_com.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4,j5,j6,j7
      integer i1,i2,i3,i4
      double complex z2
      double precision s127,s356
      z2(i1,i2,i3,i4)=za(i1,i2)*zb(i2,i4)+za(i1,i3)*zb(i3,i4)
      s127=s(j1,j2)+s(j1,j7)+s(j2,j7)
      s356=s(j3,j5)+s(j3,j6)+s(j5,j6)
      B7treea=z2(j1,j2,j7,j4)*z2(j1,j3,j6,j5)*za(j3,j6)
     . /(za(j1,j7)*za(j2,j7)*dcmplx(s(j5,j6)*s127*s356))
      return
      end

      double complex function B7treeb(j1,j2,j3,j4,j5,j6,j7,za,zb)
C---This function in the notation of DKS
c---Multiplied by a factor of (-i)
C---in the natural way this function refers to the process
c---u(2)+dbar(1)-->nu(3)+e^+(3)+b(5)+bbar(6)+g(7)
      implicit none
      include 'constants.f'
      include 'sprods_com.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4,j5,j6,j7
      integer i1,i2,i3,i4
      double complex z2
      double precision s127,s345
      z2(i1,i2,i3,i4)=za(i1,i2)*zb(i2,i4)+za(i1,i3)*zb(i3,i4)
      s127=s(j1,j2)+s(j1,j7)+s(j2,j7)
      s345=s(j3,j4)+s(j4,j5)+s(j3,j5)

      B7treeb=-za(j2,j6)*zb(j4,j5)
     . *(za(j1,j2)*z2(j3,j4,j5,j1)-za(j2,j7)*z2(j3,j4,j5,j7))
     . /(za(j1,j7)*za(j2,j7)*dcmplx(s(j3,j4)*s127*s345))
      return
      end


      subroutine tcoord(np,x,px,y,py,z,
     1                 dx,dy,dz,chi1,chi2,chi3,dir)
      use tmacro
      use mathfun, only:sqrt1
      implicit none
      integer*4 np,i
      real*8 dx,dy,dz,chi1,chi2,chi3,cchi1,schi1,
     $     cchi2,schi2,cchi3,schi3,dx0,dy0,dz0,dx1,dy1,dz1,
     $     r11,r12,r13,r21,r22,r23,r31,r32,r33,
     $     pxi,pyi,a,dpz,pzi,zi,yi,xi,xf,yf,zf,
     $     pzf
      logical*4 dir
      real*8 x(np),px(np),y(np),py(np),z(np)
c
c   xi        c3 -s3 0      1  0  0      c1 0  s1      x-dx
c   eta  =    s3  c3 0      0  c2 s2     0  1  0       y-dy
c   zeta      0   0  1      0 -s2 c2    -s1 0  c1      z-dz
c
      cchi1=cos(chi1)
      schi1=sin(chi1)
      cchi2=cos(chi2)
      schi2=sin(chi2)
      cchi3=cos(chi3)
      schi3=sin(chi3)
      if(dir)then
        dx0=dx
        dy0=dy
        dz0=dz
        dx1=0.d0
        dy1=0.d0
        dz1=0.d0
        r11= cchi1*cchi3+schi1*schi2*schi3
        r12=-cchi2*schi3
        r13= schi1*cchi3-cchi1*schi2*schi3
        r21=-schi1*schi2*cchi3+cchi1*schi3
        r22= cchi2*cchi3
        r23= cchi1*schi2*cchi3+schi1*schi3
        r31=-schi1*cchi2
        r32=-schi2
        r33= cchi1*cchi2
      else
        dx0=0.d0
        dy0=0.d0
        dz0=0.d0
        dx1=dx
        dy1=-dy
        dz1=-dz
        r11= cchi1*cchi3+schi1*schi2*schi3
        r21= cchi2*schi3
        r31=-schi1*cchi3+cchi1*schi2*schi3
        r12= schi1*schi2*cchi3-cchi1*schi3
        r22= cchi2*cchi3
        r32= cchi1*schi2*cchi3+schi1*schi3
        r13= schi1*cchi2
        r23=-schi2
        r33= cchi1*cchi2
      endif
      do 10 i=1,np
        pxi=px(i)
        pyi=py(i)
        a=pxi**2+pyi**2
        dpz=sqrt1(-a)
c        dpz=a*(-.5d0-a*(.125d0+a*.0625d0))
c        dpz=(dpz**2-a)/(2.d0+2.d0*dpz)
c        dpz=(dpz**2-a)/(2.d0+2.d0*dpz)
        pzi=1.d0+dpz
        zi=pzi*z(i)-dz0
        xi=x(i)+pxi*z(i)-dx0
        yi=y(i)+pyi*z(i)-dy0
        xf =r11*xi +r12*yi +r13*zi
        yf =r21*xi +r22*yi +r23*zi
        zf =r31*xi +r32*yi +r33*zi+dz1
        px(i)=r11*pxi+r12*pyi+r13*pzi
        py(i)=r21*pxi+r22*pyi+r23*pzi
        pzf  =r31*pxi+r32*pyi+r33*pzi
        z(i)=zf/pzf
        x(i)=xf-px(i)*z(i)+dx1
        y(i)=yf-py(i)*z(i)+dy1
10    continue
      return
      end


c
c     ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine cgaunt(lmax,clm,
     >                  plmg,tg,wg,
     >                  cgnt,
     >                  lofk,mofk,
     >                  iprint,istop)
c     =================================================================
c
      implicit   none
c
      character  sname*20
      character  istop*32
c
      integer    lmax
      integer    iprint
      integer    ng
      integer    n1
      integer    n2
      integer    j1,l1,m1
      integer    j2,l2,m2
      integer    l3,m3
      integer    lofk((2*lmax+1)**2)
      integer    mofk((2*lmax+1)**2)
c
      real*8     plmg((2*lmax+1)*(2*lmax+2)/2,2*lmax+1)
      real*8     clm((2*lmax+1)*(2*lmax+2)/2)
      real*8     tg(2*(2*lmax+1))
      real*8     wg(2*(2*lmax+1))
      real*8     gaunt
      real*8     cgnt(lmax+1,(lmax+1)**2,(lmax+1)**2)
      real*8     ctemp
      real*8     ctol
c
      parameter (ctol=1.0d-14)
      parameter (sname='cgaunt')
c
c     ****************************************************************
c     generate:
c
c               4pi  _  m1 _     m2* _     m3 _
c        clll = int do Y  (o) * Y   (o) * Y  (o)
c                0      l1       l2        l3
c
c                L3
c             = C
c                L1,L2
c
c     L1, L2: l = 0,1,..,lmax;  L3: l=0,1,...,2*lmax
c     ****************************************************************
c
c     ================================================================
c     generate the gaussian integration pts and weights...............
c     ----------------------------------------------------------------
      call gauss_legendre_points(-1.d0,1.d0,tg,wg,2*(2*lmax+1))
c     ----------------------------------------------------------------
c
c     ================================================================
c     generate the plm's at the gaussian nodes........................
      n1=2*lmax+1
      do ng=1,n1
! meis: changed to normalized associated Legendre functions
         call plm_normalized(2*lmax,tg(ng),plmg(1,ng))
      enddo
c
      if(iprint.ge.1) then
         write(6,'('' lmax ='',1i4)')lmax
         write(6,'('' ng,tg(ng),wg(ng)'',i5,2d18.10)')
     >               (ng,tg(ng),wg(ng),ng=1,2*(2*lmax+1))
      endif
c     ================================================================
c     generate gaunt numbers..........................................
c     ================================================================
      n1=(lmax+1)**2
      n2=(lmax+1)**2
      do j2=1,n2
	 l2=lofk(j2)
	 m2=mofk(j2)
         do j1=1,n1
	    l1=lofk(j1)
	    m1=mofk(j1)
	    m3=m2-m1
            do l3=l1+l2,max(abs(m3),abs(l1-l2)),-2
               ctemp=gaunt(l1,m1,l2,m2,l3,m3,2*lmax,2*lmax+1,
     >                    wg,plmg,clm)
	       if(abs(ctemp).lt.ctol) ctemp=0.d0
               cgnt(l3/2+1,j1,j2)=ctemp
c     ================================================================
      if(iprint.ge.2) then
                  write(6,'('' l1,m1,l2,m2,l3,m3,clll = '',
     >                      6i3,2x,1pd20.13)')
     >                      l1,m1,
     >                      l2,m2,
     >                      l3,m3,
     >                      cgnt(l3/2+1,j1,j2)
      endif
c     ================================================================
c
            enddo
         enddo
      enddo
c
      if(istop.eq.sname) then
         call fstop(sname)
      else
         return
      endif
c
      end


C
       SUBROUTINE EXTRASHC (DATE,DTE1,NMAX1,GH1,
     1                           DTE2,NMAX2,GH2, NMAX, GH)
c  ------------------------------------------------------------------------
c  Part of "poa_calfos" (STECF/IPMG)
c  Part of "NEWBILCAL" program to produce IGRF geomagnetic model (GSFC)
c
c  History:
c  --------
c  Version   Date        Author          Description
c      1.0       Jul 00  M. Rosa         POA calibration code
c  ------------------------------------------------------------------------
C ===============================================================
C       Version 1.01
C
C       Extrapolates linearly a spherical harmonic model with a
C       rate-of-change model.
C ---------------------------------------------------------------
C       The coefficients (GH) of the resulting model, at date
C       DATE, are computed by linearly extrapolating the coef-
C       ficients of the base model (GH1), at date DTE1, using
C       those of the rate-of-change model (GH2), at date DTE2. If
C       one model is smaller than the other, the extrapolation is
C       performed with the missing coefficients assumed to be 0.
C ---------------------------------------------------------------
C       Input:
C           DATE  - Date of resulting model (in decimal year)
C           DTE1  - Date of base model
C           NMAX1 - Maximum degree and order of base model
C           GH1   - Schmidt quasi-normal internal spherical
C                  harmonic coefficients of base model
C           NMAX2 - Maximum degree and order of rate-of-change model
C           GH2   - Schmidt quasi-normal internal spherical
C                   harmonic coefficients of rate-of-change model
C
C       Output:
C           GH    - Coefficients of resulting model
C           NMAX  - Maximum degree and order of resulting model
C
C       A. Zunde
C       USGS, MS 964, Box 25046 Federal Center, Denver, CO  80225
C ===============================================================
       INTEGER   I,K,L,NMAX,NMAX1,NMAX2
       REAL*4       GH1(*), GH2(*), GH(*)
       REAL*4    DATE,DTE1,DTE2,FACTOR

       FACTOR = (DATE - DTE1)

       IF (NMAX1 .EQ. NMAX2) THEN
         K = NMAX1 * (NMAX1 + 2)
         NMAX = NMAX1
       ELSE IF (NMAX1 .GT. NMAX2) THEN
         K = NMAX2 * (NMAX2 + 2)
         L = NMAX1 * (NMAX1 + 2)
         DO I = K + 1, L
           GH(I) = GH1(I)
         ENDDO
         NMAX = NMAX1
       ELSE
         K = NMAX1 * (NMAX1 + 2)
         L = NMAX2 * (NMAX2 + 2)
         DO I = K + 1, L
           GH(I) = FACTOR * GH2(I)
         ENDDO
         NMAX = NMAX2
       ENDIF

       DO I = 1, K
         GH(I) = GH1(I) + FACTOR * GH2(I)
       ENDDO

       RETURN
       END
C


! test_pot_at.f90
! Axilrod-Teller triple-dipole potential
MODULE test_pot_module

  !------------------------------------------------------------------------------------------------!
  ! This software was written in 2016/17                                                           !
  ! by Michael P. Allen <m.p.allen@warwick.ac.uk>/<m.p.allen@bristol.ac.uk>                        !
  ! and Dominic J. Tildesley <d.tildesley7@gmail.com> ("the authors"),                             !
  ! to accompany the book "Computer Simulation of Liquids", second edition, 2017 ("the text"),     !
  ! published by Oxford University Press ("the publishers").                                       !
  !                                                                                !
  ! LICENCE                                                                                !
  ! Creative Commons CC0 Public Domain Dedication.                                                 !
  ! To the extent possible under law, the authors have dedicated all copyright and related         !
  ! and neighboring rights to this software to the PUBLIC domain worldwide.                        !
  ! This software is distributed without any warranty.                                             !
  ! You should have received a copy of the CC0 Public Domain Dedication along with this software.  !
  ! If not, see <http://creativecommons.org/publicdomain/zero/1.0/>.                               !
  !                                                                                !
  ! DISCLAIMER                                                                                !
  ! The authors and publishers make no warranties about the software, and disclaim liability       !
  ! for all uses of the software, to the fullest extent permitted by applicable law.               !
  ! The authors and publishers do not recommend use of this software for any purpose.              !
  ! It is made freely available, solely to clarify points made in the text. When using or citing   !
  ! the software, you should not imply endorsement by the authors or publishers.                   !
  !------------------------------------------------------------------------------------------------!

  USE, INTRINSIC :: iso_fortran_env, ONLY : error_unit

  IMPLICIT NONE
  PRIVATE

  ! Public routine
  PUBLIC :: force

  ! Public data
  INTEGER, PARAMETER, PUBLIC :: n = 3 ! Three-body potential

CONTAINS

  SUBROUTINE force  ( r, pot, f )
    IMPLICIT NONE
    REAL, DIMENSION(:,:),           INTENT(in)  :: r
    REAL,                           INTENT(out) :: pot
    REAL, DIMENSION(:,:), OPTIONAL, INTENT(out) :: f

    REAL, DIMENSION(3) :: rij, rjk, rki
    REAL               :: rij_sq, rjk_sq, rki_sq, rij_mag, rjk_mag, rki_mag
    REAL               :: rij2, rjk2, rki2, ci, cj, ck, prefac, fac
    INTEGER, PARAMETER :: i = 1, j = 2, k = 3 ! Notation to match appendix

    ! Routine to demonstrate the calculation of forces from the
    ! Axilrod-Teller triple-dipole potential
    ! Written for ease of comparison with the text, rather than efficiency!

    ! Check dimensions to be sure
    IF ( ANY ( SHAPE(r) /= [3,n] ) ) THEN
       WRITE ( unit=error_unit, fmt='(a,4i15)' ) 'r shape error', SHAPE(r), 3, n
       STOP 'Error in test_pot_at'
    END IF

    ! Note that we define the separation vectors in a cyclic way
    rij = r(:,i) - r(:,j)
    rjk = r(:,j) - r(:,k)
    rki = r(:,k) - r(:,i)
    rij_sq = SUM(rij**2)
    rjk_sq = SUM(rjk**2)
    rki_sq = SUM(rki**2)
    rij2 = 1.0/rij_sq
    rjk2 = 1.0/rjk_sq
    rki2 = 1.0/rki_sq
    rij_mag = SQRT ( rij_sq )
    rjk_mag = SQRT ( rjk_sq )
    rki_mag = SQRT ( rki_sq )
    ci = DOT_PRODUCT ( rki, rij )
    cj = DOT_PRODUCT ( rij, rjk )
    ck = DOT_PRODUCT ( rjk, rki )
    prefac = 1/(rij_mag*rjk_mag*rki_mag)**5

    pot = prefac * ( rij_sq*rjk_sq*rki_sq - 3.0*ci*cj*ck ) ! The triple-dipole potential with strength=nu=1

    IF ( .NOT. PRESENT(f) ) RETURN

    IF ( ANY ( SHAPE(f) /= [3,n] ) ) THEN
       WRITE ( unit=error_unit, fmt='(a,4i15)' ) 'f shape error', SHAPE(f), 3, n
       STOP 'Error in test_pot_at'
    END IF

    fac = 5.0*(rij_sq*rjk_sq*rki_sq-3.0*ci*cj*ck)
    f(:,i) = prefac * ( fac*(rij2*rij-rki2*rki) &
         & + 3.0*ci*(ck-cj)*rjk + 3.0*cj*ck*(rki-rij) &
         & + 2.0*(rij_sq*rjk_sq*rki-rjk_sq*rki_sq*rij) )
    f(:,j) = prefac * ( fac*(rjk2*rjk-rij2*rij) &
         & + 3.0*cj*(ci-ck)*rki + 3.0*ck*ci*(rij-rjk) &
         & + 2.0*(rjk_sq*rki_sq*rij-rki_sq*rij_sq*rjk) )
    f(:,k) = prefac * ( fac*(rki2*rki-rjk2*rjk) &
         & + 3.0*ck*(cj-ci)*rij + 3.0*ci*cj*(rjk-rki) &
         & + 2.0*(rki_sq*rij_sq*rjk-rij_sq*rjk_sq*rki) )

  END SUBROUTINE force

END MODULE test_pot_module