! gfortran -03 -I$SHTOOLSMODPATH_GCC -L$SHTOOLSLIBPATH_GCC -L$FFTW3_LIB_DIR_GCC -lSHTOOLS2.8 -llapack -lblas -lfftw3 -lm TEST_RESULTS.f90 -o TEST_RESULTS

PROGRAM TEST_RESULTS
	USE SHTOOLS

	REAL*8   ::  DAT(181,361)
	REAL*8   ::  CILM(2,10,10)
	integer  ::  SH_LMAX, I, J

	OPEN(34, FILE="/Users/dchandan/Volumes/Elysium/Data1/CommonData/Dynamic_topography/C2E5/dyntopoC2E5_l1-22.txt", STATUS="OLD")
	DO I= 1,181
		READ(34, *) DAT(I,:)
	ENDDO
	CLOSE(34)

	OPEN(34, FILE="FieldRead.txt", STATUS="REPLACE")
	DO I=1,181
		WRITE(34, *) DAT(I,:)
	ENDDO
	CLOSE(34)

	OPEN(34, FILE="Coeffs.txt", STATUS="REPLACE")
	CALL SHExpandDH(DAT(1:180,1:360), 180, CILM, LMAX=SH_LMAX, NORM=4, SAMPLING=2, LMAX_CALC=9)
	DO I =1,10
		WRITE(34, '(10F6.3)') CILM(1,I,:)
	ENDDO
	CLOSE(34)

END PROGRAM TEST_RESULTS


c
c
c ... file rgrd3.f
c
c     this file contains documentation for subroutine rgrd3 followed by
c     fortran code for rgrd3 and additional subroutines.
c
c ... author
c
c     John C. Adams (NCAR 1999)
c
c ... subroutine rgrd3(nx,ny,nz,x,y,z,p,mx,my,mz,xx,yy,zz,q,intpol,
c    +                 w,lw,iw,liw,ier)
c
c ... purpose
c
c     subroutine rgrd3 interpolates the values p(i,j,k) on the orthogonal
c     grid (x(i),y(j),z(k)) for i=1,...,nx; j=1,...,ny; k=1,...,nz
c     onto q(ii,jj,kk) on the orthogonal grid (xx(ii),yy(jj),zz(kk)) for
c     ii=1,...,mx; jj=1,...,my; kk=1,...,mz.
c
c ... language
c
c     coded in portable FORTRAN77 and FORTRAN90
c
c ... test program
c
c     file trgrd3.f on regridpack includes a test program for subroutine rgrd3
c
c ... method
c
c     linear or cubic interpolation is used (independently) in
c     each direction (see argument intpol).
c
c ... required files
c
c     files rgrd2.f and rgrd1.f must be loaded with rgrd3.f.  they
c     include subroutines called by the routines in rgrd3.f
c
c ... requirements
c
c     each of the x,y,z grids must be strictly montonically increasing
c     and each of the xx,yy,zz grids must be montonically increasing
c     (see ier = 4).  in addition the (X,Y,Z) region
c
c          [xx(1),xx(mx)] X [yy(1),yy(my)] X [zz(1),zz(mz)]
c
c     must lie within the (X,Y,Z) region
c
c          [x(1),x(nx)] X [y(1),y(ny)] X [z(1),z(nz)].
c
c     extrapolation is not allowed (see ier=3).  if these (X,Y,Z)
c     regions are identical and the orthogonal grids are UNIFORM
c     in each direction then subroutine rgrd3u (see file rgrd3u.f)
c     should be used instead of rgrd3.
c
c ... efficiency
c
c     inner most loops in regridpack software vectorize.  if
c     the integer arguments mx,my,mz (see below) have different values,
c     optimal vectorization will be achieved if mx > my > mz.
c
c *** input arguments
c
c ... nx
c
c     the integer dimension of the grid vector x and the first dimension of p.
c     nx > 1 if intpol(1) = 1 or nx > 3 if intpol(1) = 3 is required.
c
c ... ny
c
c     the integer dimension of the grid vector y and the second dimension of p.
c     ny > 1 if intpol(2) = 1 or ny > 3 if intpol(2) = 3 is required.
c
c ... nz
c
c     the integer dimension of the grid vector z and the third dimension of p.
c     nz > 1 if intpol(3) = 1 or nz > 3 if intpol(3) = 3 is required.
c
c ... x
c
c     a real nx vector of strictly increasing values which defines the x
c     portion of the orthogonal grid on which p is given
c
c ... y
c
c     a real ny vector of strictly increasing values which defines the y
c     portion of the orthogonal grid on which p is given
c
c ... z
c
c     a real nz vector of strictly increasing values which defines the z
c     portion of the orthogonal grid on which p is given
c
c ... p
c
c     a real nx by ny by nz array of values given on the (x,y,z) grid
c
c ... mx
c
c     the integer dimension of the grid vector xx and the first dimension of q.
c     mx > 0 is required.
c
c ... my
c
c     the integer dimension of the grid vector yy and the second dimension of q.
c     my > 0 is required.
c
c ... mz
c
c     the integer dimension of the grid vector zz and the third dimension of q.
c     mz > 0 is required.
c
c ... xx
c
c     a real mx vector of increasing values which defines the x portion of the
c     orthogonal grid on which q is defined.  xx(1) < x(1) or xx(mx) > x(nx)
c     is not allowed (see ier = 3)
c
c ... yy
c
c     a real my vector of increasing values which defines the y portion of the
c     orthogonal grid on which q is defined.  yy(1) < y(1) or yy(my) > y(ny)
c     is not allowed (see ier = 3)
c
c ... zz
c
c     a real mz vector of increasing values which defines the z portion of the
c     orthogonal grid on which q is defined.  zz(1) < z(1) or zz(mz) > z(nz)
c     is not allowed (see ier = 3)
c
c ... intpol
c
c     an integer vector of dimension 3 which sets linear or cubic
c     interpolation in each of the x,y,z directions as follows:
c
c        intpol(1) = 1 sets linear interpolation in the x direction
c        intpol(1) = 3 sets cubic interpolation in the x direction.
c
c        intpol(2) = 1 sets linear interpolation in the y direction
c        intpol(2) = 3 sets cubic interpolation in the y direction.
c
c        intpol(3) = 1 sets linear interpolation in the z direction
c        intpol(3) = 3 sets cubic interpolation in the z direction.
c
c     values other than 1 or 3 in intpol are not allowed (ier = 5).
c
c ... w
c
c     a real work space of length at least lw which must be provided in the
c     routine calling rgrd3
c
c
c ... lw
c
c     the integer length of the real work space w.  let
c
c          lwx =   mx            if intpol(1) = 1
c          lwx = 4*mx            if intpol(1) = 3
c
c          lwy = my+2*mx         if intpol(2) = 1
c          lwy = 4*(mx+my)       if intpol(2) = 3
c
c          lwz = 2*mx*my+mz      if intpol(3) = 1
c          lwz = 4*(mx*my+mz)    if intpol(3) = 3
c
c     then lw must be greater than or equal to lwx+lwy+lwz
c
c ... iw
c
c     an integer work space of length at least liw which must be provided in the
c     routine calling rgrd3
c
c ... liw
c
c     the integer length of the integer work space iw.  liw must be at least mx+my+mz
c
c *** output arguments
c
c
c ... q
c
c     a real mx by my by mz array of values on the (xx,yy,zz) grid which are
c     interpolated from p on the (x,y,z) grid
c
c ... ier
c
c     an integer error flag set as follows:
c
c     ier = 0 if no errors in input arguments are detected
c
c     ier = 1 if  min0(mx,my,mz) < 1
c
c     ier = 2 if nx < 2 when intpol(1)=1 or nx < 4 when intpol(1)=3 (or)
c                ny < 2 when intpol(2)=1 or ny < 4 when intpol(2)=3 (or)
c                nz < 2 when intpol(3)=1 or nz < 4 when intpol(3)=3.
c
c     ier = 3 if xx(1) < x(1) or x(nx) < xx(mx) (or)
c                yy(1) < y(1) or y(ny) < yy(my) (or)
c                zz(1) < z(1) or z(nz) < zz(mz)
c
c *** to avoid this flag when end points are intended to be the
c     same but may differ slightly due to roundoff error, they
c     should be set exactly in the calling routine (e.g., if both
c     grids have the same y boundaries then yy(1)=y(1) and yy(my)=y(ny)
c     should be set before calling rgrd3)
c
c     ier = 4 if one of the grids x,y,z is not strictly monotonically
c             increasing or if one of the grids xx,yy,zz is not
c             montonically increasing.  more precisely if:
c
c             x(i+1) <= x(i) for some i such that 1 <= i < nx (or)
c
c             y(j+1) <= y(j) for some j such that 1 <= j < ny (or)
c
c             z(k+1) <= z(k) for some k such that 1 <= k < nz (or)
c
c             xx(ii+1) < xx(ii) for some ii such that 1 <= ii < mx (or)
c
c             yy(jj+1) < yy(jj) for some jj such that 1 <= jj < my (or)
c
c             zz(kk+1) < zz(k)  for some kk such that 1 <= kk < mz
c
c     ier = 5 if lw or liw is too small (insufficient work space)
c
c     ier = 6 if any of intpol(1),intpol(2),intpol(3) is not equal to 1 or 3
c
c ************************************************************************
c
c     end of rgrd3 documentation, fortran code follows:
c
c ************************************************************************
c
      subroutine rgrd3(nx,ny,nz,x,y,z,p,mx,my,mz,xx,yy,zz,q,intpol,
     +                 w,lw,iw,liw,ier)
      implicit none
      integer nx,ny,nz,mx,my,mz,lw,liw,ier
      integer lwx,lwy,lwz,jy,kz,mxmy
      real x(nx),y(ny),z(nz),p(nx,ny,nz)
      real xx(mx),yy(my),zz(mz),q(mx,my,mz)
      real w(lw)
      integer intpol(3),iw(liw)
      integer i,ii,j,jj,k,kk
      integer i2,i3,i4,i5
      integer j2,j3,j4,j5,j6,j7,j8,j9
      integer k2,k3,k4,k5,k6,k7,k8,k9
c
c     check input arguments
c
      ier = 1
c
c     check (xx,yy,zz) grid resolution
c
      if (min0(mx,my,mz) .lt. 1) return
c
c     check intpol
c
      ier = 6
      if (intpol(1).ne.1 .and. intpol(1).ne.3) return
      if (intpol(2).ne.1 .and. intpol(2).ne.3) return
      if (intpol(3).ne.1 .and. intpol(3).ne.3) return
c
c     check (x,y,z) grid resolution
c
      ier = 2
      if (intpol(1).eq.1 .and. nx.lt.2) return
      if (intpol(1).eq.3 .and. nx.lt.4) return
      if (intpol(2).eq.1 .and. ny.lt.2) return
      if (intpol(2).eq.3 .and. ny.lt.4) return
      if (intpol(3).eq.1 .and. nz.lt.2) return
      if (intpol(3).eq.3 .and. nz.lt.4) return
c
c     check work space length input and set minimum
c
      ier = 5
      mxmy = mx*my
      if (intpol(1).eq.1) then
	lwx = mx
      else
	lwx = 4*mx
      end if
      if (intpol(2).eq.1) then
	lwy = (my+2*mx)
      else
	lwy = 4*(my+mx)
      end if
      if (intpol(3).eq.1) then
	lwz = (2*mxmy+mz)
      else
	lwz = 4*(mxmy+mz)
      end if
      if (lw .lt. lwx+lwy+lwz) return
      if (liw .lt. mx+my+mz) return
c
c     check (xx,yy,zz) grid contained in (x,y,z) grid
c
      ier = 3
      if (xx(1).lt.x(1) .or. xx(mx).gt.x(nx)) return
      if (yy(1).lt.y(1) .or. yy(my).gt.y(ny)) return
      if (zz(1).lt.z(1) .or. zz(mz).gt.z(nz)) return
c
c     check montonicity of grids
c
      ier = 4
      do i=2,nx
	if (x(i-1).ge.x(i)) return
      end do
      do j=2,ny
	if (y(j-1).ge.y(j)) return
      end do
      do k=2,nz
	if (z(k-1).ge.z(k)) return
      end do
      do ii=2,mx
	if (xx(ii-1).gt.xx(ii)) return
      end do
      do jj=2,my
	if (yy(jj-1).gt.yy(jj)) return
      end do
      do kk=2,mz
	if (zz(kk-1).gt.zz(kk)) return
      end do
c
c     arguments o.k.
c
      ier = 0
      jy = mx+1
      kz = mx+my+1
      if (intpol(3).eq.1) then
c
c     linearly interpolate in nz, set work space pointers and scales
c
	k2 = 1
	k3 = k2
	k4 = k3+mz
	k5 = k4
	k6 = k5
	k7 = k6
	k8 = k7+mxmy
	k9 = k8+mxmy
	call linmx(nz,z,mz,zz,iw(kz),w(k3))
	j2 = k9
c
c     set indices and scales which depend on y interpolation
c
	if (intpol(2) .eq. 1) then
c     linear in y
	  j3 = j2
	  j4 = j3+my
	  j5 = j4
	  j6 = j5
	  j7 = j6
	  j8 = j7+mx
	  j9 = j8+mx
	  call linmx(ny,y,my,yy,iw(jy),w(j3))
	  i2 = j9
	else
c     cubic in y
	  j3 = j2+my
	  j4 = j3+my
	  j5 = j4+my
	  j6 = j5+my
	  j7 = j6+mx
	  j8 = j7+mx
	  j9 = j8+mx
	  call cubnmx(ny,y,my,yy,iw(jy),w(j2),w(j3),w(j4),w(j5))
	  i2 = j9+mx
	end if
c
c     set indices and scales which depend on x interpolation
c
	if (intpol(1) .eq. 1) then
c     linear in x
	  i3 = i2
	  i4 = i3
	  i5 = i4
	  call linmx(nx,x,mx,xx,iw,w(i3))
	else
c     cubic in x
	  i3 = i2+mx
	  i4 = i3+mx
	  i5 = i4+mx
	  call cubnmx(nx,x,mx,xx,iw,w(i2),w(i3),w(i4),w(i5))
	end if
	call lint3(nx,ny,nz,p,mx,my,mxmy,mz,q,intpol,iw(kz),
     +  w(k3),w(k7),w(k8),iw(jy),w(j2),w(j3),w(j4),w(j5),w(j6),
     +  w(j7),w(j8),w(j9),iw,w(i2),w(i3),w(i4),w(i5))
	return
      else
c
c     cubically interpolate in z
c
	k2 = 1
	k3 = k2+mz
	k4 = k3+mz
	k5 = k4+mz
	k6 = k5+mz
	k7 = k6+mxmy
	k8 = k7+mxmy
	k9 = k8+mxmy
	call cubnmx(nz,z,mz,zz,iw(kz),w(k2),w(k3),w(k4),w(k5))
	j2 = k9+mxmy
c
c     set indices which depend on y interpolation
c
	if (intpol(2) .eq. 1) then
	  j3 = j2
	  j4 = j3+my
	  j5 = j4
	  j6 = j5
	  j7 = j6
	  j8 = j7+mx
	  j9 = j8+mx
	  call linmx(ny,y,my,yy,iw(jy),w(j3))
	  i2 = j9
	else
	  j3 = j2+my
	  j4 = j3+my
	  j5 = j4+my
	  j6 = j5+my
	  j7 = j6+mx
	  j8 = j7+mx
	  j9 = j8+mx
	  call cubnmx(ny,y,my,yy,iw(jy),w(j2),w(j3),w(j4),w(j5))
	  i2 = j9+mx
	end if
c
c     set work space portion and indices which depend on x interpolation
c
	if (intpol(1) .eq. 1) then
	  i3 = i2
	  i4 = i3
	  i5 = i4
	call linmx(nx,x,mx,xx,iw,w(i3))
	else
	  i3 = i2+mx
	  i4 = i3+mx
	  i5 = i4+mx
	call cubnmx(nx,x,mx,xx,iw,w(i2),w(i3),w(i4),w(i5))
	end if
	call cubt3(nx,ny,nz,p,mx,my,mxmy,mz,q,intpol,
     +  iw(kz),w(k2),w(k3),w(k4),w(k5),w(k6),w(k7),w(k8),w(k9),
     +  iw(jy),w(j2),w(j3),w(j4),w(j5),w(j6),w(j7),w(j8),w(j9),
     +  iw,w(i2),w(i3),w(i4),w(i5))
	return

      end if

      end

      subroutine lint3(nx,ny,nz,p,mx,my,mxmy,mz,q,intpol,kz,
     +dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
c
c     linearly interpolate in z direction
c
      implicit none
      integer nx,ny,nz,mx,my,mz,mxmy
      real p(nx,ny,nz),q(mxmy,mz)
      real dz(mz),pk(mxmy),pkp(mxmy)
      real dym(my),dy(my),dyp(my),dypp(my)
      real pjm(mx),pj(mx),pjp(mx),pjpp(mx)
      real dxm(mx),dx(mx),dxp(mx),dxpp(mx)
      integer intpol(3),kz(mz),jy(my),ix(mx)
      integer k,kk,iijj,ksave
      if (intpol(2) .eq. 1) then
c
c     linear in y
c
	ksave = -1
	do kk=1,mz
	  k = kz(kk)
	  if (k.eq.ksave) then
c
c     k pointer has not moved since last pass (no updates or interpolation)
c
	  else if (k.eq.ksave+1) then
c
c     update k and interpolate k+1
c
	  do iijj=1,mxmy
	    pk(iijj) = pkp(iijj)
	  end do
	  call lint2(nx,ny,p(1,1,k+1),mx,my,pkp,intpol,jy,dy,
     +               pj,pjp,ix,dxm,dx,dxp,dxpp)
	  else
c
c     interpolate k,k+1 in pk,pkp on xx,yy mesh
c
	    call lint2(nx,ny,p(1,1,k),mx,my,pk,intpol,jy,dy,
     +                 pj,pjp,ix,dxm,dx,dxp,dxpp)
	    call lint2(nx,ny,p(1,1,k+1),mx,my,pkp,intpol,jy,dy,
     +                 pj,pjp,ix,dxm,dx,dxp,dxpp)
	  end if
c
c     save k pointer for next pass
c
	  ksave = k
c
c     linearly interpolate q(ii,jj,k) from pk,pkp in z direction
c
	  do iijj=1,mxmy
	    q(iijj,kk) = pk(iijj)+dz(kk)*(pkp(iijj)-pk(iijj))
	  end do
	end do
	return

      else
c
c     cubic in y
c
	ksave = -1
	do kk=1,mz
	  k = kz(kk)
	  if (k.eq.ksave) then
c
c     k pointer has not moved since last pass (no updates or interpolation)
c
	  else if (k.eq.ksave+1) then
c
c     update k and interpolate k+1
c
	  do iijj=1,mxmy
	    pk(iijj) = pkp(iijj)
	  end do
	  call cubt2(nx,ny,p(1,1,k+1),mx,my,pkp,intpol,
     +    jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	  else
c
c     interpolate k,k+1 in pk,pkp on xx,yy mesh
c
	    call cubt2(nx,ny,p(1,1,k),mx,my,pk,intpol,
     +      jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	    call cubt2(nx,ny,p(1,1,k+1),mx,my,pkp,intpol,
     +      jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	  end if
c
c     save k pointer for next pass
c
	  ksave = k
c
c     linearly interpolate q(ii,jj,k) from pk,pkp in z direction
c
	  do iijj=1,mxmy
	    q(iijj,kk) = pk(iijj)+dz(kk)*(pkp(iijj)-pk(iijj))
	  end do
	end do
	return

      end if
      end

      subroutine cubt3(nx,ny,nz,p,mx,my,mxmy,mz,q,intpol,
     +kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,
     +pjp,pjpp,ix,dxm,dx,dxp,dxpp)
c
c     cubically interpolate in z
c
      implicit none
      integer nx,ny,nz,mx,my,mxmy,mz,k,kk,ksave,iijj
      real p(nx,ny,nz),q(mxmy,mz)
      real pkm(mxmy),pk(mxmy),pkp(mxmy),pkpp(mxmy)
      real pjm(mx),pj(mx),pjp(mx),pjpp(mx)
      real dzm(mz),dz(mz),dzp(mz),dzpp(mz)
      real dym(my),dy(my),dyp(my),dypp(my)
      real dxm(mx),dx(mx),dxp(mx),dxpp(mx)
      integer intpol(3),kz(mz),jy(my),ix(mx)
      if (intpol(2) .eq. 1) then
c
c       linear in y
c
	ksave = -3
	do kk=1,mz
	  k = kz(kk)
	  if (k.eq.ksave) then
c
c       k pointer has not moved since last pass (no updates or interpolation)
c
	  else if (k.eq.ksave+1) then
c
c       update k-1,k,k+1 and interpolate k+2
c
	  do iijj=1,mxmy
	    pkm(iijj) = pk(iijj)
	    pk(iijj) = pkp(iijj)
	    pkp(iijj) = pkpp(iijj)
	  end do
	  call lint2(nx,ny,p(1,1,k+2),mx,my,pkpp,
     +              intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
	  else if (k.eq.ksave+2) then
c
c       update k-1,k and interpolate k+1,k+2
c
	  do iijj=1,mxmy
	    pkm(iijj) = pkp(iijj)
	    pk(iijj) = pkpp(iijj)
	  end do
	  call lint2(nx,ny,p(1,1,k+1),mx,my,pkp,
     +               intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
	  call lint2(nx,ny,p(1,1,k+2),mx,my,pkpp,
     +               intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
	  else if (k.eq.ksave+3) then
c
c       update k-1 and interpolate k,k+1,k+2
c
	  do iijj=1,mxmy
	    pkm(iijj) = pkpp(iijj)
	  end do
	  call lint2(nx,ny,p(1,1,k),mx,my,pk,
     +               intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
	  call lint2(nx,ny,p(1,1,k+1),mx,my,pkp,
     +               intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
	  call lint2(nx,ny,p(1,1,k+2),mx,my,pkpp,
     +               intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
	  else
c
c       interpolate all four k-1,k,k+1,k+2
c
	    call lint2(nx,ny,p(1,1,k-1),mx,my,pkm,
     +                 intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
	    call lint2(nx,ny,p(1,1,k),mx,my,pk,
     +                 intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
	    call lint2(nx,ny,p(1,1,k+1),mx,my,pkp,
     +           intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
	    call lint2(nx,ny,p(1,1,k+2),mx,my,pkpp,
     +                 intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
	  end if
c
c       save k pointer for next pass
c
	  ksave = k
c
c       cubically interpolate q(ii,jj,kk) from pkm,pk,pkp,pkpp in z direction
c
	  do iijj=1,mxmy
	    q(iijj,kk) = dzm(kk)*pkm(iijj) + dz(kk)*pk(iijj) +
     +                   dzp(kk)*pkp(iijj) + dzpp(kk)*pkpp(iijj)
	  end do
	end do
	return

      else
c
c       cubic in y
c
	ksave = -3
	do kk=1,mz
	  k = kz(kk)
	  if (k.eq.ksave) then
c
c       k pointer has not moved since last pass (no updates or interpolation)
c
	  else if (k.eq.ksave+1) then
c
c       update k-1,k,k+1 and interpolate k+2
c
	  do iijj=1,mxmy
	    pkm(iijj) = pk(iijj)
	    pk(iijj) = pkp(iijj)
	    pkp(iijj) = pkpp(iijj)
	  end do
	  call cubt2(nx,ny,p(1,1,k+2),mx,my,pkpp,intpol,jy,dym,dy,
     +               dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	  else if (k.eq.ksave+2) then
c
c       update k-1,k and interpolate k+1,k+2
c
	    do iijj=1,mxmy
	      pkm(iijj) = pkp(iijj)
	      pk(iijj) = pkpp(iijj)
	    end do
	    call cubt2(nx,ny,p(1,1,k+1),mx,my,pkp,intpol,jy,dym,dy,
     +                 dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	    call cubt2(nx,ny,p(1,1,k+2),mx,my,pkpp,intpol,jy,dym,dy,
     +                 dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	  else if (k.eq.ksave+3) then
c
c       update k-1 and interpolate k,k+1,k+2
c
	    do iijj=1,mxmy
	      pkm(iijj) = pkpp(iijj)
	    end do
	    call cubt2(nx,ny,p(1,1,k),mx,my,pk,intpol,
     +      jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	    call cubt2(nx,ny,p(1,1,k+1),mx,my,pkp,intpol,
     +      jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	    call cubt2(nx,ny,p(1,1,k+2),mx,my,pkpp,intpol,
     +      jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	  else
c
c     interpolate all four k-1,k,k+1,k+2
c
	    call cubt2(nx,ny,p(1,1,k-1),mx,my,pkm,intpol,
     +      jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	    call cubt2(nx,ny,p(1,1,k),mx,my,pk,intpol,
     +      jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	    call cubt2(nx,ny,p(1,1,k+1),mx,my,pkp,intpol,
     +      jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
	    call cubt2(nx,ny,p(1,1,k+2),mx,my,pkpp,intpol,
     +      jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)

	  end if
c
c       save k pointer for next pass
c
	  ksave = k
c
c       cubically interpolate q(ii,jj,kk) from pkm,pk,pkp,pkpp in z direction
c
	  do iijj=1,mxmy
	    q(iijj,kk) = dzm(kk)*pkm(iijj) + dz(kk)*pk(iijj) +
     +                   dzp(kk)*pkp(iijj) + dzpp(kk)*pkpp(iijj)
	  end do
	end do
	return
      end if

      end


subroutine EigValVecSym(ain, n, eig, evec, ul, K)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subroutine will return the eigenvalues and eigenvectors
!	of the symmetric square matrix Ain. The output eigenvectors
!	are ordered from greatest to least, and the norm of the eigenvectors
!	is unity. If the optional parameter K is specified, only the K largest
!	eigenvalues and corresponding vectors will be output.
!
!	Calling Parameters
!		IN
!			Ain	Input symmetric matrix. By default, only the
!				upper portion is used.
!			n	Order of the matrix Ain.
!		OUT
!			eig	Vector of length n of the eigenvalues of Ain.
!			evec	Matrix of dimension n of the
!				eigenvectors of Ain.
!		OPTIONAL
!			ul	Use the upper 'U' or lower 'L' portion of the
!				input symmetric matrix.
!			K	The K largest eigenvalues and corresponding eigenvectors
!				to calculate and output.
!
!	Notes:
!
!	1.	The eigenvalues and eigenvectors are determined by reducing the matrix to
!			A = Z L Z = Q (S L S') Q'
!		by the two operations:
!
!		(1) The real symmetric square matrix is reduced to tridiagonal form
!			A = Q T Q'
!		where Q is orthogonal, and T is symmetric tridiagonal.
!		(2) The tridiagonal matrix is reduced to
!			T = S L S'
!
!		The eigenvalues of A correspond to the L (which is a diagonal), and the
!		eigenvectors correspond to Z = Q S.
!	2. 	The sign convention for the eigenvalues might want to be changed.
!		For instance, IMSL chooses the sign such that the value with
!		max(abs(evec)) is positive.
!
!	Dependencies: LAPACK, BLAS
!
!	Written by Mark Wieczorek June 2004.
!	Modified August 15:	Option to only calcuate K largest eigenvectors and corresponding eigenvalues. Also,
!				with LAPACK3.1, the DSTEGR routine no longer uses ABSTOL, so this parameter does
!				not need to be specified.
!
!	Copyright (c) 2005-2009, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	real*8, intent(in) ::		ain(:,:)
	integer, intent(in) ::		n
	real*8, intent(out) ::		eig(:), evec(:,:)
	character, intent(in), optional ::	ul
	integer, intent(in), optional ::	K
	integer, parameter ::			nb = 80, nbl = 10
	character ::			uplo
	real*8 ::			d(n), e(n), tau(n-1), work(nb*n), vl, vu, &
					abstol, w(n)
	real*8, allocatable :: 		a(:,:), z(:,:)
	integer ::			lwork, info, il, iu, m, isuppz(2*n), liwork, iwork(nbl*n), &
					i, astat(2)
	external	 		dsytrd_, dstegr_, dormtr_

	if (size(ain(:,1)) < n .or. size(ain(1,:)) < n) then
		print*, "Error --- EigValVecSym"
		print*, "AIN must be dimensioned as (N, N) where N is ", n
		print*, "Input array is dimensioned as ", size(ain(:,1)), size(ain(1,:))
		stop
	endif

	if (present(K)) then
		if(size(eig) < K) then
			print*, "Error --- EigValVecSym"
			print*, "EIG must be dimensioned as (K) where K is ", K
			print*, "Input array is dimensioned as ", size(eig)
			stop
		elseif(size(evec(:,1)) < n .or. size(evec(1,:)) < K) then
			print*, "Error --- EigValVecSym"
			print*, "EVEC must be dimensioned as (N, K)."
			print*, "N = ", n
			print*, "K = ", k
			print*, "Input array is dimensioned as ", size(evec(:,1)), size(evec(1,:))
			stop
		endif
	else
		if(size(eig) < n) then
			print*, "Error --- EigValVecSym"
			print*, "EIG must be dimensioned as (N) where N is ", n
			print*, "Input array is dimensioned as ", size(eig)
			stop
		elseif(size(evec(:,1)) < n .or. size(evec(1,:)) < n) then
			print*, "Error --- EigValVecSym"
			print*, "EVEC must be dimensioned as (N, N) where N is ", n
			print*, "Input array is dimensioned as ", size(evec(:,1)), size(evec(1,:))
			stop
		endif
	endif

	allocate(a(n,n), stat = astat(1))
	allocate(z(n,n), stat = astat(2))

	if (astat(1) /= 0 .or. astat(2) /= 0) then
		print*, "Error --- EigValVecSym2"
		print*, "Problem allocating arrays A and Z", astat(1), astat(2)
		stop
	endif

	lwork = nb*n
	liwork = nbl*n

	eig = 0.0d0
	evec = 0.0d0
	a(1:n,1:n) = ain(1:n,1:n)

	if (present(ul)) then
		uplo = ul
	else
		uplo = "U"
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Factor A to Q T Q' where T is a tridiagonal matrix.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	call dsytrd_(uplo, n, a, n, d, e(1:n-1), tau, work, lwork, info)

	if (info /= 0) then
		print*, "Error --- EigValVecSym"
		print*, "Problem tri-diagonalizing input matrix"
		print*, "DSYTRD info = ", info
		stop
	else
		if ( work(1) > dble(lwork) ) then
			print*, "Warning --- EigValVecSym"
			print*, "Consider changing value of nb to ", work(1)/n, " and recompile."
		endif
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Factor T to S L S' where L is a diagonal matrix.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	abstol = 0.0d0

	if (present(K)) then
		call dstegr_('v','I', n, d, e, vl, vu, n-K+1, n, abstol, m,  w, &
			z, n, isuppz, work, lwork, iwork, liwork, info)
	else
		call dstegr_('v','I', n, d, e, vl, vu, il, iu, abstol, m,  w, &
			z, n, isuppz, work, lwork, iwork, liwork, info)
	endif

       	if (info /= 0) then
		print*, "Error --- EigValVecSym"
		print*, "Problem determining eigenvalues and eigenvectors of tridiagonal matrix."
		if (info==1) print*, "Internal error in DLARRE"
		if (info==2) print*, "Internal error in DLARRV"
		print*, "DSTEGR info = ", info
		stop
	else
		if (work(1) > dble(lwork) ) then
			print*, "Warning --- EigValVecSym"
			print*, "Consider changing value of nb to ", work(1)/n, " and recompile SHTOOLS archive."
		endif

		if (iwork(1) > liwork ) then
			print*, "Warning --- EigValVecSym"
			print*, "Consider changing value of nb to ", iwork(1)/n, " and recompile SHTOOLS archive."
		endif
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Determine eigenvalues Z = Q S (note that Q is stored in a
	!	bizarre manner, see LAPACK notes), and reorder eigenvalues and
	!	eigenvectors from greatest to least.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	call dormtr_('L', uplo, 'N', n, n, a, n, tau, z, n, work, lwork, info)

	if (info /= 0) then
		print*, "Error --- EigValVecSym"
		print*, "Problem multiplying matrices."
		print*, "DORMTR info = ", info
		stop
	else
		if ( work(1) > dble(lwork) ) then
			print*, "Warning --- EigValVecSym"
			print*, "Consider changing value of nb to ", work(1)/n, " and recompile."
		endif
	endif

	if (present(k)) then
		do i=n-K+1, n
			eig(i-n+k) = w(n+1-i)
			evec(1:n,i-n+k) = z(1:n,n+1-i)
		enddo
	else
		do i=1, n
			eig(i) = w(n+1-i)
			evec(1:n,i) = z(1:n,n+1-i)
		enddo
	endif

	deallocate(a)
	deallocate(z)

end subroutine EigValVecSym


Spectrum-analysis-program: Integrate the supplied spectrum

Keys:

     infile       nokeyok             input spectrum file [-]
     xc                               x-column [1]
     yc                               y-column [2]
     xmin                             } range over which to integrate
     xmax                             } [full range of x]

A simple integration of the data within the specified range is performed.
The y data are integrated with respect to x using a trapezoidal rule and
the result of the integration is printed on the standard output.

Example:

Integrate column-3 with respect to column 1 in the range 0,100

  sp_integrate my_data.dat xmin 0.0 xmax 100.0 xc 1 yc 3


! This is free and unencumbered software released into the public domain.
!
! Anyone is free to copy, modify, publish, use, compile, sell, or
! distribute this software, either in source code form or as a compiled
! binary, for any purpose, commercial or non-commercial, and by any
! means.
!
! In jurisdictions that recognize copyright laws, the author or authors
! of this software dedicate any and all copyright interest in the
! software to the public domain. We make this dedication for the benefit
! of the public at large and to the detriment of our heirs and
! successors. We intend this dedication to be an overt act of
! relinquishment in perpetuity of all present and future rights to this
! software under copyright law.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
! EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
! IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR
! OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
! ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
! OTHER DEALINGS IN THE SOFTWARE.
!
! For more information, please refer to <https://unlicense.org>

!> Analytical implementation of the 3x3 eigenproblem and its solution.
module diag3x3
   implicit none
   private

   public :: eigval3x3, eigvec3x3

   !> Floating point precision
   integer, parameter :: wp = selected_real_kind(15)

   !> 2π/3
   real(wp), parameter :: twothirdpi = 8.0_wp * atan(1.0_wp) / 3.0_wp

   !> Numerical precision
   real(wp), parameter :: eps = epsilon(1.0_wp)

contains

!> Calculates eigenvalues based on the trigonometric solution of A = pB + qI
pure subroutine eigval3x3(a, w)

   !> The symmetric input matrix
   real(wp), intent(in) :: a(3, 3)

   !> Contains eigenvalues on exit
   real(wp), intent(out) :: w(3)

   real(wp) :: q, p, r

   r = a(1, 2) * a(1, 2) + a(1, 3) * a(1, 3) + a(2, 3) * a(2, 3)
   q = (a(1, 1) + a(2, 2) + a(3, 3)) / 3.0_wp
   w(1) = a(1, 1) - q
   w(2) = a(2, 2) - q
   w(3) = a(3, 3) - q
   p = sqrt((w(1) * w(1) + w(2) * w(2) + w(3) * w(3) + 2*r) / 6.0_wp)
   r = (w(1) * (w(2) * w(3) - a(2, 3) * a(2, 3)) &
      & - a(1, 2) * (a(1, 2) * w(3) - a(2, 3) * a(1, 3)) &
      & + a(1, 3) * (a(1, 2) * a(2, 3) - w(2) * a(1, 3))) / (p*p*p) * 0.5_wp

   if (r <= -1.0_wp) then
      r = 0.5_wp * twothirdpi
   else if (r >= 1.0_wp) then
      r = 0.0_wp
   else
      r = acos(r) / 3.0_wp
   end if

   w(3) = q + 2 * p * cos(r)
   w(1) = q + 2 * p * cos(r + twothirdpi)
   w(2) = 3 * q - w(1) - w(3)

end subroutine eigval3x3

!> Calculates eigenvector using an analytical method based on vector cross
!  products.
pure subroutine eigvec3x3(a, w, q)

   !> The symmetric input matrix, destroyed while solving
   real(wp), intent(inout) :: a(3,3)

   !> Contains eigenvalues on exit
   real(wp), intent(out) :: w(3)

   !> Contains eigenvectors on exit
   real(wp), intent(out) :: q(3,3)

   !> Local variables
   real(wp) :: norm, n1, n2, n3, precon
   integer :: i

   w(1) = max(abs(a(1, 1)), abs(a(1, 2)))
   w(2) = max(abs(a(1, 3)), abs(a(2, 2)))
   w(3) = max(abs(a(2, 3)), abs(a(3, 3)))
   precon = max(w(1), max(w(2), w(3)))

   ! null matrix
   if (precon < eps) then
      w(1) = 0.0_wp
      w(2) = 0.0_wp
      w(3) = 0.0_wp
      q(1, 1) = 1.0_wp
      q(2, 2) = 1.0_wp
      q(3, 3) = 1.0_wp
      q(1, 2) = 0.0_wp
      q(1, 3) = 0.0_wp
      q(2, 3) = 0.0_wp
      q(2, 1) = 0.0_wp
      q(3, 1) = 0.0_wp
      q(3, 2) = 0.0_wp
      return
   end if

   norm = 1.0_wp / precon

   a(1, 1) = a(1, 1) * norm
   a(1, 2) = a(1, 2) * norm
   a(2, 2) = a(2, 2) * norm
   a(1, 3) = a(1, 3) * norm
   a(2, 3) = a(2, 3) * norm
   a(3, 3) = a(3, 3) * norm

   ! Calculate eigenvalues
   call eigval3x3(a, w)

   ! Compute first eigenvector
   a(1, 1) = a(1, 1) - w(1)
   a(2, 2) = a(2, 2) - w(1)
   a(3, 3) = a(3, 3) - w(1)

   q(1, 1) = a(1, 2) * a(2, 3) - a(1, 3) * a(2, 2)
   q(2, 1) = a(1, 3) * a(1, 2) - a(1, 1) * a(2, 3)
   q(3, 1) = a(1, 1) * a(2, 2) - a(1, 2) * a(1, 2)
   q(1, 2) = a(1, 2) * a(3, 3) - a(1, 3) * a(2, 3)
   q(2, 2) = a(1, 3) * a(1, 3) - a(1, 1) * a(3, 3)
   q(3, 2) = a(1, 1) * a(2, 3) - a(1, 2) * a(1, 3)
   q(1, 3) = a(2, 2) * a(3, 3) - a(2, 3) * a(2, 3)
   q(2, 3) = a(2, 3) * a(1, 3) - a(1, 2) * a(3, 3)
   q(3, 3) = a(1, 2) * a(2, 3) - a(2, 2) * a(1, 3)
   n1 = q(1, 1) * q(1, 1) + q(2, 1) * q(2, 1) + q(3, 1) * q(3, 1)
   n2 = q(1, 2) * q(1, 2) + q(2, 2) * q(2, 2) + q(3, 2) * q(3, 2)
   n3 = q(1, 3) * q(1, 3) + q(2, 3) * q(2, 3) + q(3, 3) * q(3, 3)

   norm = n1
   i = 1
   if (n2 > norm) then
      i = 2
      norm = n1
   end if
   if (n3 > norm) then
      i = 3
   end if

   if (i == 1) then
      norm = sqrt(1.0_wp / n1)
      q(1, 1) = q(1, 1) * norm
      q(2, 1) = q(2, 1) * norm
      q(3, 1) = q(3, 1) * norm
   else if (i == 2) then
      norm = sqrt(1.0_wp / n2)
      q(1, 1) = q(1, 2) * norm
      q(2, 1) = q(2, 2) * norm
      q(3, 1) = q(3, 2) * norm
   else
      norm = sqrt(1.0_wp / n3)
      q(1, 1) = q(1, 3) * norm
      q(2, 1) = q(2, 3) * norm
      q(3, 1) = q(3, 3) * norm
   end if

   ! Robustly compute a right-hand orthonormal set (ev1, u, v)
   if (abs(q(1, 1)) > abs(q(2, 1))) then
      norm = sqrt(1.0_wp / (q(1, 1) * q(1, 1) + q(3, 1) * q(3, 1)))
      q(1, 2) = -q(3, 1) * norm
      q(2, 2) = 0.0_wp
      q(3, 2) = +q(1, 1) * norm
   else
      norm = sqrt(1.0_wp / (q(2, 1) * q(2, 1) + q(3, 1) * q(3, 1)))
      q(1, 2) = 0.0_wp
      q(2, 2) = +q(3, 1) * norm
      q(3, 2) = -q(2, 1) * norm
   end if
   q(1, 3) = q(2, 1) * q(3, 2) - q(3, 1) * q(2, 2)
   q(2, 3) = q(3, 1) * q(1, 2) - q(1, 1) * q(3, 2)
   q(3, 3) = q(1, 1) * q(2, 2) - q(2, 1) * q(1, 2)

   ! Reset A
   a(1, 1) = a(1, 1) + w(1)
   a(2, 2) = a(2, 2) + w(1)
   a(3, 3) = a(3, 3) + w(1)

   ! A*U
   n1 = a(1, 1) * q(1, 2) + a(1, 2) * q(2, 2) + a(1, 3) * q(3, 2)
   n2 = a(1, 2) * q(1, 2) + a(2, 2) * q(2, 2) + a(2, 3) * q(3, 2)
   n3 = a(1, 3) * q(1, 2) + a(2, 3) * q(2, 2) + a(3, 3) * q(3, 2)

   ! A*V, note out of order computation
   a(3, 3) = a(1, 3) * q(1, 3) + a(2, 3) * q(2, 3) + a(3, 3) * q(3, 3)
   a(1, 3) = a(1, 1) * q(1, 3) + a(1, 2) * q(2, 3) + a(1, 3) * q(3, 3)
   a(2, 3) = a(1, 2) * q(1, 3) + a(2, 2) * q(2, 3) + a(2, 3) * q(3, 3)

   ! UT*(A*U) - l2*E
   n1 = q(1, 2) * n1 + q(2, 2) * n2 + q(3, 2) * n3 - w(2)
   ! UT*(A*V)
   n2 = q(1, 2) * a(1, 3) + q(2, 2) * a(2, 3) + q(3, 2) * a(3, 3)
   ! VT*(A*V) - l2*E
   n3 = q(1, 3) * a(1, 3) + q(2, 3) * a(2, 3) + q(3, 3) * a(3, 3) - w(2)

   if (abs(n1) >= abs(n3)) then
      norm = max(abs(n1), abs(n2))
      if (norm > eps) then
         if (abs(n1) >= abs(n2)) then
            n2 = n2 / n1
            n1 = sqrt(1.0_wp / (1.0_wp + n2 * n2))
            n2 = n2 * n1
         else
            n1 = n1 / n2
            n2 = sqrt(1.0_wp / (1.0_wp + n1 * n1))
            n1 = n1 * n2
         end if
         q(1, 2) = n2 * q(1, 2) - n1 * q(1, 3)
         q(2, 2) = n2 * q(2, 2) - n1 * q(2, 3)
         q(3, 2) = n2 * q(3, 2) - n1 * q(3, 3)
      end if
   else
      norm = max(abs(n3), abs(n2))
      if (norm > eps) then
         if (abs(n3) >= abs(n2)) then
            n2 = n2 / n3
            n3 = sqrt(1.0_wp / (1.0_wp + n2 * n2))
            n2 = n2 * n3
         else
            n3 = n3 / n2
            n2 = sqrt(1.0_wp / (1.0_wp + n3 * n3))
            n3 = n3 * n2
         end if
         q(1, 2) = n3 * q(1, 2) - n2 * q(1, 3)
         q(2, 2) = n3 * q(2, 2) - n2 * q(2, 3)
         q(3, 2) = n3 * q(3, 2) - n2 * q(3, 3)
      end if
   end if

   ! Calculate third eigenvector from cross product
   q(1, 3) = q(2, 1) * q(3, 2) - q(3, 1) * q(2, 2)
   q(2, 3) = q(3, 1) * q(1, 2) - q(1, 1) * q(3, 2)
   q(3, 3) = q(1, 1) * q(2, 2) - q(2, 1) * q(1, 2)

   w(1) = w(1) * precon
   w(2) = w(2) * precon
   w(3) = w(3) * precon

end subroutine eigvec3x3

end module diag3x3


!------------------------------------------------------------------------------!
!> Numerical operations.
!------------------------------------------------------------------------------!
module num_ops
#include <PB3D_macros.h>
    use str_utilities
    use messages
    use num_vars, only: dp, iu, max_str_ln, pi
    use num_utilities
    use output_ops

    implicit none
    private
    public calc_zero_HH, calc_zero_Zhang
#if ldebug
    public debug_calc_zero
#endif

    ! global variables
#if ldebug
    !> \ldebug
    logical :: debug_calc_zero = .false.                                        !< plot debug information for calc_zero
#endif

    ! interfaces

    !> \public Finds the zero of a function using Householder iteration.
    !!
    !! If something goes  wrong, by default multiple tries can  be attempted, by
    !! backtracking on the correction by  multiplying it by a relaxation factor.
    !! This can be done \c max_nr_backtracks times.
    !!
    !! If still nothing is achieved, an error message is returned,
    !! that is empty otherwise.
    interface calc_zero_HH
        !> \public
        module procedure calc_zero_HH_0D
        !> \public
        module procedure calc_zero_HH_3D
    end interface

contains
    !> \private 0-D version
    !! \param[inout] fun <tt>fun(x,ord)</tt> with
    !!  - <tt>x</tt> abscissa
    !!  - <tt>ord</tt> order of derivative
    !!  - <tt>fun</tt> ordinate
    function calc_zero_HH_0D(zero,fun,ord,guess,max_nr_backtracks,output) &
        &result(err_msg)
        use num_vars, only: max_it_zero, tol_zero, max_nr_backtracks_HH

        ! input / output
        real(dp), intent(inout) :: zero                                         !< output
        interface
            function fun(x,ord)                                                 ! the function
                use num_vars, only: dp
                real(dp), intent(in) :: x
                integer, intent(in) :: ord
                real(dp) :: fun
            end function fun
        end interface
        integer, intent(in) :: ord                                              !< order of solution
        real(dp), intent(in) :: guess                                           !< first guess
        integer, intent(in), optional :: max_nr_backtracks                      !< max nr. of tries with different relaxation factors
        logical, intent(in), optional :: output                                 !< give output on convergence
        character(len=max_str_ln) :: err_msg                                    !< possible error message

        ! local variables
        integer :: id, jd, kd                                                   ! counters
        integer :: max_nr_backtracks_loc                                        ! local max_nr_backtracks
        logical :: output_loc                                                   ! local output
        logical :: relaxed_enough                                               ! whether step was relaxed enough to get a smaller new value
        real(dp) :: zero_new                                                    ! new zero calculated
        real(dp) :: fun_new                                                     ! function value at new zero
        real(dp) :: corr                                                        ! correction
        real(dp), allocatable :: fun_vals(:)                                    ! function values
#if ldebug
        real(dp), allocatable :: corrs(:)                                       ! corrections for all steps
        real(dp), allocatable :: values(:)                                      ! values for all steps
#endif

        ! initialize error message
        err_msg = ''

        ! set up local output
        output_loc = .false.
        if (present(output)) output_loc = output

        ! set up zero
        zero = guess

        ! set up local max_nr_backtracks
        max_nr_backtracks_loc = max_nr_backtracks_HH
        if (present(max_nr_backtracks)) &
            &max_nr_backtracks_loc = max_nr_backtracks

        ! initialize function values
        allocate(fun_vals(0:ord))

#if ldebug
        if (debug_calc_zero) then
            ! set up corrs
            allocate(corrs(max_it_zero))
            allocate(values(max_it_zero))
        end if
#endif

        ! loop over iterations
        HH: do jd = 1,max_it_zero
            ! calculate function values
            do kd = 0,ord
                fun_vals(kd) = fun(zero,kd)
            end do

            ! correction to theta_HH
            select case (ord)
                case (1)                                                        ! Newton-Rhapson
                    corr = -fun_vals(0)/fun_vals(1)
                case (2)                                                        ! Halley
                    corr = -fun_vals(0)*fun_vals(1)/&
                        &(fun_vals(1)**2 - 0.5_dp*&
                        &fun_vals(0)*fun_vals(2))
                case (3)                                                        ! 3rd order
                    corr = -(6*fun_vals(0)*fun_vals(1)**2-&
                        &3*fun_vals(0)**2*fun_vals(2))/&
                        &(6*fun_vals(1)**3 - 6*fun_vals(0)*&
                        &fun_vals(1)*fun_vals(2)+&
                        &fun_vals(0)**2*fun_vals(3))
            end select
#if ldebug
            if (debug_calc_zero) then
                corrs(jd) = corr
                values(jd) = zero
            end if
#endif
            relaxed_enough = .false.
            do id = 1,max_nr_backtracks_loc
                zero_new = zero + corr                                          ! propose a new zero

                fun_new = fun(zero_new,0)                                       ! calculate function value there

                if (abs(fun_new)-abs(fun_vals(0)).le.0._dp) then                ! error has decreased
                    relaxed_enough = .true.
                    zero = zero_new
                    exit
                end if
                corr = corr*0.5_dp
            end do

            ! check for relaxation
            if (.not.relaxed_enough) then
                err_msg = trim(i2str(max_nr_backtracks_HH))//' backtracks were &
                    &not sufficient to get a better guess for the zero'
                zero = 0.0_dp
            else
                ! output
                if (output_loc) call writo(trim(i2str(jd))//' / '&
                    &//trim(i2str(max_it_zero))//&
                    &' - relative error: '//&
                    &trim(r2str(abs(corr)))//' (tol: '//&
                    &trim(r2str(tol_zero))//')')

                ! check for convergence
                if (abs(corr).lt.tol_zero) then
#if ldebug
                    if (debug_calc_zero) &
                        &call plot_evolution(corrs(1:jd),values(1:jd))
#endif
                    return
                else if (jd .eq. max_it_zero) then
#if ldebug
                    if (debug_calc_zero) then
                        call plot_evolution(corrs,values)
                        deallocate(corrs)
                        deallocate(values)
                    end if
#endif
                    err_msg = 'Not converged after '//trim(i2str(jd))//&
                        &' iterations, with residual '//&
                        &trim(r2strt(corr))//' and final value '//&
                        &trim(r2strt(zero))
                    zero = 0.0_dp
                end if
            end if
        end do HH
#if ldebug
    contains
        ! plots corrections
        !> \private
        subroutine plot_evolution(corrs,values)
            ! input / output
            real(dp), intent(in) :: corrs(:)                                    ! corrections
            real(dp), intent(in) :: values(:)                                   ! values

            ! local variables
            real(dp) :: min_x, max_x                                            ! min. and max. x for which to plot the function
            real(dp) :: extra_x = 1._dp                                         ! how much bigger to take the plot interval than just min and max
            real(dp) :: delta_x                                                 ! interval between zero and guess
            integer :: n_x = 200                                                ! how many x values to plot
            real(dp), allocatable :: x_out(:,:)                                 ! output x of plot
            real(dp), allocatable :: y_out(:,:)                                 ! output y of plot

            ! set up min and max x
            min_x = min(zero,guess)
            max_x = max(zero,guess)
            delta_x = max_x-min_x
            min_x = min_x - delta_x*extra_x
            max_x = max_x + delta_x*extra_x

            ! set up output of plot
            allocate(x_out(n_x,2))
            allocate(y_out(n_x,2))
            x_out(:,1) = [(min_x+(max_x-min_x)*(jd-1._dp)/(n_x-1),jd=1,n_x)]
            x_out(:,2) = [(min_x+(max_x-min_x)*(jd-1._dp)/(n_x-1),jd=1,n_x)]
            y_out(:,1) = [(fun(min_x+(max_x-min_x)*(jd-1._dp)/(n_x-1),0),&
                &jd=1,n_x)]
            y_out(:,2) = [(fun(min_x+(max_x-min_x)*(jd-1._dp)/(n_x-1),1),&
                &jd=1,n_x)]

            ! plot function
            call writo('Initial guess: '//trim(r2str(guess)))
            call writo('Resulting zero: '//trim(r2str(zero)))
            call print_ex_2D(['function  ','derivative'],'',y_out,x=x_out)

            ! user output
            call writo('Last correction '//trim(r2strt(corrs(size(corrs))))&
                &//' with tolerance '//trim(r2strt(tol_zero)))

            ! plot corrections and values
            call print_ex_2D('corrs','',corrs)
            call print_ex_2D('values','',values)
        end subroutine plot_evolution
#endif
    end function calc_zero_HH_0D
    !> \private 3-D version
    !! \param[inout] fun <tt>fun(dims,x,ord)</tt> with
    !!  - <tt>dims(3)</tt> dimension of abscissa and ordinate
    !!  - <tt>x(dims(1),dims(2),dims(3))</tt> abscissa
    !!  - <tt>ord</tt> order of derivative
    !!  - <tt>fun(dims(1),dims(2),dims(3))</tt> ordinate
    function calc_zero_HH_3D(dims,zero,fun,ord,guess,max_nr_backtracks,output) &
        &result(err_msg)
        use num_vars, only: max_it_zero, tol_zero, max_nr_backtracks_HH

        ! input / output
        integer, intent(in) :: dims(3)                                          !< dimensions of the problem
        real(dp), intent(inout) :: zero(dims(1),dims(2),dims(3))                !< output
        interface
            function fun(dims,x,ord)                                            ! the function
                use num_vars, only: dp
                integer, intent(in) :: dims(3)
                real(dp), intent(in) :: x(dims(1),dims(2),dims(3))
                integer, intent(in) :: ord
                real(dp) :: fun(dims(1),dims(2),dims(3))
            end function fun
        end interface
        integer, intent(in) :: ord                                              !< order of solution
        real(dp), intent(in) :: guess(dims(1),dims(2),dims(3))                  !< first guess
        integer, intent(in), optional :: max_nr_backtracks                      !< max nr. of backtracks
        logical, intent(in), optional :: output                                 !< give output on convergence
        character(len=max_str_ln) :: err_msg                                    !< possible error message

        ! local variables
        integer :: id, jd, kd                                                   ! counters
        integer :: max_nr_backtracks_loc                                        ! local max_nr_backtracks
        integer :: mc_ind(3)                                                    ! index of maximum correction
        logical :: output_loc                                                   ! local output
        logical :: relaxed_enough                                               ! relaxed enough
        real(dp) :: zero_new(dims(1),dims(2),dims(3))                           ! new zeros calculated
        real(dp) :: fun_new(dims(1),dims(2),dims(3))                            ! function values at new zero
        real(dp) :: corr(dims(1),dims(2),dims(3))                               ! correction
        real(dp), allocatable :: fun_vals(:,:,:,:)                              ! function values
#if ldebug
        real(dp), allocatable :: corrs(:,:,:,:)                                 ! corrections for all steps
        real(dp), allocatable :: values(:,:,:,:)                                ! values for all steps
#endif

        ! initialize error message
        err_msg = ''

        ! test
        if (ord.lt.1 .or. ord.gt.3) then
            zero = 0.0_dp
            err_msg = 'only orders 1 (Newton-Rhapson), 2 (Halley) and 3 &
                &implemented, not '//trim(i2str(ord))
            return
        end if

        ! set up local output
        output_loc = .false.
        if (present(output)) output_loc = output

        ! set up zero
        zero = guess

        ! set up local max_nr_backtracks
        max_nr_backtracks_loc = max_nr_backtracks_HH
        if (present(max_nr_backtracks)) &
            &max_nr_backtracks_loc = max_nr_backtracks

        ! initialize function values
        allocate(fun_vals(dims(1),dims(2),dims(3),0:ord))

#if ldebug
        if (debug_calc_zero) then
            ! set up corrs
            allocate(corrs(dims(1),dims(2),dims(3),max_it_zero))
            allocate(values(dims(1),dims(2),dims(3),max_it_zero))
        end if
#endif

        ! loop over iterations
        HH: do jd = 1,max_it_zero
            ! calculate function values
            do kd = 0,ord
                fun_vals(:,:,:,kd) = fun(dims,zero,kd)
            end do

            ! correction to theta_HH
            select case (ord)
                case (1)                                                        ! Newton-Rhapson
                    corr = -fun_vals(:,:,:,0)/fun_vals(:,:,:,1)
                case (2)                                                        ! Halley
                    corr = -fun_vals(:,:,:,0)*fun_vals(:,:,:,1)/&
                        &(fun_vals(:,:,:,1)**2 - 0.5_dp*&
                        &fun_vals(:,:,:,0)*fun_vals(:,:,:,2))
                case (3)                                                        ! 3rd order
                    corr = -(6*fun_vals(:,:,:,0)*fun_vals(:,:,:,1)**2-&
                        &3*fun_vals(:,:,:,0)**2*fun_vals(:,:,:,2))/&
                        &(6*fun_vals(:,:,:,1)**3 - 6*fun_vals(:,:,:,0)*&
                        &fun_vals(:,:,:,1)*fun_vals(:,:,:,2)+&
                        &fun_vals(:,:,:,0)**2*fun_vals(:,:,:,3))
            end select
#if ldebug
            if (debug_calc_zero) then
                corrs(:,:,:,jd) = corr
                values(:,:,:,jd) = zero
            end if
#endif
            relaxed_enough = .false.
            do id = 1,max_nr_backtracks_loc
                zero_new = zero                                                 ! otherwise some values might stay unitialized
                where (abs(corr).gt.tol_zero) zero_new = zero + corr            ! propose a new zero

                fun_new = fun(dims,zero_new,0)                                  ! calculate function value there

#if ldebug
                if (debug_calc_zero) &
                    &call writo('backtrack '//trim(i2str(id))//' of max. '//&
                    &trim(i2str(max_nr_backtracks_loc))//' - criterion: '//&
                    &trim(r2str(maxval(abs(fun_new)-abs(fun_vals(:,:,:,0)))))//&
                    &' <= 0?')
#endif
                if (maxval(abs(fun_new)-abs(fun_vals(:,:,:,0))).le.0._dp) then  ! error has decreased
                    relaxed_enough = .true.
                    zero = zero_new
                    exit
                end if
                corr = corr*0.5_dp
            end do

            ! check for relaxation
            if (.not.relaxed_enough) then
                err_msg = trim(i2str(max_nr_backtracks_HH))//' backtracks were &
                    &not sufficient to get a better guess for the zero'
                zero = 0.0_dp
                exit
            else
                ! output
                if (output_loc) call writo(trim(i2str(jd))//' / '&
                    &//trim(i2str(max_it_zero))//&
                    &' - maximum relative error: '//&
                    &trim(r2str(maxval(abs(corr))))//' (tol: '//&
                    &trim(r2str(tol_zero))//')')

                ! check for convergence
                if (maxval(abs(corr)).lt.tol_zero) then
#if ldebug
                    if (debug_calc_zero) call &
                        &plot_evolution(corrs(:,:,:,1:jd),values(:,:,:,1:jd))
#endif
                    return
                else if (jd .eq. max_it_zero) then
#if ldebug
                    if (debug_calc_zero) then
                        call plot_evolution(corrs,values)
                        deallocate(corrs)
                        deallocate(values)
                    end if
#endif
                    mc_ind = maxloc(abs(corr))
                    err_msg = 'Not converged after '//trim(i2str(jd))//&
                        &' iterations, with maximum residual '//&
                        &trim(r2strt(corr(mc_ind(1),mc_ind(2),mc_ind(3))))&
                        &//' and final value '//trim(r2strt(&
                        &zero(mc_ind(1),mc_ind(2),mc_ind(3))))
                    zero = 0.0_dp
                end if
            end if
        end do HH
#if ldebug
    contains
        ! plots corrections
        !> \private
        subroutine plot_evolution(corrs,values)
            ! input / output
            real(dp), intent(in) :: corrs(:,:,:,:)                              ! corrections
            real(dp), intent(in) :: values(:,:,:,:)                             ! values

            ! local variables
            integer :: n_corrs                                                  ! number of corrections
            character(len=max_str_ln) :: var_name(1)                            ! names of variable
            character(len=max_str_ln) :: file_name                              ! name of file

            ! initialize
            n_corrs = size(corrs,4)
            mc_ind = maxloc(abs(corrs(:,:,:,n_corrs)))

            ! user output
            call writo('Last maximum correction '//&
                &trim(r2strt(corrs(mc_ind(1),mc_ind(2),mc_ind(3),n_corrs)))&
                &//' and final value '//trim(r2strt(&
                &values(mc_ind(1),mc_ind(2),mc_ind(3),n_corrs)))//&
                &' with tolerance '//trim(r2strt(tol_zero)))

            ! plot corrs
            file_name = 'corrs'
            var_name = 'var'

            call plot_HDF5(var_name,file_name,corrs,col=2,&
                &descr='corrections')

            ! plot values
            file_name = 'values'
            var_name = 'var'

            call plot_HDF5(var_name,file_name,values,col=2,&
                &descr='values')
        end subroutine plot_evolution
#endif
    end function calc_zero_HH_3D

    !> Finds the zero of a function  using Zhang's method, which is simpler than
    !! Brent's method.
    !!
    !! Taken  from  from  Steven  Stage's  correction  of  Zhang's  paper
    !! \cite zhang2011improvement.
    !!
    !! Unlike Householder, Zhang's method needs  an interval \c x_int_in to work
    !! in,  not  a guess.  Also,  it  does not  require  the  derivative of  the
    !! function.
    !!
    !! The routine returns  an error message if  no zero is found,  and which is
    !! empty otherwise.
    !!
    !! \note The interval \c x_int_in needs to be so that the function values at
    !! either end are of different value.
    !! \param[inout] fun <tt>fun(x)</tt> with
    !!  - <tt>x</tt> abscissa
    !!  - <tt>fun</tt> ordinate
    function calc_zero_Zhang(zero,fun,x_int_in) result(err_msg)
        use num_vars, only: max_it_zero, tol_zero

        ! input / output
        real(dp), intent(inout) :: zero                                         !< output
        interface
            function fun(x)                                                     ! the function
                use num_vars, only: dp
                real(dp), intent(in) :: x
                real(dp) :: fun
            end function fun
        end interface
        real(dp), intent(in) :: x_int_in(2)                                     !< interval
        character(len=max_str_ln) :: err_msg                                    !< possible error message

        ! local variables
        logical :: converged                                                    ! whether converged
        integer :: jd                                                           ! counter
        integer :: id_loc                                                       ! local id (either 1 or 2)
        real(dp) :: x_int(2)                                                    ! points of current interval [a,b]
        real(dp) :: x_mid                                                       ! x at midpoint [c]
        real(dp) :: x_rule                                                      ! x found with rule [s]
        real(dp) :: x_temp                                                      ! temporary x
        real(dp) :: fun_int(2)                                                  ! function at x_int
        real(dp) :: fun_mid                                                     ! function at x_mid
        real(dp) :: fun_rule                                                    ! function at x_rule
#if ldebug
        real(dp), allocatable :: x_ints(:,:)                                    ! bounds for all steps
#endif

        ! initialize error message and zero
        err_msg = ''
        zero = 0.0_dp

        ! initialize from input
        x_int(1) = minval(x_int_in)
        x_int(2) = maxval(x_int_in)
        fun_int = [fun(x_int(1)),fun(x_int(2))]

        ! test whether already zero
        if (abs(fun_int(1)).lt.tol_zero) then
            zero = x_int(1)
            return
        end if
        if (abs(fun_int(2)).lt.tol_zero) then
            zero = x_int(2)
            return
        end if

        ! test whether different sign
        if (product(fun_int).gt.0) then
            err_msg = 'Function values on starting interval have same sign'
            return
        end if

        ! intialize converged
        converged = .false.

#if ldebug
        if (debug_calc_zero) then
            ! set up x_ints
            allocate(x_ints(max_it_zero,2))
        end if
#endif

        ! iterations
        do jd = 1,max_it_zero
            ! calculate midpoint and function value
            x_mid = 0.5_dp*sum(x_int)
            fun_mid = fun(x_mid)

            if (abs(fun_int(1)-fun_mid).gt.tol_zero .and. &
                &abs(fun_int(2)-fun_mid).gt.tol_zero) then
                ! three  different  function   values:   use  inverse  quadratic
                ! interpolation
                x_rule = fun_mid*fun_int(2)*x_int(1)/&
                    &((fun_int(1)-fun_mid)*(fun_int(1)-fun_int(2))) + &
                    &fun_int(1)*fun_int(2)*x_mid/&
                    &((fun_mid-fun_int(1))*(fun_mid-fun_int(2))) + &
                    &fun_int(1)*fun_mid*x_int(2)/&
                    &((fun_int(2)-fun_mid)*(fun_int(2)-fun_mid))

                if (x_int(1).lt.x_rule .and. x_rule.lt.x_int(2)) then
                    ! found x within interval
                else
                    ! use bisection instead
                    if (fun_int(1)*fun_mid.lt.0) then                           ! [a,c] contains sign change
                        id_loc = 1
                    else if (fun_int(2)*fun_mid.lt.0) then                      ! [b,c] contains sign change
                        id_loc = 2
                    else
                        err_msg = 'Something went wrong...'
                        converged = .true.
                    end if
                    if (.not.converged) x_rule = 0.5_dp*(x_int(id_loc)+x_mid)
                end if
            else
                ! two function values overlap so use secant rule
                if (fun_int(1)*fun_mid.lt.0) then                               ! [a,c] contains sign change
                    id_loc = 1
                else if (fun_int(2)*fun_mid.lt.0) then                          ! [b,c] contains sign change
                    id_loc = 2
                else
                    err_msg = 'Something went wrong...'
                    converged = .true.
                end if
                if (.not.converged) x_rule = x_int(id_loc) - &
                    &fun_int(id_loc)*(x_int(id_loc)-x_mid)/&
                    &(fun_int(id_loc)-fun_mid)
            end if

            ! calculate fun(s)
            fun_rule = fun(x_rule)

            ! make sure x_mid < x_rule
            if (x_mid.gt.x_rule) then
                x_temp = x_rule
                x_rule = x_mid
                x_mid = x_temp
            end if

            ! check whether [c,s] contains root
            if (fun_mid*fun_rule.lt.0) then
                x_int(1) = x_mid
                x_int(2) = x_rule
            else
                if (fun_int(1)*fun_mid.lt.0) then
                    x_int(2) = x_mid
                else
                    x_int(1) = x_rule
                end if
            end if

#if ldebug
            if (debug_calc_zero) then
                x_ints(jd,:) = x_int
            end if
#endif

            ! check for convergence
            fun_int = [fun(x_int(1)),fun(x_int(2))]
            if (abs(fun_int(1)).lt.tol_zero) then
                zero = x_int(1)
                converged = .true.
            end if
            if (abs(fun_int(2)).lt.tol_zero) then
                zero = x_int(2)
                converged = .true.
            end if
            if ((x_int(2)-x_int(1)).lt.tol_zero) then
                zero = 0.5_dp*sum(x_int)
                converged = .true.
            end if

            if (converged) then
#if ldebug
                if (debug_calc_zero) call plot_evolution(x_ints(1:jd,:))
#endif
                return
            end if
        end do
#if ldebug
    contains
        ! plots corrections
        !> \private
        subroutine plot_evolution(x_ints)
            ! input / output
            real(dp), intent(in) :: x_ints(:,:)                                 ! x_intervals

            ! local variables
            real(dp) :: min_x, max_x                                            ! min. and max. x for which to plot the function
            integer :: n_x = 200                                                ! how many x values to plot
            integer :: n_ints                                                   ! nr. of intervals
            real(dp), allocatable :: x_out(:)                                   ! output x of plot
            real(dp), allocatable :: y_out(:)                                   ! output y of plot

            ! set up nr. of intervals
            n_ints = size(x_ints,1)

            ! set up min and max x
            min_x = x_int_in(1)
            max_x = x_int_in(2)

            ! set up output of plot
            allocate(x_out(n_x))
            allocate(y_out(n_x))
            x_out = [(min_x+(max_x-min_x)*(jd-1._dp)/(n_x-1),jd=1,n_x)]
            y_out = [(fun(min_x+(max_x-min_x)*(jd-1._dp)/(n_x-1)),jd=1,n_x)]

            ! plot function
            call writo('Initial interval: ['//trim(r2str(x_int_in(1)))//&
                &'..'//trim(r2str(x_int_in(2)))//']')
            call writo('Resulting zero: '//trim(r2str(zero)))
            call print_ex_2D('function','',y_out,x=x_out)

            ! user output
            call writo('Final interval ['//trim(r2str(x_ints(n_ints,1)))//&
                &'..'//trim(r2str(x_ints(n_ints,2)))//'] with tolerance '//&
                &trim(r2strt(tol_zero)))

            ! plot intervals
            call print_ex_2D(['x_intervals'],'',x_ints)
        end subroutine plot_evolution
#endif
    end function calc_zero_Zhang
end module num_ops