      subroutine fpbspl(t,n,k,x,l,h)
c  subroutine fpbspl evaluates the (k+1) non-zero b-splines of
c  degree k at t(l) <= x < t(l+1) using the stable recurrence
c  relation of de boor and cox.
c  ..
c  ..scalar arguments..
      real x
      integer n,k,l
c  ..array arguments..
      real t(n),h(6)
c  ..local scalars..
      real f,one
      integer i,j,li,lj
c  ..local arrays..
      real hh(5)
c  ..
      one = 0.1e+01
      h(1) = one
      do 20 j=1,k
        do 10 i=1,j
          hh(i) = h(i)
  10    continue
        h(1) = 0.
        do 20 i=1,j
          li = l+i
          lj = li-j
          f = hh(i)/(t(li)-t(lj))
          h(i) = h(i)+f*(t(li)-x)
          h(i+1) = f*(x-t(lj))
  20  continue
      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C   Copyright (C) 1995-2004, Scientific Computing Division,
C   University Corporation for Atmospheric Research
C   Licensed under the GNU General Public License (GPL)
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id: tables.f,v 1.2 2006-11-21 01:10:20 haley Exp $
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE DTABLES(IDO,IP,WA)
      DOUBLE PRECISION TPI
      DOUBLE PRECISION ARGZ
      DOUBLE PRECISION ARG1
      DOUBLE PRECISION ARG2
      DOUBLE PRECISION ARG3
      DOUBLE PRECISION ARG4
      DOUBLE PRECISION WA(IDO,IP-1,2)
C
      TPI = 8.D0*ATAN(1.D0)
      ARGZ = TPI/DBLE(IP)
      ARG1 = TPI/DBLE(IDO*IP)
      DO 110 J = 2,IP
          ARG2 = DBLE(J-1)*ARG1
          DO 100 I = 1,IDO
              ARG3 = DBLE(I-1)*ARG2
              WA(I,J-1,1) = COS(ARG3)
              WA(I,J-1,2) = SIN(ARG3)
  100     CONTINUE
          IF (IP.LE.5) GO TO 110
          ARG4 = DBLE(J-1)*ARGZ
          WA(1,J-1,1) = COS(ARG4)
          WA(1,J-1,2) = SIN(ARG4)
  110 CONTINUE
      RETURN
      END


program bench_inline
use gpfunc, only: build_K, kern_sqexp
implicit none

integer, parameter :: nx = 4096
integer, parameter :: nd = 4

real(8), allocatable :: x(:, :), y(:), l(:)
real(8), allocatable :: K(:, :)
integer :: kx, kd
integer(8) :: count, count_rate, count_max
real(8) :: tic, toc

integer :: info

external :: dpotrf
external :: dtrmv

allocate(K(nx, nx), x(nd, nx), l(nd), y(nx))

l = 1d0

do kx = 1, nx
    call random_number(y(kx))
    do kd = 1, nd
        call random_number(x(kd, kx))
    end do
end do

!-------------------------------------------------------------------------------
! Row-wise kernel
K = 0d0
call system_clock(count, count_rate, count_max)
tic = count*1d3/count_rate

call build_K(nd, nx, nx, x, x, l, K, kern_sqexp)

call system_clock(count, count_rate, count_max)
toc = count*1d3/count_rate
print *, 'Time build_K_vec:', toc - tic, 'ms'
print *, K(5,5), K(nx,nx-5)
print *, ''

! Nugget regularization
do kx = 1, nx
    K(kx, kx) = K(kx, kx) + 1d-10
end do

call system_clock(count, count_rate, count_max)
tic = count*1d3/count_rate

! This doesn't touch anything above diagonal
print *, K(1,1:3)
print *, K(2,1:3)
print *, K(3,1:3)
call dpotrf('L', nx, K, nx, info)
print *, '------------------'
print *, K(1,1:3)
print *, K(2,1:3)
print *, K(3,1:3)

call system_clock(count, count_rate, count_max)

toc = count*1d3/count_rate
print *, 'Result Cholesky:', info
print *, 'Time Cholesky:', toc - tic, 'ms'
print *, ''

call system_clock(count, count_rate, count_max)
tic = count*1d3/count_rate

call dtrmv('L', 'N', 'N', nx, K, nx, y, 1)

call system_clock(count, count_rate, count_max)
toc = count*1d3/count_rate
print *, 'Time matmul:', toc - tic, 'ms'

deallocate(K, x, y, l)

end program bench_inline


PROGRAM main

  IMPLICIT NONE

  REAL :: input_temp, output_temp
  REAL :: factor, factor_sub
  LOGICAL :: FtoC
  CHARACTER (LEN=1) :: unit_in, unit_out

  !Conversion factors to turn F into C
  !these names are OK, but not the best
  factor = 5.0/9.0
  factor_sub = 32.0

  PRINT*, "Enter a temperature in the form 23.5 F or 23.5 C (with a space):"

  ! Minor fancy thing - use READ formatting to take the last character
  ! and assume it's a unit
  ! let the rest of the string be the temperature.
  ! Sadly this crashes if you type it wrong, so it's not a very robust solution...
  READ(*, *) input_temp, unit_in

  ! We can store a comparison into a logical
  FtoC = (unit_in .eq. "F")

  IF(FtoC) THEN
    output_temp = (input_temp - factor_sub)*factor
    unit_out = "C"
  ELSE
    output_temp = input_temp/factor + factor_sub
    unit_out = "F"
  END IF

  ! Print result. Add a space to keep in and out formatting consistent
  PRINT "(F8.3, A, A)", output_temp, " ", unit_out

END PROGRAM


! **********************************************
!   July 31, 2012
! **********************************************
!
! This subroutine performs the algorithm described in:
!
!	Aurentz, J. L., Vandebril, R., Watkins, D. S. (2012). Fast Computation of the Zeros of a Polynomial via
!	Factorization of the Companion Matrix. SIAM Journal on Scientific Computing.
!
!
! **************************************************************
!
! Input variables:
!
! POLY         complex array of length DEGREE, containing the nonleading
!              coefficients of P (ordered with decreasing degree)
!
! DEGREE       degree of polynomial
!
! Output variables:
!
! ROOTS        complex array of length DEGREE, containing the roots
!              of Poly
!
! ITERATIONS   integer array of length DEGREE the stores the number of iterations
!	       per deflation
!
! FLAG         reports the position of any instance where the algorithm
!              tried to divide by 0
!
! ***************************************************************

subroutine avw(POLY,DEGREE,ROOTS,ITERATIONS,FLAG)

  implicit none

  integer, intent(in) :: degree
  complex(kind(1d0)), intent(in) :: poly(degree)
  complex(kind(1d0)), intent(out) :: roots(degree)
  integer, intent(out) :: iterations(degree),flag
  integer :: stop_index,start_index,zero_index,i,j,k,n,m,it_count=0,it_max
  double precision :: tolerance=1d-16,zero_point,diagonals,diag1,diag2,norm,nr,nc,nm,bgst,x1,x2,x3,x4
  complex(kind(1d0)) :: trace,detm,disc,DET,shift1,shift2,rho(1),fctr
  complex(kind(1d0)) :: Q(2,2),Q_star(2,2),Temp(2,2),A(2,2),B(2,2),C(2,2),H(3,3),TempH(2,3),rr(1,2),cc(2,1),Blocks(2,2,degree)

  double precision :: DZNRM2

! Initialize and normalize blocks

  do k=2,degree
	Blocks(1,1,k) = complex(-dble(poly(k-1)),-dimag(poly(k-1)))
	Blocks(1,2,k) = complex(1d0,0d0)
	Blocks(2,1,k) = complex(1d0,0d0)
	Blocks(2,2,k) = complex(0d0,0d0)
  end do

  Blocks(1,2,degree) = complex(-dble(poly(degree)),-dimag(poly(degree)))

  Blocks(1,1,1) = complex(0d0,0d0)
  Blocks(1,2,1) = complex(0d0,0d0)
  Blocks(2,1,1) = complex(0d0,0d0)
  Blocks(2,2,1) = complex(1d0,0d0)

! Main loop

  stop_index = degree
  start_index = 2
  zero_index = 1
  it_max = 20*degree
  it_count = 0

  do m=1,it_max

	! Zero check
	do i=1,stop_index
		zero_point = abs(Blocks(2,1,stop_index+1-i))

		if(i>1)then
			diag2 = abs(Blocks(1,1,stop_index+2-i)*Blocks(2,2,stop_index+1-i))
		else
			diag2 = abs(Blocks(2,2,stop_index+1-i))
		end if

		if(i<stop_index)then
			diag1 = abs(Blocks(1,1,stop_index+1-i)*Blocks(2,2,stop_index-i))
		else
			diag1 = abs(Blocks(1,1,stop_index+1-i))
		end if

		diagonals = diag1 + diag2

		if(zero_point < tolerance*diagonals)then
			zero_index = stop_index+1-i
			Blocks(2,1,zero_index) = complex(0d0,0d0)

			! Deflate down if not at bottom
			if(zero_index<stop_index)then
				Blocks(1,1,zero_index+1) = Blocks(1,1,zero_index+1)*Blocks(2,2,zero_index)
				Blocks(1,2,zero_index+1) = Blocks(1,2,zero_index+1)*Blocks(2,2,zero_index)
				Blocks(2,2,zero_index) = complex(1d0,0d0)
				start_index = zero_index+1
			end if

			exit

		end if
	end do

	! zero at bottom
	if(zero_index==stop_index)then
		roots(zero_index) = Blocks(2,2,zero_index)

		iterations(degree-zero_index+1) = it_count
		it_count = 0

		if(stop_index<=1)then
			exit
		end if

		! deflate up
		Blocks(1,2,zero_index-1) = Blocks(1,2,zero_index-1)*Blocks(1,1,zero_index)
		Blocks(2,2,zero_index-1) = Blocks(2,2,zero_index-1)*Blocks(1,1,zero_index)
		Blocks(1,1,zero_index) = complex(1d0,0d0)

		stop_index = stop_index-1

	! 2x2 case
	else if(stop_index==start_index)then
		! calculate eigenvalues using modified quadratic
		trace = Blocks(1,1,stop_index) + Blocks(2,2,stop_index)
		detm = Blocks(1,1,stop_index)*Blocks(2,2,stop_index) - Blocks(1,2,stop_index)*Blocks(2,1,stop_index)

		disc = sqrt(trace*trace - complex(4d0,0d0)*detm)

		if(abs(trace-disc)<abs(trace+disc))then
			if(abs(trace+disc)==0)then
				shift1 = complex(0d0,0d0)
				shift2 = complex(0d0,0d0)
			else
				shift1 = (trace+disc)/complex(2d0,0d0)
				shift2 = complex(2d0,0d0)*detm/(trace+disc)
			end if
		else
			if(abs(trace-disc)==0)then
				shift1 = complex(0d0,0d0)
				shift2 = complex(0d0,0d0)
			else
				shift1 = (trace-disc)/complex(2d0,0d0)
				shift2 = complex(2d0,0d0)*detm/(trace-disc)
			end if
		end if

		! store eigenvalues
		roots(stop_index) = shift1
		Blocks(2,2,stop_index-1) = shift2

		iterations(degree-stop_index) = 0
		it_count = 0

		stop_index = stop_index-1

	! more than one block
	else
		it_count = it_count + 1

		! shift calc
		trace = Blocks(2,2,stop_index-1)*Blocks(1,1,stop_index) + Blocks(2,2,stop_index)
		detm = Blocks(1,1,stop_index)*Blocks(2,2,stop_index) - Blocks(1,2,stop_index)*Blocks(2,1,stop_index)
		detm = Blocks(2,2,stop_index-1)*detm

		disc = sqrt(trace*trace - complex(4d0,0d0)*detm)

		if(abs(trace-disc)<abs(trace+disc))then
			if(abs(trace+disc)==0)then
				shift1 = complex(0d0,0d0)
				shift2 = complex(0d0,0d0)
			else
				shift1 = (trace+disc)/complex(2d0,0d0)
				shift2 = complex(2d0,0d0)*detm/(trace+disc)
			end if
		else
			if(abs(trace-disc)==0)then
				shift1 = complex(0d0,0d0)
				shift2 = complex(0d0,0d0)
			else
				shift1 = (trace-disc)/complex(2d0,0d0)
				shift2 = complex(2d0,0d0)*detm/(trace-disc)
			end if
		end if

		! pick best shift
		if(m == 1)then
			rho(1) = complex(sqrt(2d0),sqrt(2d0))
		else if(m == 2)then
			rho(1) = complex(sqrt(2d0),-sqrt(2d0))
		else if(m == 3)then
			rho(1) = complex(-sqrt(2d0),sqrt(2d0))
		else if(m == 4)then
			rho(1) = complex(-sqrt(2d0),-sqrt(2d0))
		else if(mod(it_count,15)==0)then
			call cnormalpoly(1,rho(1))
			rho(1) = rho(1)/complex(abs(rho(1)),0d0)
			write(*,*) "Exceptional shift"
		else if(abs(Blocks(2,2,stop_index)-shift1)<abs(Blocks(2,2,stop_index)-shift2))then
			rho(1) = shift1
		else
			rho(1) = shift2
		end if

		! Build Q and Q_star
		Q(1,1) = Blocks(1,1,start_index)-rho(1)
		Q(2,1) = Blocks(2,1,start_index)
		norm = dznrm2(2,Q(:,1),1)

		if(norm==0)then
			flag = 2
		end if

		Q(1,1) = Q(1,1)/norm
		Q(2,1) = Q(2,1)/norm
		Q(1,2) = -conjg(Q(2,1))
		Q(2,2) = conjg(Q(1,1))

		Q_star(1,1) = conjg(Q(1,1))
		Q_star(2,1) = conjg(Q(1,2))
		Q_star(1,2) = conjg(Q(2,1))
		Q_star(2,2) = conjg(Q(2,2))

		! initialize A,B and C
		A(1,1) = (Q_star(1,1)*Blocks(1,1,start_index) + Q_star(1,2)*Blocks(2,1,start_index))
		A(1,2) = (Q_star(1,1)*Blocks(1,2,start_index) + Q_star(1,2)*Blocks(2,2,start_index))
		A(2,1) = (Q_star(2,1)*Blocks(1,1,start_index) + Q_star(2,2)*Blocks(2,1,start_index))
		A(2,2) = (Q_star(2,1)*Blocks(1,2,start_index) + Q_star(2,2)*Blocks(2,2,start_index))

		B(1,1) = Blocks(1,1,start_index+1)
		B(1,2) = Blocks(1,2,start_index+1)
		B(2,1) = Blocks(2,1,start_index+1)
		B(2,2) = Blocks(2,2,start_index+1)

		C(1,1) = Q(1,1)
		C(1,2) = Q(1,2)
		C(2,1) = Q(2,1)
		C(2,2) = Q(2,2)

		! Turnover iterations
		do n=(start_index+1),(stop_index)

			call zto(A,B,C,flag)
			if(flag>0)then
				write(*,*) "Flag set at outer iteration ",m," and inner iteration ",n
				return
			end if

			! Update Blocks and C
			Blocks(1,1,n-1) = B(1,1)
			Blocks(1,2,n-1) = B(1,2)
			Blocks(2,1,n-1) = B(2,1)
			Blocks(2,2,n-1) = B(2,2)

			Blocks(1,1,n) = C(1,1)
			Blocks(1,2,n) = C(1,2)
			Blocks(2,1,n) = C(2,1)
			Blocks(2,2,n) = C(2,2)

			! Dump the Bulge
			if(n == stop_index)then
				Temp(1,1) = Blocks(1,1,n)*A(1,1) + Blocks(1,2,n)*A(2,1)
				Temp(1,2) = Blocks(1,1,n)*A(1,2) + Blocks(1,2,n)*A(2,2)
				Temp(2,1) = Blocks(2,1,n)*A(1,1) + Blocks(2,2,n)*A(2,1)
				Temp(2,2) = Blocks(2,1,n)*A(1,2) + Blocks(2,2,n)*A(2,2)

				Blocks(1,1,n) = Temp(1,1)
				Blocks(1,2,n) = Temp(1,2)
				Blocks(2,1,n) = Temp(2,1)
				Blocks(2,2,n) = Temp(2,2)

				exit
			end if

			! Update A, B and C
			Temp(1,1) = A(1,1)
			Temp(1,2) = A(1,2)
			Temp(2,1) = A(2,1)
			Temp(2,2) = A(2,2)

			A(1,1) = C(1,1)
			A(1,2) = C(1,2)
			A(2,1) = C(2,1)
			A(2,2) = C(2,2)

			C(1,1) = Temp(1,1)
			C(1,2) = Temp(1,2)
			C(2,1) = Temp(2,1)
			C(2,2) = Temp(2,2)

			B(1,1) = Blocks(1,1,n+1)
			B(1,2) = Blocks(1,2,n+1)
			B(2,1) = Blocks(2,1,n+1)
			B(2,2) = Blocks(2,2,n+1)

		end do

	end if

  end do

  ! set flag for maxing out loop
  if(m == it_max)then
  	flag = 1
  end if

end subroutine

! **************************************************************
!
! This subroutine performs the turnover step in the AVW algorithm.
!
! **************************************************************

subroutine zto(A,B,C,flag)

	implicit none

	integer, intent(inout) :: flag
	complex(kind(1d0)), intent(inout) :: A(2,2),B(2,2),C(2,2)
	double precision :: norm,nr,nc,nm,bgst,x1,x2,x3,x4
	complex(kind(1d0)) :: Temp(2,2),H(3,3),TempH(2,3),rr(1,2),cc(2,1),fctr,DET,QA(2,2),QB(2,2),QC(2,2)

	double precision :: DZNRM2

			! Build H
			H(1,1) = A(1,1)*C(1,1) + A(1,2)*B(1,1)*C(2,1)
			H(1,2) = A(1,1)*C(1,2) + A(1,2)*B(1,1)*C(2,2)
			H(1,3) = A(1,2)*B(1,2)
			H(2,1) = A(2,1)*C(1,1) + A(2,2)*B(1,1)*C(2,1)
			H(2,2) = A(2,1)*C(1,2) + A(2,2)*B(1,1)*C(2,2)
			H(2,3) = A(2,2)*B(1,2)
			H(3,1) = B(2,1)*C(2,1)
			H(3,2) = B(2,1)*C(2,2)
			H(3,3) = B(2,2)

			! Build first inverse
			Temp(1,1) = H(1,2)*H(3,3) - H(1,3)*H(3,2)
			Temp(1,2) = -H(1,2)*H(2,3) + H(1,3)*H(2,2)
			norm = dznrm2(2,Temp(1,:),1)

			if(norm == 0)then
				flag = 3
				write(*,*) "Flag set in zto!"
				return
			end if

			Temp(1,1) = Temp(1,1)/norm
			Temp(1,2) = Temp(1,2)/norm

			Temp(2,1) = -H(3,1)
			Temp(2,2) = H(2,1)
			norm = dznrm2(2,Temp(2,:),1)

			if(norm == 0)then
				flag = 4
				write(*,*) "Flag set in zto!"
				return
			end if

			Temp(2,1) = Temp(2,1)/norm
			Temp(2,2) = Temp(2,2)/norm

			! invert and store in A
			DET = Temp(1,1)*Temp(2,2) - Temp(1,2)*Temp(2,1)

			if(DET == 0)then
				flag = 5
				write(*,*) "Flag set in zto!"
				return
			end if

			A(1,1) = Temp(2,2)/DET
			A(2,2) = Temp(1,1)/DET
			A(2,1) = -Temp(2,1)/DET
			A(1,2) = -Temp(1,2)/DET

			! Update H
			TempH(1,1) = Temp(1,1)*H(2,1) + Temp(1,2)*H(3,1)
			TempH(1,2) = Temp(1,1)*H(2,2) + Temp(1,2)*H(3,2)
			TempH(1,3) = Temp(1,1)*H(2,3) + Temp(1,2)*H(3,3)
			TempH(2,1) = Temp(2,1)*H(2,1) + Temp(2,2)*H(3,1)
			TempH(2,2) = Temp(2,1)*H(2,2) + Temp(2,2)*H(3,2)
			TempH(2,3) = Temp(2,1)*H(2,3) + Temp(2,2)*H(3,3)

			H(2,1) = TempH(1,1)
			H(2,2) = TempH(1,2)
			H(2,3) = TempH(1,3)
			H(3,1) = TempH(2,1)
			H(3,2) = TempH(2,2)
			H(3,3) = TempH(2,3)

			! Prepare to split updated H
			x1 = abs(H(1,2))
			x2 = abs(H(1,3))
			x3 = abs(H(2,2))
			x4 = abs(H(2,3))

			bgst = max(x1,x2,x3,x4)

			if(bgst == 0)then
				flag = 6
				write(*,*) "Flag set in zto!"
				return
			end if

			if(x1 == bgst)then
				fctr = sqrt(H(1,2))
				rr(1,1) = H(1,2)/fctr
				rr(1,2) = H(1,3)/fctr
				cc(1,1) = H(1,2)/fctr
				cc(2,1) = H(2,2)/fctr
			else if(x2 == bgst)then
				fctr = sqrt(H(1,3))
				rr(1,1) = H(1,2)/fctr
				rr(1,2) = H(1,3)/fctr
				cc(1,1) = H(1,3)/fctr
				cc(2,1) = H(2,3)/fctr
			else if(x3 == bgst)then
				fctr = sqrt(H(2,2))
				rr(1,1) = H(2,2)/fctr
				rr(1,2) = H(2,3)/fctr
				cc(1,1) = H(1,2)/fctr
				cc(2,1) = H(2,2)/fctr
			else
				fctr = sqrt(H(2,3))
				rr(1,1) = H(2,2)/fctr
				rr(1,2) = H(2,3)/fctr
				cc(1,1) = H(1,3)/fctr
				cc(2,1) = H(2,3)/fctr
			end if

			nr = dznrm2(2,rr(1,:),1)
			nc = dznrm2(2,cc(:,1),1)

			nm = sqrt(nc*nr)

			rr(1,1) = rr(1,1)*nm/nr
			rr(1,2) = rr(1,2)*nm/nr

			cc(1,1) = cc(1,1)*nm/nc
			cc(2,1) = cc(2,1)*nm/nc

			! Split updated H into B and C
			B(1,1) = H(1,1)
			B(2,1) = H(2,1)
			B(1,2) = cc(1,1)
			B(2,2) = cc(2,1)

			C(1,1) = rr(1,1)
			C(1,2) = rr(1,2)
			C(2,1) = H(3,2)
			C(2,2) = H(3,3)

end subroutine

! **************************************************************
!
! This subroutine initializes the random seed using the CPU time.
!
! **************************************************************

subroutine init_random_seed()

	implicit none

        integer :: i, n, clock
        integer, dimension(:), allocatable :: seed

        call RANDOM_SEED(size = n)
        allocate(seed(n))

        call SYSTEM_CLOCK(COUNT=clock)

        seed = clock + 37 * (/ (i - 1, i = 1, n) /)
        call RANDOM_SEED(PUT = seed)

	deallocate(seed)
end subroutine

! **************************************************************
!
! This subroutine generates nonleading coefficients of a complex,
! monic polynomial where both the real and imaginary parts are normally
! distributed with 0 mean and a variance of 1.
!
! **************************************************************

subroutine cnormalpoly(degree,poly)

	implicit none

	integer, intent(in) :: degree
	complex(kind(1d0)), intent(inout) :: poly(degree)

	double precision :: u,v,s,pi = 3.141592653589793239d0
	integer :: i,j

	do i=1,degree
		do j=1,20

			call random_number(u)
			call random_number(v)

			s = u**2 + v**2

			if(s > 0 .and. s < 1)then
				poly(i) = complex(cos(2d0*pi*v)*sqrt(-2d0*log(u)),sin(2d0*pi*v)*sqrt(-2d0*log(u)))
				exit
			end if
		end do

	end do

end subroutine


Function pyw2au(eps, ireim)
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Save /ludat1/
  acosh(x) = log(x+sqrt(x**2-1.))
  If (eps<0.) Then
    w2re = 4.*(asinh(sqrt(-1./eps)))**2
    w2im = 0.
  Else If (eps<1.) Then
    w2re = 4.*(acosh(sqrt(1./eps)))**2 - paru(1)**2
    w2im = -4.*paru(1)*acosh(sqrt(1./eps))
  Else
    w2re = -4.*(asin(sqrt(1./eps)))**2
    w2im = 0.
  End If
  If (ireim==1) pyw2au = w2re
  If (ireim==2) pyw2au = w2im
  Return
End Function pyw2au


      subroutine eflux(w,dw,p,x,porj,il,jl,ib,jb)
c
c     ******************************************************************
c     *                                                                *
c     *   euler flux                                                   *
c     *                                                                *
c     ******************************************************************
c
c     w(i,j,1)  = density
c     w(i,j,2)  = momentum in x direction
c     w(i,j,3)  = momentum in y direction
c     w(i,j,4)  = total energy
c
c     ******************************************************************
c
c      use dims
c
c     ******************************************************************
c
c      use flo_var
c      use mesh_var
c      use solv_var
c
c     ******************************************************************
c
      implicit none

c     inputs
      integer, intent(in) :: il,jl,ib,jb

c     everything is zero indexed except for porosity
      real(8), intent(in), dimension(0:ib,0:jb,4) :: w
      real(8), intent(in), dimension(1:il,1:jl,2) :: x
      real(8), intent(in), dimension(0:ib,0:jb)   :: p
      real(8), intent(in), dimension(:,:)         :: porj

      real(8), intent(inout), dimension(0:ib,0:jb,4)  :: dw

c
c     ******************************************************************
c
c     local variables
c
c     ******************************************************************
c
      integer :: i,j,n
c
c     ******************************************************************
c
      real(8)     :: xx,yx,xy,yy
      real(8)     :: qsp,qsm,pa
c
c     ******************************************************************
c
      real(8), dimension(il+2,jl+2,4) :: fs
c
c     ******************************************************************
c
c     flux in the i direction
c
      do j=2,jl
      do i=1,il
         xy        = x(i,j,1)  -x(i,j-1,1)
         yy        = x(i,j,2)  -x(i,j-1,2)
         pa        = p(i+1,j)  +p(i,j)
         qsp       = (yy*w(i+1,j,2)  -xy*w(i+1,j,3))/w(i+1,j,1)
         qsm       = (yy*w(i,j,2)  -xy*w(i,j,3))/w(i,j,1)
         fs(i,j,1) = qsp*w(i+1,j,1)  +qsm*w(i,j,1)
         fs(i,j,2) = qsp*w(i+1,j,2)  +qsm*w(i,j,2)  +yy*pa
         fs(i,j,3) = qsp*w(i+1,j,3)  +qsm*w(i,j,3)  -xy*pa
         fs(i,j,4) = qsp*(w(i+1,j,4)  +p(i+1,j))
     .              +qsm*(w(i,j,4)    +p(i,j))
      end do
      end do
c
c     accumulate the flux in the i direction
c
      do n=1,4
         do j=2,jl
         do i=2,il
            dw(i,j,n) = fs(i,j,n)  -fs(i-1,j,n)
         end do
         end do
      end do
c
c     flux in the j direction
c
      do j=1,jl
      do i=2,il
         xx        = x(i,j,1)  -x(i-1,j,1)
         yx        = x(i,j,2)  -x(i-1,j,2)
         pa        = p(i,j+1)  +p(i,j)
         qsp       = porj(i,j)*(xx*w(i,j+1,3)  -yx*w(i,j+1,2))/
     .                          w(i,j+1,1)
         qsm       = porj(i,j)*(xx*w(i,j,3)  -yx*w(i,j,2))/
     .                          w(i,j,1)
         fs(i,j,1) = qsp*w(i,j+1,1)  +qsm*w(i,j,1)
         fs(i,j,2) = qsp*w(i,j+1,2)  +qsm*w(i,j,2)  -yx*pa
         fs(i,j,3) = qsp*w(i,j+1,3)  +qsm*w(i,j,3)  +xx*pa
         fs(i,j,4) = qsp*(w(i,j+1,4)  +p(i,j+1))
     .              +qsm*(w(i,j,4)    +p(i,j))
      end do
      end do
c
c     accumulate the flux in the j direction
c
      do n=1,4
         do j=2,jl
         do i=2,il
            dw(i,j,n) = dw(i,j,n)  +fs(i,j,n)  -fs(i,j-1,n)
         end do
         end do
      end do

      return

      end


        subroutine logparm (iant,nel, rlnel, rl1, hnel, h1, dc, z0)
c
c       LOG-PERIODIC ANTENNA PARAMETERS CALCULATION
c
      common/general/d1,e1,f1,p1,q1,s1,beta,rlambda
      common/logp/fi(35),rim(35),x(35),y(35),iek(35),rl(35),h(30)
      common/ccparm/uust,nat,ah1,bh1
      common/surf/ro,costh,sinth,rnumb,gamma,epq
c
        dimension d(30),ria(30)
c
ccc        write(*,100)nel,rlnel,rl1,hnel,h1,dc,z0
ccc  100   format(' nel,rlnel,rl1,hnel,h1,dc,z0 = ',I2,6f6.1)
c
        rl(nel) = rlnel
        rl(1) = rl1
        h(nel) = hnel
        h(1) = h1
        rlr = rl1 / rlnel
        exl = 1.0 / (nel - 1.0)
        tau = rlr **exl
        rld = rlnel - rl1
        sinth = (hnel - h1) / dc
        costh = sqrt(1 - sinth **2)
ccc        write(*,110)rlr,exl,tau,rld,sinth,costh
ccc  110   format(' rlr,exl,tau,rld,sinth,costh = ',6f6.1)
c
      if (iant.ne.5) then
c===========================================================================
c  CALC. ELEM. LENGTH L(I), HEIGHT H(I), DISTANCES D(I) - VERT.LOG-PERIODIC
c===========================================================================
        dl1 = dc * rl1 / rld
        da1 = dl1 * costh
        db1 = dl1 * sinth
        dc1 = db1 - rl1
        tg23 = sinth / costh
        alfa23 = atan(tg23)
        tg3 = dc1 / da1
        alfa3 = atan(tg3)
        alfa2 = alfa23 - alfa3
        sigma = (1 - tau) / (4 * (sinth - tg3 * costh))
        theta = sin(alfa3) * costh / sin(alfa2)
        h(nel) = rl(nel) * (1 + theta)
        h0 = h1 - rl1 * (1 + theta)
        do 600 i = (nel - 1),1, -1
        rl(i) = rl(i + 1) * tau
        d(i) = 4 * rl(i + 1) * sigma
        h(i) = rl(i) * (1 + theta) + h0
  600   continue
        y(1) = rl(1) / (tg23 * (1 - tg3 / tg23))
        do 610 i = 2, nel
        y(i) = y(i - 1) + d(i - 1) * costh
  610   continue
      else
c============================================================================
c CALC. ELEM. LENGTH L(I), HEIGHT H(I), DISTANCES D(I) - HORIZ.LOG-PERIODIC
c============================================================================
        alftan = rld / dc
        thetan = sinth / costh
        theta = atan(thetan)
        alfa = atan(alftan)
        sigma = (1 - tau) / (4 * alftan)
        d(nel) = 4 * rl(nel) * sigma
        do 620 i = (nel - 1),1,-1
        rl(i) = rl(i + 1) * tau
        d(i) = 4 * rl(i + 1) * sigma
  620   continue
        x(1) = rl(1) / alftan * costh
        do 630 i = 2,nel
        x(i) = x(i - 1) + d(i - 1) * costh
        h(i) = h(i - 1) + d(i - 1) * sinth
  630   continue
      endif
c============================================================================
c       CALCULATION OF LC, LLOW, LUP AND L0 ( l/a = 500 is assumed )
c============================================================================
        z0m = z0 / 1000
        shf = 1.098790227 - 1.055146365 * z0m + 3.208544524 *
     &      z0m **2 - 5.766460847 * z0m **3 + 4.054233788 * z0m **4
        rlc = rlambda * shf / 4.0
        bar = 1.1 + 30.7 * sigma * (1 - tau)
        rllow = rlc / bar
        rlup = 1.1 * rlc
ccc        write(*,200)rllow,rlup
ccc  200   format(' rllow,rlup = ',2f6.1)
        rl0 = rllow + .7166 * (rlc - rllow)
c============================================================================
c       DETERMINATION OF INDEX EK(I) OF ELEMENTS FALLING IN LLOW - LUP RANGE
c============================================================================
        k = 0
        do 650 i = 1,nel
        if (rl(i).ge.rllow .and. rl(i).le.rlup) then
          k = k + 1
          iek(k) = i
        endif
  650   continue
        nat = k
ccc        write(*,220)nat
ccc  220   format(' nat = ',i2)
ccc        read(*,230)iii
ccc  230   format(i1)
c============================================================================
c       CALCULATION OF CURRENT IA(I) AND PHASE FI(I) OF ACTIVE ELEMENTS
c============================================================================
        call curcal(rl0, rllow, rlc, rlup, aa1, aa2, aa3, aa4,
     1    aa5, bb1, bb2, bb3, bb4, bb5, cc1, cc2, cc3, cc4, cc5)
      do 900 k = 1,nat
      i = iek(k)
      if (rl(i).ge.rllow.and.rl(i).lt.(rllow+(rl0-rllow)/2.0)) then
          ria(i) = aa1 * rl(i) **2 + bb1 * rl(i) + cc1
      elseif (rl(i).ge.(rllow + (rl0 - rllow) / 2.0) .and.
     &  rl(i).lt.(rllow + 3.0 * (rl0 - rllow) / 4.0)) then
          ria(i) = aa2 * rl(i) **2 + bb2 * rl(i) + cc2
      elseif (rl(i).ge.(rllow + 3 * (rl0 - rllow) / 4.0) .and.
     &  rl(i).le.rl0) then
          ria(i) = aa3 * rl(i) **2 + bb3 * rl(i) + cc3
      elseif (rl(i).ge.rl0 .and. rl(i).le.rlc) then
          ria(i) = aa4 * rl(i) **2 + bb4 * rl(i) + cc4
      elseif (rl(i).ge.rlc .and.rl(i).le.rlup) then
          ria(i) = aa5 * rl(i) **2 + bb5 * rl(i) + cc5
      else
          write(*,*)'current calculation error!'
      endif
      if (rl(i).ge.rllow .and. rl(i).le.rl0) then
        af = 150 / (rl0 - rllow)
      else
        af = 142 / (rlup - rl0)
      endif
        bf = -af * rl0
        fi(i) = af * rl(i) + bf
  900   continue
c============================================================================
c       CALCULATION OF NORMALIZED CURRENT IM(I) TO IMAX=1 AND PHASES FI(I)
c============================================================================
        kmax = 0
        riamax = 0
        do 960 k = 1,nat
        i = iek(k)
        if (ria(i).ge.riamax) then
          kmax = i
          riamax = ria(i)
          fimin = fi(i)
        endif
  960   continue
        do 980 k = 1,nat
        i = iek(k)
        rinm = ria(i) / riamax
        fi(i) = fi(i) - fimin
        rim(i) = rinm / sin(beta * rl(i))
  980   continue
        return
        end
c--------------------------------------------------------------------


MODULE m_pd_geopotential

! ----------------------------------------------------------------------
! MODULE: m_pd_geopotential
! ----------------------------------------------------------------------
! Purpose:
!  Module for calling the following subroutines
!
! Subroutines contained within the module:
! - pd_geopotential
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou
!			Cooperative Research Centre for Spatial Information, Australia
! Created:	11 December 2017
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE pd_geopotential (GM, ae, r, nmax, mmax, Cnm, Snm, Fvec, Umatrix)

! ----------------------------------------------------------------------
! SUBROUTINE: pd_geopotential
! ----------------------------------------------------------------------
! Purpose:
! Partial derivatives of the acceleration due to the Earth Gravity field
! (based on a gravity model expressed by a set of spherical harmonic coefficients)
! and the Tides effects (expressed as corrections to the spherical harmonic coefficients)
! ----------------------------------------------------------------------
! Input arguments:
! - GM:				Earth gravity constant  (m^3/sec^2)
! - ae:				Earth radius (meters)
! - r:				Position vector (m) in Terrestrial Reference System (ITRS)
!   				r = [x y z]
! - nmax:           maximum degree expansion
! - mmax:           maximum order expansion (mmax <= nmax)
! - Cnm, Snm:		Spherical Harmonic Coefficients (degree n, order m); dynamic allocatable arrays
!
! Output arguments:
! - fxyz:			Acceleration vector cartesian components in ITRS
! - U: 				Matrix of the partial derivatives of the acceleration in ITRS
!   				given in the form of second partial derivatives of
!					geopotential Uxx, Uyy, Uzz, Uxy, Uxz, Uyz
! ----------------------------------------------------------------------
! Remark 1:
!  Cnm, Snm are dynamic allocatable arrays
!  Cnm and Snm arrays are formed into lower triangular matrices.
!  Coefficient Cnm corresponds to the matrix element Cnm(n+1,m+1)
!
! Remark 2:
!  Matrix of second partial derivatives:
!   U = [ Uxx   Uxy   Uxz
!         Uxy   Uyy   Uyz
!         Uxz   Uyz   Uzz ]
!
!  Partial derivatives are noted as:
!   dfx / dy = Uxy,     dfx / dx = Uxx
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou
!			Cooperative Research Centre for Spatial Information, Australia
! Created:	11 December 2017
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE mdl_param
      USE m_legendre
      USE m_legendre1
      USE m_legendre2
      USE m_matrixRxR
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN) :: GM, ae
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(3) :: r
      INTEGER (KIND = prec_int8), INTENT(IN) :: nmax, mmax
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(:,:), ALLOCATABLE :: Cnm, Snm
! ----------------------------------------------------------------------
! OUT
      REAL (KIND = prec_q), INTENT(OUT) :: Fvec(3)
      REAL (KIND = prec_q), INTENT(OUT) :: Umatrix(3,3)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: Pnm_norm, dPnm_norm, d2Pnm_norm
      REAL (KIND = prec_q) :: phi, lamda, radius, fgrav_3d
      REAL (KIND = prec_q) :: l, rdist
      REAL (KIND = prec_q) :: fr, ftheta, flamda
      REAL (KIND = prec_q) :: dV_r, dV_phi, dV_lamda
      INTEGER (KIND = prec_int8) :: n, m, m_limit
      INTEGER (KIND = prec_int8) :: sz_tides, Nmax_tide
      INTEGER (KIND = prec_int2) :: comp_option
      INTEGER (KIND = prec_int2) :: AllocateStatus, DeAllocateStatus
      REAL (KIND = prec_q) :: fx, fy, fz
      REAL (KIND = prec_q), DIMENSION(3) :: fxyz, dV_sph
      REAL (KIND = prec_q), DIMENSION(3,3) :: PDVrx, PDVrx_T
      REAL (KIND = prec_q), DIMENSION(3,3) :: Vrtl, pdv2_r, pdv2_theta, pdv2_lamda, pdvFxyz_rtl
      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: U1, U2, U3
      REAL (KIND = prec_q) :: theta, pi
      REAL (KIND = prec_q) :: Vrr, Vrt, VrL, Vtt, VtL, VLL
      REAL (KIND = prec_q) :: Vrr_f, Vrt_f, VrL_f, Vtt_f, VtL_f, VLL_f
      REAL (KIND = prec_q) :: pdvfx_r, pdvfy_r, pdvfz_r
      REAL (KIND = prec_q) :: pdvfx_theta, pdvfy_theta, pdvfz_theta
      REAL (KIND = prec_q) :: pdvfx_lamda, pdvfy_lamda, pdvfz_lamda
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Numerical Constants
      pi = PI_global
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! computation of spherical coordinates in radians
CALL coord_r2sph (r , phi,lamda,radius)
l = radius
rdist = radius
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Normalized associated Legendre functions
CALL legendre (phi, nmax, Pnm_norm)
! First-order derivatives of normalized associated Legendre functions
CALL legendre_drv1 (phi, nmax, dPnm_norm)
! Second-order derivatives of the Normalized Associated Legendre functions
CALL legendre2 (phi, nmax, d2Pnm_norm)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! 2nd approach:
! Partial derivatives of potential with respect to the spherical coordinates:
! - dV_r     : partial derivative of geopotential to radius
! - dV_phi   : partial derivative of geopotential to latitude
! - dV_lamda : partial derivative of geopotential to longtitude
dV_r = 0.D0
dV_phi = 0.D0
dV_lamda = 0.D0
Do n = 2 , nmax
    If (n > mmax) Then
        m_limit = mmax
    else
        m_limit = n
    End IF
        Do m = 0 , m_limit
            dV_r = dV_r + 1.0D0*(n+1)*((ae/l)**n) * Pnm_norm(n+1,m+1) * (Cnm(n+1,m+1) * cos(m*lamda) + Snm(n+1,m+1) * sin(m*lamda))
            dV_phi = dV_phi     + ((ae/l)**n) * dPnm_norm(n+1,m+1) * (Cnm(n+1,m+1)*cos(m*lamda)+Snm(n+1,m+1)*sin(m*lamda))
            dV_lamda = dV_lamda + m * ((ae/l)**n) * Pnm_norm(n+1,m+1) * (Snm(n+1,m+1)*cos(m*lamda)-Cnm(n+1,m+1)*sin(m*lamda))
        end Do
end Do
dV_r = - GM / (l**2) - (GM/l**2) * dV_r
dV_phi = (GM / l) * dV_phi
dV_lamda = (GM / l) * dV_lamda
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Partial derivatives of (r,phi,lamda) with respect to (x,y,z)
! ----------------------------------------------------------------------
PDVrx (1,1:3) = (/ cos(phi)*cos(lamda) ,              cos(phi)*sin(lamda) ,             sin(phi) /)
PDVrx (2,1:3) = (/ (1.0D0/l)*sin(phi)*cos(lamda) ,    (1.0D0/l)*sin(phi)*sin(lamda),    (-1.0D0/l)*cos(phi) /)
PDVrx (3,1:3) = (/ ( -1.D0/(l*cos(phi)) )*sin(lamda), ( 1.D0/(l*cos(phi)) )*cos(lamda),         0.0D0 /)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Computation of Cartesian counterparts of the acceleration
!fxyz = PDVrx' * [dV_r; dV_phi; dV_lamda];
PDVrx_T = TRANSPOSE (PDVrx)
dV_sph = (/ dV_r, dV_phi, dV_lamda /)
CALL matrix_Rr (PDVrx_T, dV_sph , fxyz)
fx = fxyz(1)
fy = fxyz(2)
fz = fxyz(3)
Fvec = fxyz
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Geopotential 2nd-order partial derivatives in r,theta,lamda components
! ----------------------------------------------------------------------
! Vrr, VrTheta (Vrt), VrLamda(VrL), V_ThetaTheta (Vtt), V_ThetaLamda (VtL)
! V_LamdaLamda (VLL)
! ----------------------------------------------------------------------
Vrr = 0.D0
Vrt = 0.D0
VrL = 0.D0
Vtt = 0.D0
VtL = 0.D0
VLL = 0.D0
Do n = 0 , nmax
        Do m = 0 , n
            Vrr_f = (GM/ae**3) * 1.D0*(n+1)*(n+2) * (ae/l)**(n+3)
            Vrr = Vrr + Vrr_f * ( Cnm(n+1,m+1) * cos(m*lamda) + Snm(n+1,m+1) * sin(m*lamda) ) * Pnm_norm(n+1,m+1)

            Vrt_f = - (GM/ae**2) * 1.D0*(n+1) * (ae/l)**(n+2) 					!% Eq.6.24 Revised 2012
            Vrt = Vrt + Vrt_f * ( Cnm(n+1,m+1) * cos(m*lamda) + Snm(n+1,m+1) * sin(m*lamda) ) * dPnm_norm(n+1,m+1)

            VrL_f = (GM/ae**2) * 1.D0*(n+1) * (ae/l)**(n+2)
            VrL = VrL + VrL_f * m * ( Cnm(n+1,m+1) * sin(m*lamda) - Snm(n+1,m+1) * cos(m*lamda) ) * Pnm_norm(n+1,m+1)

            Vtt_f = (GM / ae) * (ae / l)**(n+1)
            Vtt = Vtt + Vtt_f * ( Cnm(n+1,m+1) * cos(m*lamda) + Snm(n+1,m+1) * sin(m*lamda) ) * d2Pnm_norm(n+1,m+1)

            VtL_f = (GM / ae) * (ae / l)**(n+1)
            !% Corrected : May 2012
            VtL = VtL + VtL_f * m * ( - Cnm(n+1,m+1) * sin(m*lamda) + Snm(n+1,m+1) * cos(m*lamda) ) * dPnm_norm(n+1,m+1)

            VLL_f = (GM / ae) * (ae / l)**(n+1)
            VLL = VLL - VLL_f * m**2 * ( Cnm(n+1,m+1) * cos(m*lamda) + Snm(n+1,m+1) * sin(m*lamda) ) * Pnm_norm(n+1,m+1)
        end Do
end Do

! Geopotential 2nd-order partial derivatives in local tangent frame (er, etheta, elamda)
Vrtl(1,:) = (/ Vrr , Vrt , VrL /)
Vrtl(2,:) = (/ Vrt , Vtt , VtL /)
Vrtl(3,:) = (/ VrL , VtL , VLL /)
! ----------------------------------------------------------------------

theta = pi/2 - phi

! ----------------------------------------------------------------------
! Partial derivatives of PDVrx with respect to (r,theta,lamda)
! ----------------------------------------------------------------------
pdv2_r (1,1:3) = (/ 0.0D0 , 0.0D0 , 0.0D0 /)
pdv2_r (2,1:3) = (/ (-1.0D0/rdist**2)*(cos(theta)*cos(lamda)), (-1.0D0/rdist**2)*(cos(theta)*sin(lamda)),  &
                    (1.0D0/rdist**2)*sin(theta) /)
pdv2_r (3,1:3) = (/  (1.0D0/rdist**2)*(sin(lamda)/sin(theta)), (-1.0D0/rdist**2)*(cos(lamda)/sin(theta)),  0.0D0 /)

pdv2_theta (1,1:3) = (/ cos(theta)*cos(lamda), cos(theta)*sin(lamda), -sin(theta) /)
pdv2_theta (2,1:3) = (/ (-1.0D0/rdist)*(sin(theta)*cos(lamda)), (-1.0D0/rdist)*(sin(theta)*sin(lamda)),  &
                        (-1.0D0/rdist)*cos(theta) /)
pdv2_theta (3,1:3) = (/ (1.0D0/rdist)*(sin(lamda)*cos(theta)/sin(theta)**2),  &
                        (-1.0D0/rdist)*(cos(lamda)*cos(theta)/sin(theta)**2), 0.0D0 /)

pdv2_lamda (1,1:3) = (/ -sin(theta)*sin(lamda), sin(theta)*cos(lamda), 0.0D0 /)
pdv2_lamda (2,1:3) = (/ (-1.0D0/rdist)*(cos(theta)*sin(lamda)),  (1.0D0/rdist)*(cos(theta)*cos(lamda)), 0.0D0 /)
pdv2_lamda (3,1:3) = (/ (-1.0D0/rdist)*(cos(lamda)/sin(theta)), (-1.0D0/rdist)*(sin(lamda)/sin(theta)), 0.0D0 /)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Partial derivatives of (Fx,Fy,Fz) with respect to (r,theta,lamda)
! ----------------------------------------------------------------------
! pdv(fxyz/r)
pdvfx_r = Vrr * PDVrx(1,1) + Vrt * PDVrx(2,1) + VrL * PDVrx(3,1) +           &
          dV_r * pdv2_r(1,1) + dV_phi * pdv2_r(2,1) + dV_lamda * pdv2_r(3,1)

pdvfy_r = Vrr * PDVrx(1,2) + Vrt * PDVrx(2,2) + VrL * PDVrx(3,2) +           &
          dV_r * pdv2_r(1,2) + dV_phi * pdv2_r(2,2) + dV_lamda * pdv2_r(3,2)

pdvfz_r = Vrr * PDVrx(1,3) + Vrt * PDVrx(2,3) + VrL * PDVrx(3,3) +           &
          dV_r * pdv2_r(1,3) + dV_phi * pdv2_r(2,3) + dV_lamda * pdv2_r(3,3)

! pdv(fxyz/theta)
pdvfx_theta = Vrt * PDVrx(1,1) + Vtt * PDVrx(2,1) + VtL * PDVrx(3,1) +                      &
              dV_r * pdv2_theta(1,1) + dV_phi * pdv2_theta(2,1) + dV_lamda * pdv2_theta(3,1)

pdvfy_theta = Vrt * PDVrx(1,2) + Vtt * PDVrx(2,2) + VtL * PDVrx(3,2) +                      &
              dV_r * pdv2_theta(1,2) + dV_phi * pdv2_theta(2,2) + dV_lamda * pdv2_theta(3,2)

pdvfz_theta = Vrt * PDVrx(1,3) + Vtt * PDVrx(2,3) + VtL * PDVrx(3,3) +                      &
              dV_r * pdv2_theta(1,3) + dV_phi * pdv2_theta(2,3) + dV_lamda * pdv2_theta(3,3)

! pdv(fxyz/lamda)
pdvfx_lamda = VrL * PDVrx(1,1) + VtL * PDVrx(2,1) + VLL * PDVrx(3,1) +                      &
              dV_r * pdv2_lamda(1,1) + dV_phi * pdv2_lamda(2,1) + dV_lamda * pdv2_lamda(3,1)

pdvfy_lamda = VrL * PDVrx(1,2) + VtL * PDVrx(2,2) + VLL * PDVrx(3,2) +                      &
              dV_r * pdv2_lamda(1,2) + dV_phi * pdv2_lamda(2,2) + dV_lamda * pdv2_lamda(3,2)

pdvfz_lamda = VrL * PDVrx(1,3) + VtL * PDVrx(2,3) + VLL * PDVrx(3,3) +                      &
              dV_r * pdv2_lamda(1,3) + dV_phi * pdv2_lamda(2,3) + dV_lamda * pdv2_lamda(3,3)

! matrix : pdvFxyz_rtl
pdvFxyz_rtl (1,1:3) = (/ pdvfx_r,   pdvfx_theta,   pdvfx_lamda /)
pdvFxyz_rtl (2,1:3) = (/ pdvfy_r,   pdvfy_theta,   pdvfy_lamda /)
pdvFxyz_rtl (3,1:3) = (/ pdvfz_r,   pdvfz_theta,   pdvfz_lamda /)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Geopotential 2nd-order partial derivatives in ITRS X,Y,Z components
! ----------------------------------------------------------------------
!Umatrix = PDVrx' * pdvFxyz_rtl'

! Allocatable arrays
ALLOCATE (U1(3,3), STAT = AllocateStatus)
ALLOCATE (U2(3,3), STAT = AllocateStatus)
ALLOCATE (U3(3,3), STAT = AllocateStatus)

U1 = TRANSPOSE(PDVrx)
U2 = TRANSPOSE(pdvFxyz_rtl)
Call matrixRxR (U1, U2, U3)
Umatrix = U3

END SUBROUTINE

END Module


program bignum
    use fmzm
    implicit none
    type(im) :: a
    integer :: n

    call fm_set(50)
    a = to_im(5)**(to_im(4)**(to_im(3)**to_im(2)))
    n = to_int(floor(log10(to_fm(a))))
    call im_print(a / to_im(10)**(n - 19))
    call im_print(mod(a, to_im(10)**20))
end program


!---------------------------------------------------------------------------------------------------
!
!	filename = atomic.f90
!	authors = Edison Salazar
!		  Pedro Guarderas
!	date = 01/08/2013
!
!---------------------------------------------------------------------------------------------------

!---------------------------------------------------------------------------------------------------
! Module for atomic calculus
! Based in notes of Eduardo Ludeña
module atomic
  use base
  use consts

  implicit none

contains

!---------------------------------------------------------------------------------------------------
subroutine radialDFT( p, r, Nr, c, nc, e, ne, d, n, m )
  implicit none
  integer, intent( in ) :: n, m, Nr, d(n+1)
  double precision, intent( in ) :: c(m), ne(n), nc(m), e(m), r(Nr)
  double precision, intent( out ) :: p(Nr)
  double precision :: sum, nrmj
  integer i, j, k, Mi, Ni

  do k = 1,Nr
    Mi = 1
    Ni = 0
    do i = 1,n
      Mi = Mi + d(i)
      Ni = d( i + 1 ) + Mi - 1
      sum = 0.0D0
      do j = Mi,Ni
        nrmj = 1.0D0 / sqrt( STOnorm( 2.0D0 * nc(j), 2.0D0 * e(j) ) )
        sum = sum + c(j) * nrmj * ( r(k)**( nc(j) - 1.0D0 ) ) * exp( -e(j) * r(k) )
      end do
      p(k) = p(k) + ne(i) * ( r(k) * sum )**2.0D0
    end do
  end do

end subroutine radialDFT

subroutine HomogeneousApprox( T, C, W, J, p, r, Nr, n )
  integer, intent( in ) :: n, Nr
  double precision, intent( in ) :: C(n), W(n), J(n), p(Nr), r(Nr)
  double precision, intent( out ) :: T
  double precision :: S
  integer :: k, l

  T = 0.0D0
  do k = 1,n
    S = 0.0D0
    do l = 1,(Nr-1)
!       S = S + ( ( 0.5D0 * ( p(l+1) + p(l) ) )**W(k) ) * ( r(l+1) - r(l) )
      S = S + ( p(l)**W(k) ) * ( r(l+1) - r(l) )
    end do
    T = T + C(k) * S**J(k)
  end do

end subroutine HomogeneousApprox

end module atomic


module spectral_damping_mod

use        fms_mod, only: mpp_pe, mpp_root_pe, error_mesg, FATAL, &
                          write_version_number

use transforms_mod, only: get_eigen_laplacian, get_spec_domain

implicit none

private

interface compute_spectral_damping
   module procedure  compute_spectral_damping_2d, compute_spectral_damping_3d
end interface

real, allocatable, dimension(:,:) :: damping, damping_vor, damping_div, damping_eddy_sponge
real, allocatable, dimension(:)   :: damping_zmu_sponge, damping_zmv_sponge
logical :: module_is_initialized = .false.
integer :: ms, me, ns, ne, num_levels

character(len=128), parameter :: version = '$Id: spectral_damping.f90,v 13.0 2006/03/28 21:18:04 fms Exp $'
character(len=128), parameter :: tagname = '$Name: latest $'

public :: spectral_damping_init, spectral_damping_end, compute_spectral_damping
public :: compute_spectral_damping_vor, compute_spectral_damping_div

contains
!----------------------------------------------------------------------------------------------------------------
subroutine spectral_damping_init (damping_coeff, damping_order, damping_option, num_fourier, num_spherical, &
                                  num_levels_in, eddy_sponge_coeff, zmu_sponge_coeff, zmv_sponge_coeff,     &
                                  damping_coeff_vor, damping_order_vor, damping_coeff_div, damping_order_div)

real,    intent(in) :: damping_coeff
integer, intent(in) :: damping_order, num_fourier, num_spherical, num_levels_in
real,    intent(in) :: eddy_sponge_coeff, zmu_sponge_coeff, zmv_sponge_coeff
character(len=*), intent(in) :: damping_option
real,    intent(in), optional :: damping_coeff_vor, damping_coeff_div
integer, intent(in), optional :: damping_order_vor, damping_order_div

real    :: damping_coeff_vor_local, damping_coeff_div_local
integer :: damping_order_vor_local, damping_order_div_local
real, dimension(0:num_fourier, 0:num_spherical) :: eigen

if(module_is_initialized) return

call write_version_number(version, tagname)
num_levels = num_levels_in

call get_spec_domain(ms, me, ns, ne)

allocate(damping_zmu_sponge(0:num_spherical))
allocate(damping_zmv_sponge(0:num_spherical))
allocate(damping_eddy_sponge(0:num_fourier, 0:num_spherical))
allocate(damping    (0:num_fourier, 0:num_spherical))
allocate(damping_vor(0:num_fourier, 0:num_spherical))
allocate(damping_div(0:num_fourier, 0:num_spherical))

call get_eigen_laplacian(eigen)

if(present(damping_coeff_vor)) then
  damping_coeff_vor_local = damping_coeff_vor
else
  damping_coeff_vor_local = damping_coeff
endif

if(present(damping_coeff_div)) then
  damping_coeff_div_local = damping_coeff_div
else
  damping_coeff_div_local = damping_coeff
endif

if(present(damping_order_vor)) then
  damping_order_vor_local = damping_order_vor
else
  damping_order_vor_local = damping_order
endif

if(present(damping_order_div)) then
  damping_order_div_local = damping_order_div
else
  damping_order_div_local = damping_order
endif

if(trim(damping_option) == 'resolution_dependent') then
  damping    (:,:) = damping_coeff          *((eigen(:,:)/eigen(0,num_spherical-1))**damping_order          )
  damping_vor(:,:) = damping_coeff_vor_local*((eigen(:,:)/eigen(0,num_spherical-1))**damping_order_vor_local)
  damping_div(:,:) = damping_coeff_div_local*((eigen(:,:)/eigen(0,num_spherical-1))**damping_order_div_local)
else if(trim(damping_option) == 'resolution_independent') then
  damping    (:,:) = damping_coeff          *(eigen(:,:)**damping_order          )
  damping_vor(:,:) = damping_coeff_vor_local*(eigen(:,:)**damping_order_vor_local)
  damping_div(:,:) = damping_coeff_div_local*(eigen(:,:)**damping_order_div_local)
else
  call error_mesg('spectral_damping_init','"'//trim(damping_option)//'" is an invalid value for damping_option', FATAL)
end if
damping_zmu_sponge  =  zmu_sponge_coeff*eigen(0,:)
damping_zmv_sponge  =  zmv_sponge_coeff*eigen(0,:)
damping_eddy_sponge = eddy_sponge_coeff*eigen

module_is_initialized = .true.

return
end subroutine spectral_damping_init

!-----------------------------------------------------------------
!compute_spectral_damping_3d is local
subroutine compute_spectral_damping_3d(spec, dt_spec, current_dt)

complex, intent(in), dimension(:,:,:) :: spec
real,    intent(in) :: current_dt
complex, intent(inout), dimension (:,:,:) :: dt_spec

real, dimension(size(spec,1),size(spec,2)) :: coeff

integer :: k

if(.not.module_is_initialized) then
  call error_mesg('compute_spectral_damping','initialization of spectral_damping not performed', FATAL)
end if

coeff = 1.0/(1.0 + damping(ms:me,ns:ne)*current_dt)

do k = 1, size(spec,3)
  dt_spec(:,:,k) =   coeff(:,:) * (dt_spec(:,:,k) - damping(ms:me,ns:ne)*spec(:,:,k))
end do

return
end subroutine compute_spectral_damping_3d
!-----------------------------------------------------------------
subroutine compute_spectral_damping_vor(vor, dt_vor, current_dt)

complex, intent(in), dimension(ms:me, ns:ne, num_levels) :: vor
real,    intent(in) :: current_dt
complex, intent(inout), dimension(ms:me, ns:ne, num_levels) :: dt_vor

real, dimension(ms:me, ns:ne) :: coeff

integer :: k, m, n

if(.not.module_is_initialized) then
  call error_mesg('compute_spectral_damping_vor','initialization of spectral_damping not performed', FATAL)
end if

coeff = 1.0/(1.0 + damping_vor(ms:me,ns:ne)*current_dt)

do k = 1, size(vor,3)
  dt_vor(:,:,k) = coeff * (dt_vor(:,:,k) - damping_vor(ms:me,ns:ne)*vor(:,:,k))
end do

do n=ns,ne
  do m=ms,me
    if(m /= 0) then
      dt_vor(m,n,1) = (dt_vor(m,n,1) - damping_eddy_sponge(m,n)*vor(m,n,1))/(1. + damping_eddy_sponge(m,n)*current_dt)
    endif
  enddo
enddo

if(ms == 0) then
  do n=ns,ne
    dt_vor(0,n,1) = (dt_vor(0,n,1) - damping_zmu_sponge(n)*vor(0,n,1))/(1. + damping_zmu_sponge(n)*current_dt)
  enddo
endif

return
end subroutine compute_spectral_damping_vor
!-----------------------------------------------------------------

subroutine compute_spectral_damping_div(div, dt_div, current_dt)
complex, intent(in), dimension(ms:me, ns:ne, num_levels) :: div
real,    intent(in) :: current_dt
complex, intent(inout), dimension (ms:me, ns:ne, num_levels) :: dt_div

real, dimension(ms:me, ns:ne) :: coeff

integer :: k, m, n

if(.not.module_is_initialized) then
  call error_mesg('compute_spectral_damping_div','initialization of spectral_damping not performed', FATAL)
end if

coeff = 1.0/(1.0 + damping_div(ms:me,ns:ne)*current_dt)

do k = 1, size(div,3)
  dt_div(:,:,k) = coeff * (dt_div(:,:,k) - damping_div(ms:me,ns:ne)*div(:,:,k))
end do

do n=ns,ne
  do m=ms,me
    if(m /= 0) then
      dt_div(m,n,1) = (dt_div(m,n,1) - damping_eddy_sponge(m,n)*div(m,n,1))/(1. + damping_eddy_sponge(m,n)*current_dt)
    endif
  enddo
enddo

if(ms == 0) then
  do n=ns,ne
    dt_div(0,n,1) = (dt_div(0,n,1) - damping_zmv_sponge(n)*div(0,n,1))/(1. + damping_zmv_sponge(n)*current_dt)
  enddo
endif

return
end subroutine compute_spectral_damping_div
!-----------------------------------------------------------------
subroutine compute_spectral_damping_2d(spec, dt_spec, current_dt)

complex, intent(in), dimension(:,:) :: spec
real, intent(in) :: current_dt
complex, intent(inout), dimension(:,:) :: dt_spec

real, dimension(size(spec,1),size(spec,2)) :: coeff

if(.not.module_is_initialized) then
  call error_mesg('compute_spectral_damping','initialization of spectral_damping not performed', FATAL)
end if

coeff = 1.0/(1.0 + damping(ms:me,ns:ne)*current_dt)
dt_spec = coeff*(dt_spec - damping(ms:me,ns:ne)*spec)

return
end subroutine compute_spectral_damping_2d

!-----------------------------------------------------------------
subroutine spectral_damping_end

if(.not.module_is_initialized) return
deallocate(damping, damping_vor, damping_div)
deallocate(damping_eddy_sponge, damping_zmu_sponge, damping_zmv_sponge)
module_is_initialized = .false.

return
end subroutine spectral_damping_end
!-----------------------------------------------------------------

end module spectral_damping_mod


!> Testing diagonalization.
!! \details
!! Invoke it with the following parameters:
!!
!!   # number of processor rows
!!   # number of processor columns
!!   # block size
!!   # which diagonalizer to use (1 - QR, 2 - Divide and conquer)
!!   # file with the matrix to diagonalize
!!   # (Optional:) file with the matrix on the right hand side, if it is a
!!     generalized eigenvalue problem.
!!
!! The filess with the matrices should contain an integer number (n) in their
!! first line, indicating the dimension of the problem. Then n lines with
!! n entries should follow.
program test_diag
  use, intrinsic :: iso_fortran_env, stdout => output_unit
  use test_common_module
  use libscalapackfx_module
  implicit none

  call main()

contains

  subroutine main()
    type(blacsgrid) :: mygrid
    real(dp), allocatable :: hammtx(:,:), overmtx(:,:), eigvecs(:,:), eigvals(:)
    integer :: hamdesc(DLEN_), overdesc(DLEN_), eigvdesc(DLEN_)
    integer :: nn
    integer :: tsys1, tsys2, tcount
    real(dp) :: tcpu1, tcpu2
    character(100) :: hamfile, overfile
    logical :: overlap
    integer :: nprow, npcol, bsize, idiag
    integer :: iproc, nproc

    call getarguments(nprow, npcol, bsize, idiag, hamfile, overfile)
    overlap = len_trim(overfile) > 0

    call blacsfx_pinfo(iproc, nproc)
    if (npcol * nprow /= nproc) then
      write(stdout, *) "Incorrect number of processors:", npcol, nprow,&
          & nproc
      call blacsfx_exit(keepmpi=.false.)
      stop
    end if
    call mygrid%initgrid(nprow, npcol)
    if (mygrid%lead) then
      write(stdout, "(A,2(1X,I0))") "# processor grid:", nprow, npcol
      write(stdout, "(A,1X,I0)") "# block size:", bsize
    end if

    call readfromfile(mygrid, hamfile, bsize, bsize, hammtx, hamdesc)
    if (overlap) then
      call readfromfile(mygrid, overfile, bsize, bsize, overmtx, overdesc)
    end if

    nn = hamdesc(M_)
    if (mygrid%lead) then
      write(stdout, "(A,2(1X,I0))") "# matrix size:", nn, nn
      if (overlap) then
        write(stdout, "(A,1X,A)") "# eigenvalue problem:", "generalized"
      else
        write(stdout, "(A,1X,A)") "# eigenvalue problem:", "standard"
      end if
      write(stdout, "(A,2(1X,I0))") "# matrix size on leader:",&
          & size(hammtx, dim=1), size(hammtx, dim=2)
      select case (idiag)
      case(1)
        write(stdout, "(A)") "# diagonalization: QR"
      case(2)
        write(stdout, "(A)") "# diagonalization: DAC"
      case(3)
        write(stdout, "(A)") "# diagonalization: RRR"
      case(4)
        write(stdout, "(A)") "# diagonalization: RRR subset by index (1:3)"
      case(5)
        write(stdout, "(A)") "# diagonalization: RRR subset by value (-1.0:0.0)"
      end select

    end if

    call system_clock(tsys1, tcount)
    call cpu_time(tcpu1)

    ! Allocate matrix for eigenvectors and eigenvals
    call scalafx_creatematrix(mygrid, nn, nn, bsize, bsize, eigvecs, eigvdesc)
    allocate(eigvals(nn))

    if (overlap) then
      select case (idiag)
      case(1)
        call scalafx_psygv(hammtx, hamdesc, overmtx, overdesc, eigvals,&
            & eigvecs, eigvdesc, jobz="V", uplo="L")
      case(2)
        call scalafx_psygvd(hammtx, hamdesc, overmtx, overdesc,&
            & eigvals, eigvecs, eigvdesc, jobz="V", uplo="L", &
            & allocfix=.true.)
      case(3)
        call scalafx_psygvr(hammtx, hamdesc, overmtx, overdesc, &
            & eigvals, eigvecs, eigvdesc, jobz="V", uplo="L")
      case(4)
        call scalafx_psygvr(hammtx, hamdesc, overmtx, overdesc, &
            & eigvals, eigvecs, eigvdesc, iu=3, jobz="V", uplo="L")
      case(5)
        call scalafx_psygvr(hammtx, hamdesc, overmtx, overdesc, &
            & eigvals, eigvecs, eigvdesc, vl=-1.0_dp, vu=0.0_dp, jobz="V", &
            & uplo="L")
      end select
    else
      select case (idiag)
      case(1)
        call scalafx_psyev(hammtx, hamdesc, eigvals, eigvecs, eigvdesc,&
            & jobz="V", uplo="L")
      case(2)
        call scalafx_psyevd(hammtx, hamdesc, eigvals, eigvecs,&
            & eigvdesc, jobz="V", uplo="L", allocfix=.true.)
      case(3)
        call scalafx_psyevr(hammtx, hamdesc, eigvals, eigvecs, &
            & eigvdesc, jobz="V", uplo="L")
      case(4)
        call scalafx_psyevr(hammtx, hamdesc, eigvals, eigvecs, &
            & eigvdesc, iu=3, jobz="V", uplo="L")
      case(5)
        call scalafx_psyevr(hammtx, hamdesc, eigvals, eigvecs, &
            & eigvdesc, vl=-1.0_dp, vu=0.0_dp, jobz="V", uplo="L")
      end select
    end if

    call cpu_time(tcpu2)
    call system_clock(tsys2)

    if (mygrid%lead) then
      write(stdout, "(A,F8.1)") "# cpu time on leader:", tcpu2 - tcpu1
      write(stdout, "(A,F8.1)") "# system time on leader:",&
          & real(tsys2 - tsys1, dp) / real(tcount, dp)
    end if

    ! Write eigenvalues and eigenvectors
    if (mygrid%lead) then
      open(12, file="eigvals.dat", form="formatted", status="replace")
      write(12, "(ES23.15)") eigvals
      close(12)
      write(stdout, "(A,A,A)") "# Eigenvalues written to '", "eigvals.dat", "'"
    end if
    call writetofile(mygrid, "eigvecs.dat", eigvecs, eigvdesc)
    if (mygrid%lead) then
      write(stdout, "(A,A,A)") "# Eigenvectors written to '", "eigvecs.dat", "'"
    end if

    ! Destroy blacs communication layer.
    call blacsfx_exit()

  end subroutine main

  !> Process command line arguments.
  subroutine getarguments(nprow, npcol, bsize, idiag, hamfile, overfile)
    integer, intent(out) :: npcol, nprow, bsize, idiag
    character(*), intent(out) :: hamfile, overfile

    integer :: narg
    character(128) :: buffer

    narg = command_argument_count()
    if (narg /= 6 .and. narg /= 5) then
      write(stdout, *) "Incorrect number of arguments"
      write(stdout, *) "Need: nprow npcol bsize idiag hamiltonian [ overlap ]"
      stop
    end if
    call get_command_argument(1, buffer)
    read(buffer, *) nprow
    call get_command_argument(2, buffer)
    read(buffer, *) npcol
    call get_command_argument(3, buffer)
    read(buffer, *) bsize
    call get_command_argument(4, buffer)
    read(buffer, *) idiag
    if (.not. any([ 1, 2, 3, 4, 5 ] == idiag)) then
      stop "idiag must between 1 and 5."
    end if
    call get_command_argument(5, hamfile)
    if (narg == 6) then
      call get_command_argument(6, overfile)
    else
      overfile = ""
    end if

  end subroutine getarguments

end program test_diag


! This file (box_spline_basis.f95) contains the module
! box_spline_basis that declares the subroutines (compute_boxes,
! evaluate_boxes) for generating and evaluating a box spline hypercube
! basis model for continuous multidimensional (d<=20) data with real
! response values.

! The following LAPACK routines are used:
!    + DGELS

! compute_boxes(x_data, response, boxes, widths, weights)
!   x_data   -- matrix of n-dimensions by m-data points (nxm) stored as
!               column vectors. x_data(:,1) should be the first point.
!   response -- array of length "m" holding response values at each x-point
!   boxes    -- matrix of n-dimensions by p-boxes (nxp), will be
!               overwritten with the output boxes
!   widths   -- array of length "p" holding the width of each box
!   weights  -- array of length "p" holding the weight for each box function

MODULE max_box
  USE ISO_FORTRAN_ENV, ONLY: REAL64
  IMPLICIT NONE

CONTAINS
  ! Subroutine for computing the max-box around given points
  !  where the max-box is the box defined by a center, lower, and
  !  upper widths such that MIN(lower,upper) is maximized
  SUBROUTINE max_boxes(pts, box_widths)
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: pts
    ! Column vectors of points
    REAL(KIND=REAL64), INTENT(OUT), &
         DIMENSION(2*UBOUND(pts,1),UBOUND(pts,2)) :: box_widths
    ! Holder for the upper and lower widths surrounding each point
    REAL(KIND=REAL64), DIMENSION(UBOUND(pts,2)) :: distances
    ! Distances between points
    INTEGER, DIMENSION(UBOUND(pts,2)) :: distance_indices
    ! Indices of distances (for use in sorting)
    LOGICAL, DIMENSION(UBOUND(pts,1)) :: in_lower, in_upper
    ! Holder for checking if a point is inside of a box
    INTEGER :: step, dim, idx, other_pt_idx, other_pt
    ! Miscellaneous integers for stepping

    ! Initialize all box widths to be 'undefined'
    box_widths= -1.0_REAL64
    ! Iterate over box centers (points)
    compute_box_shapes : DO step = 1,UBOUND(pts,2)
       ! Find the infinity norm distances to each other point
       linf_distances : DO CONCURRENT (idx = 1: UBOUND(pts,2))
          distances(idx) = MAXVAL(ABS(pts(:,idx) - pts(:,step)))
       END DO linf_distances
       ! Sort the Linf distances between pts
       CALL QSORTC(distances, distance_indices)
       ! Identify the max-Linf-width bounding rectangle
       calculate_box_width : DO other_pt = 1, UBOUND(pts,2)
          other_pt_idx = distance_indices(other_pt)
          ! Don't try to use the current box center as a boundary
          IF (other_pt_idx .EQ. step) CYCLE
          ! Logical testing if a point is inside a box:
          !  -- lower width undefined .OR. (box - other) < lower width
          in_lower = (box_widths(:UBOUND(pts,1),step) .LT. 0.0_REAL64) .OR. &
               (pts(:,step)-pts(:,other_pt_idx) .LT. box_widths(:UBOUND(pts,1),step))
          !  -- upper width undefined .OR. (other - box) < upper width
          in_upper = (box_widths(UBOUND(pts,1)+1:,step) .LT. 0.0_REAL64) .OR. &
               (pts(:,other_pt_idx)-pts(:,step) .LT. box_widths(UBOUND(pts,1)+1:,step))
          ! If all conditions are satisfied, the point is in the box
          IF (ALL(in_lower .AND. in_upper)) THEN
             ! Find the dimension of max magnitude (Linf) difference
             dim = MAXLOC(ABS(pts(:,other_pt_idx) - pts(:,step)),1)
             ! Check if we are adjusting the upper or lower width of
             ! the box, and adjust the boundary for this point
             IF (pts(dim,step) .GT. pts(dim,other_pt_idx)) THEN
                box_widths(dim,step) = &
                     pts(dim,step) - pts(dim,other_pt_idx)
             ELSE
                box_widths(dim+UBOUND(pts,1),step) = &
                     pts(dim,other_pt_idx) - pts(dim,step)
             END IF
          END IF
       END DO calculate_box_width
    END DO compute_box_shapes
  END SUBROUTINE max_boxes

  ! Given computed boxe-pts, box_widths, and box_values, compute the
  ! values associated with a new set of pts
  SUBROUTINE linear_eval(boxes, box_widths, box_values, pts, values, error)
    ! Box point coordinates
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:,:)             :: boxes
    ! Lower and upper widths of each box along each dimension
    REAL(KIND=REAL64), INTENT(IN), &
         DIMENSION(2*UBOUND(boxes,1),UBOUND(boxes,2))     :: box_widths
    ! The values associated with each of the box points
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(UBOUND(boxes,2)) :: box_values
    ! The new points to evaluate the max-box-mesh at
    REAL(KIND=REAL64), INTENT(IN), DIMENSION(:,:)             :: pts
    ! The holder for returning the values at each of the new points
    REAL(KIND=REAL64), INTENT(OUT), DIMENSION(UBOUND(pts,2))  :: values
    INTEGER(KIND=8), INTENT(OUT)                          :: error
    ! Local variables for evaluating all of the boxes
    INTEGER :: pt_num, box_num, dim
    REAL(KIND=REAL64) :: val, divisor
    REAL(KIND=REAL64), DIMENSION(UBOUND(boxes,1)) :: shifted_box
    ! Initialize all values to be zero (we'll add box evluations)
    error = 0
    values = 0.0_REAL64
    ! Compute the linear box evaluation for each cube
    pt_evals : DO pt_num = 1,UBOUND(pts,2)
       divisor = 0.0_REAL64
       box_evals : DO box_num = 1,UBOUND(boxes,2)
          ! Calculate the normalized distance from center of this box,
          ! that is shifted_box in the range [0,1) is inside the box.
          normal_box : DO dim = 1,UBOUND(boxes,1)
             ! If the box-point is greater than the x-point in <dim>
             IF (boxes(dim,box_num) .GT. pts(dim,pt_num)) THEN
                ! Then divide by the lower width
                shifted_box(dim) = (boxes(dim,box_num) - &
                     pts(dim,pt_num)) / box_widths(dim,box_num)
             ELSE
                ! Else divide by the upper width
                shifted_box(dim) = (pts(dim,pt_num) - &
                     boxes(dim,box_num)) / &
                     box_widths(UBOUND(boxes,1)+dim,box_num)
             END IF
             ! Consider the special case of an undefined box-width
             ! (this manifests as a width of "-1") Consider this to be
             ! a point aligned with the center of the box.
             IF (shifted_box(dim) .LT. 0.0_REAL64) shifted_box(dim) = 0.0_REAL64
          END DO normal_box

          ! ASSERT: "shifted_box" is now the shifted x-coordinate
          !         relative to boxes(:,box_num), normalized coordinates

          ! HERE is where we would use CALL non-linear-func(shifted_box)
          ! Store the evaluation of this box for this x-data point
          val = PRODUCT( MAX(1.0_REAL64 - shifted_box, 0.0_REAL64) )
          values(pt_num) = values(pt_num) + val * box_values(box_num)
          divisor = divisor + val

       END DO box_evals
       ! Calculate the final value for all points (NURBS style approach)
       IF (divisor .GT. 0.0_REAL64) THEN
          values(pt_num) = values(pt_num) / divisor
       ELSE
          PRINT *, 'ERROR: Point', pt_num, 'out of range of all boxes.', pts(:,pt_num)
          PRINT *, '   value   --', values(pt_num)
          PRINT *, '   divisor --', divisor
          error = pt_num
          EXIT pt_evals
       END IF
    END DO pt_evals
  END SUBROUTINE linear_eval

  SUBROUTINE QSORTC(A, IDX)
    ! This is a QuickSort routine adapted from Orderpack 2.0.
    !
    ! Also, this implementation incorporates ideas from "A Practical Introduction
    ! to Data Structures and Algorithm Analysis", by Clifford Shaffer.
    !
    ! It sorts real numbers into ascending numerical order
    ! and keeps an index of the value's original array position.
    !
    ! Author: Will Thacker, Winthrop University, July 2013.
    !
    ! QSORTC sorts the real array A and keeps the index of the value's
    ! original array position along with the value (integer array IDX).
    !
    ! On input:
    !
    ! A(:) is the array to be sorted.
    !
    ! On output:
    !
    ! A(:) is sorted.
    !
    ! IDX(1:SIZEOF(A)) contains the original positions of the sorted values.
    !    I.e., sorted(i) = orginal_unsorted(IDX(i)).
    !
    !
    REAL(KIND=REAL64), DIMENSION(:), INTENT(IN OUT):: A
    INTEGER, DIMENSION(SIZE(A)), INTENT(OUT):: IDX

    ! Local variables

    INTEGER:: I   ! Loop iteration variable.

    ! Initialize the array of original positions.
    DO CONCURRENT (I=1:SIZE(A)); IDX(I)=I; END DO

    CALL QSORTC_HELPER(A, IDX, 1, SIZE(A))
    RETURN

  CONTAINS
    RECURSIVE SUBROUTINE QSORTC_HELPER(A, IDX, ISTART, ISTOP)
      ! This internal recursive subroutine performs the recursive quicksort
      ! algorithm.  It is needed because the boundaries of the part of the
      ! array being sorted change and the initial call to the sort routine
      ! does not need to specify boundaries since, generally, the user will
      ! want to sort the entire array passed.
      !
      ! On input:
      !
      ! A(:) contains a subpart to be sorted.
      !
      ! IDX(i) contains the initial position of the value A(i) before sorting.
      !
      ! ISTART is the starting position of the subarray to be sorted.
      !
      ! ISTOP is the ending position of the subarray to be sorted.
      !
      ! On output:
      !
      ! A(ISTART:ISTOP) will be sorted.
      !
      ! IDX(i) contains the original position for the value at A(i).
      !
      !
      REAL(KIND=REAL64), DIMENSION(:), INTENT (IN OUT):: A
      INTEGER, DIMENSION(SIZE(A)), INTENT(IN OUT):: IDX
      INTEGER, INTENT(IN):: ISTART, ISTOP

      !  Local variables
      INTEGER:: ILEFT ! A position on the left to be swapped with value at IRIGHT.
      INTEGER:: IMID ! The middle position used to select the pivot.
      INTEGER:: IRIGHT ! A position on the right to be swapped with value at ILEFT.
      INTEGER:: ITEMP  ! Used for swapping within IDX.
      REAL(KIND=REAL64):: ATEMP ! Used for swapping.
      REAL(KIND=REAL64):: PIVOT ! Holds the temporary pivot.

      ! INSMAX is used to stop recursively dividing the array and to instead
      ! use a sort that is more efficient for small arrays than quicksort.
      !
      ! The best cutoff point is system dependent.

      INTEGER, PARAMETER:: INSMAX=24

      ! Check to see if we have enough values to make quicksort useful.
      ! Otherwise let the insertion sort handle it.

      IF ((ISTOP - ISTART) < INSMAX) THEN
         CALL INSERTION(A, IDX, ISTART, ISTOP)
      ELSE

         ! Use the median of the first, middle and last items for the pivot
         ! and place the median (pivot) at the end of the list.
         ! Putting it at the end of the list allows for a guard value to keep
         ! the loop from falling off the right end of the array (no need to
         ! check for at the end of the subarray EACH time through the loop).

         IMID = (ISTART + ISTOP)/2

         IF (A(ISTOP) < A(ISTART)) THEN
            ATEMP = A(ISTART)
            A(ISTART) = A(ISTOP)
            A(ISTOP) = ATEMP

            ITEMP = IDX(ISTART)
            IDX(ISTART) = IDX(ISTOP)
            IDX(ISTOP) = ITEMP
         END IF

         IF (A(IMID) < A(ISTOP)) THEN
            ATEMP = A(ISTOP)
            A(ISTOP) = A(IMID)
            A(IMID) = ATEMP

            ITEMP = IDX(ISTOP)
            IDX(ISTOP) = IDX(IMID)
            IDX(IMID) = ITEMP

            IF (A(ISTOP) < A(ISTART)) THEN
               ATEMP = A(ISTOP)
               A(ISTOP) = A(ISTART)
               A(ISTART) = ATEMP

               ITEMP = IDX(ISTOP)
               IDX(ISTOP) = IDX(ISTART)
               IDX(ISTART) = ITEMP
            END IF
         END IF

         ! Now, the first position has a value that is less or equal to the
         ! partition. So, we know it belongs in the left side of the partition
         ! and we can skip it. Also, the pivot is at the end.  So, there is
         ! no need to compare the pivot with itself.

         PIVOT = A(ISTOP)
         ILEFT = ISTART + 1
         IRIGHT = ISTOP - 1

         DO WHILE (ILEFT < IRIGHT)
            ! Find a value in the left side that is bigger than the pivot value.
            ! Pivot is at the right end so ILEFT will not fall off the end
            ! of the subarray.

            DO WHILE (A(ILEFT) < PIVOT)
               ILEFT = ILEFT + 1
            END DO

            DO WHILE (IRIGHT .NE. ILEFT)
               IF (A(IRIGHT) .LT. PIVOT) EXIT
               IRIGHT = IRIGHT - 1
            END DO

            ! Now we have a value bigger than pivot value on the left side that can be
            ! swapped with a value smaller than the pivot on the right side.
            !
            ! This gives us all values less than pivot on the left side of the
            ! array and all values greater than the pivot on the right side.

            ATEMP = A(IRIGHT)
            A(IRIGHT) = A(ILEFT)
            A(ILEFT) = ATEMP

            ITEMP = IDX(IRIGHT)
            IDX(IRIGHT) = IDX(ILEFT)
            IDX(ILEFT) = ITEMP

         END DO
         !
         ! The last swap was in error (since the while condition is not checked
         ! until after the swap is done) so we swap again to fix it.

         ! This is done (once) rather than having an if (done many times) in the
         ! loop to prevent the swapping.

         ATEMP = A(IRIGHT)
         A(IRIGHT) = A(ILEFT)
         A(ILEFT) = ATEMP

         ITEMP = IDX(IRIGHT)
         IDX(IRIGHT) = IDX(ILEFT)
         IDX(ILEFT) = ITEMP

         ! Put the pivot value in its correct spot (between the 2 partitions)
         ! When the WHILE condition finishes, ILEFT is greater than IRIGHT.
         ! So, ILEFT has the position of the first value in the right side.
         ! This is where we can put the pivot (and where it will finally rest,
         ! so no need to look at it again).  Also, place the first value of
         ! the right side (being displaced by the pivot) at the end of the
         ! subarray (since it is bigger than the pivot).

         ATEMP = A(ISTOP)
         A(ISTOP) = A(ILEFT)
         A(ILEFT) = ATEMP

         ITEMP = IDX(ISTOP)
         IDX(ISTOP) = IDX(ILEFT)
         IDX(ILEFT) = ITEMP

         CALL QSORTC_HELPER(A, IDX, ISTART, ILEFT-1)
         CALL QSORTC_HELPER(A, IDX, ILEFT+1, ISTOP)
      END IF

    END SUBROUTINE QSORTC_HELPER

    SUBROUTINE INSERTION(A, IDX, ISTART, ISTOP)
      ! This subroutine performs an insertion sort used for sorting
      ! small subarrays efficiently.
      !
      ! This subroutine sorts a subarray of A (between positions ISTART
      ! and ISTOP) keeping a record of the original position (array IDX).

      ! On input:
      !
      ! A(:) contains a subpart to be sorted.
      !
      ! IDX(i) contains the initial position of the value A(i) before sorting.
      !
      ! ISTART is the starting position of the subarray to be sorted.
      !
      ! ISTOP is the ending position of the subarray to be sorted.
      !
      ! On output:
      !
      ! A(ISTART:ISTOP) will be sorted.
      !
      ! IDX(i) contains the original position for the value at A(i).
      !

      REAL(KIND=REAL64), DIMENSION(:), INTENT (IN OUT):: A
      INTEGER, DIMENSION(SIZE(A)), INTENT(IN OUT)::IDX
      INTEGER, INTENT(IN):: ISTART, ISTOP

      ! Local variables.

      REAL(KIND=REAL64):: AMIN  ! Temporary minimum.
      REAL(KIND=REAL64):: ATEMP  ! The value to be inserted.
      INTEGER:: I    ! Index variable.
      INTEGER:: IABOVE ! Index to find insertion point.
      INTEGER:: IMIN ! Temporary minimum position.
      INTEGER:: ITEMP ! Temporary for swapping.

      IF (ISTOP .EQ. ISTART) THEN
         RETURN
      END IF

      ! Find the smallest and put it at the top as a "guard" so there is
      ! no need for the DO WHILE to check if it is going past the top.

      AMIN = A(ISTART)
      IMIN = ISTART

      DO I=ISTOP,ISTART+1,-1
         IF (A(I) < AMIN) THEN
            AMIN = A(I)
            IMIN = I
         END IF
      END DO

      A(IMIN) = A(ISTART)
      A(ISTART) = AMIN

      ITEMP = IDX(ISTART)
      IDX(ISTART) = IDX(IMIN)
      IDX(IMIN) = ITEMP

      ! Insertion sort the rest of the array.
      DO I=ISTART+2,ISTOP
         ATEMP = A(I)
         ITEMP = IDX(I)
         IABOVE = I - 1
         IF (ATEMP < A(IABOVE)) THEN
            A(I) = A(IABOVE)
            IDX(I) = IDX(IABOVE)
            IABOVE = IABOVE - 1

            ! Stop moving items down when the position for "insertion" is found.
            !
            ! Do not have to check for "falling off" the beginning of the
            ! array since the smallest value is a guard value in the first position.

            DO WHILE (ATEMP < A(IABOVE))
               A(IABOVE+1) = A(IABOVE)
               IDX(IABOVE+1) = IDX(IABOVE)
               IABOVE = IABOVE - 1
            END DO
         END IF
         A(IABOVE+1) = ATEMP
         IDX(IABOVE+1) = ITEMP
      END DO
    END SUBROUTINE INSERTION
  END SUBROUTINE QSORTC

END MODULE max_box


      SUBROUTINE PCSHFT(A,B,D,N)
      DIMENSION D(N)
      CONST=2./(B-A)
      FAC=CONST
      DO 11 J=2,N
        D(J)=D(J)*FAC
        FAC=FAC*CONST
11    CONTINUE
      CONST=0.5*(A+B)
      DO 13 J=1,N-1
        DO 12 K=N-1,J,-1
          D(K)=D(K)-CONST*D(K+1)
12      CONTINUE
13    CONTINUE
      RETURN
      END