subroutine SHrtoc(rcilm, ccilm, degmax, convention, switchcs)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subroutine will convert the real "geodesy 4-pi" spherical harmonic coefficients into
!	complex form with either a 4 pi or unit normalization. The complex
!	coefficients are only calculated for positive m's (the negative m's are given by
!
!		c_l,m* = (-1)^m c_l,-m
!
!	This sign convention is designed to be used with the spherical haromic rotation routines
!	taken from Mark Simons' code. If degmax is not specified, then the maximum degree of the
!	conversion is taken from the size of the input arrays.
!
!
!	Calling Parameters
!		IN
!			rcilm		Real "geodesy" spherical harmonic coefficients with dimensions
!					(2, lmax+1, lmax+1).
!		OUT
!			ccilm		Complex unity-normalized spherical harmonic coefficients, dimensioned
!					as (2, lmax+1, lmax+1). The first index corresponds to the real and
!					complex coefficients, respectively.
!		OPTIONAL
!			degmax		Maximum degree of conversion to be performed.
!			convention	1=output 4-pi normalized coefficients
!					2=output  Varshalovich et al. normalized coefficients
!			switchcs	If 1, Change between different Condon-Shortley phase convenctions.
!					If 0, use consistent phase convention.
!
!		Dependencies:	None
!
!
!	Written by Mark Wieczorek (August 2003)
!	June 4 2006: Added optional argument to change between Condon-Shortley phase conventions.
!
!	Copyright (c) 2005-2006, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	real*8, intent(in) :: 		rcilm(:,:,:)
	real*8, intent(out) ::	 	ccilm(:,:,:)
	integer, intent(in), optional ::	degmax, convention, switchcs
	integer :: 			lmax, l, m
	real*8 ::			pi

	if (present(switchcs)) then
		if (switchcs /= 1 .and. switchcs /=0) then
			print*, "Error --- SHrtoc"
			print*, "switchcs must be equal to either 0 (keep same convention) of 1 (change Condon-Shortley phase)"
			print*, "Input value is ", switchcs
			stop
		endif
	endif

	if (present(convention) ) then
		if (convention /=1 .and. convention /=2) then
			print*, "Error --- SHrtoc"
			print*, "CONVENTION must be 1 or 2."
			print*, "Input valuse is ", convention
			stop
		endif
	endif

	if (present(degmax)) then
		lmax = degmax
		if (size(rcilm(:,1,1)) < 2 .or. size(rcilm(1,:,1)) < lmax +1 .or. size(rcilm(1,1,:)) < lmax +1) then
			print*, "Error --- SHrtoc"
			print*, "RCILM must be dimensioned as (2, DEGMAX+1, DEGMAX+1) where DEGMAX is ", degmax
			print*, "Input array is dimensioned as ", size(rcilm(:,1,1)), size(rcilm(1,:,1)),  size(rcilm(1,1,:))
			stop
		elseif (size(ccilm(:,1,1)) < 2 .or. size(ccilm(1,:,1)) < lmax +1 .or. size(ccilm(1,1,:)) < lmax +1) then
			print*, "Error --- SHrtoc"
			print*, "CCILM must be dimensioned as (2, DEGMAX+1, DEGMAX+1) where DEGMAX is ", degmax
			print*, "Input array is dimensioned as ", size(ccilm(:,1,1)), size(ccilm(1,:,1)),  size(ccilm(1,1,:))
			stop

		endif
	else
		if (size(rcilm(:,1,1)) < 2) then
			print*, "Error --- SHrtoc"
			print*, "RCILM must be dimensioned as (2,*,*)."
			print*, "Input array is dimensioned as ",  size(rcilm(:,1,1)), size(rcilm(1,:,1)), size(rcilm(1,1,:))
			stop
		elseif (size(ccilm(:,1,1)) < 2) then
			print*, "Error --- SHrtoc"
			print*, "CCILM must be dimensioned as (2,*,*)."
			print*, "Input array is dimensioned as ",  size(ccilm(:,1,1)), size(ccilm(1,:,1)), size(ccilm(1,1,:))
			stop
		endif

		lmax = min(size(rcilm(1,1,:)) -1, size(ccilm(1,1,:)) -1, size(rcilm(1,:,1)) -1, size(ccilm(1,:,1)) -1)

	endif

	pi = acos(-1.0d0)
	ccilm= 0.0d0

	do l = 0, lmax, 1

		if (present(convention) ) then
			if (convention == 2) then
				ccilm(1,l+1, 1) = sqrt(4.0d0*pi)*rcilm(1,l+1,1)
				ccilm(2,l+1, 1) = 0.0d0

				do m=1, l, 1
					if (present(switchcs)) then
						if (switchcs == 1) then
							ccilm(1, l+1, m+1) = sqrt(2.0d0*pi) * rcilm(1,l+1,m+1) * (-1.0d0)**m
							ccilm(2, l+1, m+1) = -sqrt(2.0d0*pi) * rcilm(2,l+1,m+1) * (-1.0d0)**m
						else
							ccilm(1, l+1, m+1) = sqrt(2.0d0*pi) * rcilm(1,l+1,m+1)
							ccilm(2, l+1, m+1) = -sqrt(2.0d0*pi) * rcilm(2,l+1,m+1)
						endif
					else
						ccilm(1, l+1, m+1) = sqrt(2.0d0*pi) * rcilm(1,l+1,m+1)
						ccilm(2, l+1, m+1) = -sqrt(2.0d0*pi) * rcilm(2,l+1,m+1)
					endif
				enddo
			endif

		else
			ccilm(1,l+1, 1) = rcilm(1,l+1,1)
			ccilm(2,l+1, 1) = 0.0d0

			do m=1, l, 1
				if (present(switchcs)) then
					if (switchcs == 1) then
						ccilm(1, l+1, m+1) = rcilm(1,l+1,m+1)/sqrt(2.0d0) * (-1.0d0)**m
						ccilm(2, l+1, m+1) = -rcilm(2,l+1,m+1)/sqrt(2.0d0) * (-1.0d0)**m
					else
						ccilm(1, l+1, m+1) = rcilm(1,l+1,m+1)/sqrt(2.0d0)
						ccilm(2, l+1, m+1) = -rcilm(2,l+1,m+1)/sqrt(2.0d0)
					endif
				else
					ccilm(1, l+1, m+1) = rcilm(1,l+1,m+1)/sqrt(2.0d0)
					ccilm(2, l+1, m+1) = -rcilm(2,l+1,m+1)/sqrt(2.0d0)
				endif
			enddo
		endif

	enddo

end subroutine SHrtoc

subroutine SHctor(ccilm, rcilm, degmax, convention, switchcs)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subroutine will convert either "geodesy 4-pi" or "Varshalovich et al." complex spherical
!	harmonic coefficients into real "geodesy 4-pi" spherical harmonic coefficients.
!
!	If degmax is not specified, then the maximum degree of the
!	conversion is taken from the size of the input arrays.
!
!
!	Calling Parameters
!		IN
!			ccilm		Complex unity-normalized spherical harmonic coefficients, dimensioned
!					as (2, lmax+1, lmax+1). The first index corresponds to the real and
!					complex coefficients, respectively.
!		OUT
!			rcilm		Real "geodesy" spherical harmonic coefficients with dimensions
!					(2, lmax+1, lmax+1).
!		OPTIONAL
!			degmax		Maximum degree of conversion to be performed.
!			convention	1=input coefficients are 4-pi normalized
!					2=input coefficients are Varshalovich et al. normalized.
!			switchcs	If 1, Change between different Condon-Shortley phase convenctions.
!					If 0, use consistent phase convention.
!
!		Dependencies:	None
!
!	Written by Mark Wieczorek 2004.
!	June 4 2006: Added option to change between Condon-Shortley phase conventions.
!
!	Copyright (c) 2005-2006, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	real*8, intent(in) :: ccilm(:,:,:)
	real*8, intent(out) :: rcilm(:,:,:)
	integer, intent(in), optional ::	degmax, convention, switchcs
	integer ::	lmax, l, m
	real*8 ::	pi

	if (present(switchcs)) then
		if (switchcs /= 1 .and. switchcs /=0) then
			print*, "Error --- SHrtoc"
			print*, "switchcs must be equal to either 0 (keep same convention) of 1 (change Condon-Shortley phase)"
			print*, "Input value is ", switchcs
			stop
		endif
	endif

	if (present(convention) ) then
		if (convention /=1 .and. convention /=2) then
			print*, "Error --- SHrtoc"
			print*, "CONVENTION must be 1 or 2."
			print*, "Input valuse is ", convention
			stop
		endif
	endif

	if (present(degmax)) then
		lmax = degmax
		if (size(rcilm(:,1,1)) < 2 .or. size(rcilm(1,:,1)) < lmax +1 .or. size(rcilm(1,1,:)) < lmax +1) then
			print*, "Error --- SHrtoc"
			print*, "RCILM must be dimensioned as (2, DEGMAX+1, DEGMAX+1) where DEGMAX is ", degmax
			print*, "Input array is dimensioned as ", size(rcilm(:,1,1)), size(rcilm(1,:,1)),  size(rcilm(1,1,:))
			stop
		elseif (size(ccilm(:,1,1)) < 2 .or. size(ccilm(1,:,1)) < lmax +1 .or. size(ccilm(1,1,:)) < lmax +1) then
			print*, "Error --- SHrtoc"
			print*, "CCILM must be dimensioned as (2, DEGMAX+1, DEGMAX+1) where DEGMAX is ", degmax
			print*, "Input array is dimensioned as ", size(ccilm(:,1,1)), size(ccilm(1,:,1)),  size(ccilm(1,1,:))
			stop

		endif
	else
		if (size(rcilm(:,1,1)) < 2) then
			print*, "Error --- SHrtoc"
			print*, "RCILM must be dimensioned as (2,*,*)."
			print*, "Input array is dimensioned as ",  size(rcilm(:,1,1)), size(rcilm(1,:,1)), size(rcilm(1,1,:))
			stop
		elseif (size(ccilm(:,1,1)) < 2) then
			print*, "Error --- SHrtoc"
			print*, "CCILM must be dimensioned as (2,*,*)."
			print*, "Input array is dimensioned as ",  size(ccilm(:,1,1)), size(ccilm(1,:,1)), size(ccilm(1,1,:))
			stop
		endif

		lmax = min(size(rcilm(1,1,:)) -1, size(ccilm(1,1,:)) -1, size(rcilm(1,:,1)) -1, size(ccilm(1,:,1)) -1)

	endif

	pi = acos(-1.0d0)
	rcilm = 0.0d0

	do l = 0, lmax, 1

		if (present(convention) ) then
			if (convention == 2) then
				rcilm(1,l+1,1) = ccilm(1,l+1,1)/sqrt(4.0d0*pi)
				rcilm(2, l+1, 1) = 0.0d0

				do m=1, l, 1
					if (present(switchcs)) then
						if (switchcs == 1) then
							rcilm(1,l+1, m+1) =  ccilm(1, l+1, m+1) / sqrt(2.0d0*pi) * (-1.0d0)**m
							rcilm(2,l+1, m+1) =  - ccilm(2,l+1,m+1) /sqrt(2.0d0*pi) * (-1.0d0)**m
						else
							rcilm(1,l+1, m+1) =  ccilm(1, l+1, m+1) / sqrt(2.0d0*pi)
							rcilm(2,l+1, m+1) =  - ccilm(2,l+1,m+1) /sqrt(2.0d0*pi)
						endif
					else
						rcilm(1,l+1, m+1) =  ccilm(1, l+1, m+1) / sqrt(2.0d0*pi)
						rcilm(2,l+1, m+1) =  - ccilm(2,l+1,m+1) /sqrt(2.0d0*pi)
					endif
				enddo
			endif

		else

			rcilm(1,l+1,1) = ccilm(1,l+1,1)
			rcilm(2, l+1, 1) = 0.0d0

			do m=1, l, 1
				if (present(switchcs)) then
					if(switchcs == 1) then
						rcilm(1,l+1, m+1) = sqrt(2.0d0) * ccilm(1, l+1, m+1) * (-1.0d0)**m
						rcilm(2,l+1, m+1) = -sqrt(2.0d0) * ccilm(2, l+1, m+1) * (-1.0d0)**m
					else
						rcilm(1,l+1, m+1) = sqrt(2.0d0) * ccilm(1, l+1, m+1)
						rcilm(2,l+1, m+1) = -sqrt(2.0d0) * ccilm(2, l+1, m+1)
					endif
				else
					rcilm(1,l+1, m+1) = sqrt(2.0d0) * ccilm(1, l+1, m+1)
					rcilm(2,l+1, m+1) = -sqrt(2.0d0) * ccilm(2, l+1, m+1)
				endif
			enddo

		endif
	enddo

end subroutine SHctor

subroutine SHCilmToCindex(cilm, cindex, degmax)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This routine will convert a 3D matrix of spherical harmonics indexed as (i, l+1, m+1)
!	into a 2D matrix that is indexed as (i, index) where index = l(l+1)/2+m+1.
!
!	Calling Parameters:
!		IN
!			cilm	Array of spherical harmonic coefficients with dimensions
!				(2, lmax+1, lmax+1).
!		OUT
!			cindex	Array of indexed spherical harmonic coefficnets with dimensions
!				(2, (lmax+1)*(lmax+2)/2).
!
!	Dependencies:	None
!
!	Written by Mark Wieczorek 2004.
!
!	Copyright (c) 2005-2006, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	real*8, intent(in) :: cilm(:,:,:)
	real*8, intent(out) :: cindex(:,:)
	integer, intent(in), optional ::	degmax
	integer :: lmax, l, m, index

	if (present(degmax)) then
		lmax = degmax
		if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax + 1 .or. size(cilm(1,1,:)) < lmax+1 ) then
			print*, "Error --- SHcilmtocindex"
			print*, "CILM must be dimensioned as (2, DEGMAX+1, DEGMAX+1) where DEGMAX is ", degmax
			print*, "Input array is dimensioned ", size(cilm(:,1,1)), size(cilm(1,:,1)), size(cilm(1,1,:))
			stop
		elseif (size(cindex(:,1)) < 2 .or. size(cindex(1,:)) < (lmax+1)*(lmax+2)/2) then
			print*, "Error --- SHcilmtocindex"
			print*, "CINDEX must be dimensioned as (2, (DEGMAX+1)*(DEGMAX+2)/2) where DEGMAX is ", degmax
			print*, "Input array is dimensioned ", size(cindex(:,1)), size(cindex(1,:))
			stop
		endif
	else
		lmax = min(size(cilm(1,1,:)) - 1, size(cilm(1,:,1)) - 1)
		if (size(cilm(:,1,1)) < 2) then
			print*, "Error --- SHcilmtocindex"
			print*, "CILM must be dimensioned as (2, *, *)."
			print*, "Input array is dimensioned ", size(cilm(:,1,1)), size(cilm(1,:,1)), size(cilm(1,1,:))
			stop
		elseif (size(cindex(:,1)) < 2 .or. size(cindex(1,:)) <  (lmax+1)*(lmax+2)/2) then
			print*, "Error --- SHcilmtocindex"
			print*, "CINDEX must be dimensioned as (2, (LMAX+1)*(LMAX+2)/2) where LMAX is ", lmax
			stop
		endif
	endif

	do l=0, lmax
		do m=0, l
			index = l*(l+1)/2+m+1
			cindex(1, index) = cilm(1,l+1,m+1)
			cindex(2, index) = cilm(2,l+1,m+1)
		enddo
	enddo

end subroutine SHCilmToCindex

subroutine SHCindexToCilm(cindex, cilm, degmax)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subroutine will convert a 2D matrix of spherical harmonics indexed as (i, index)
!	into a 2D matrix that is index as (i, l+1, m+1) where index = l(l+1)/2+m+1.
!
!	Calling Parameters:
!		IN
!			cindex	Array of indexed spherical harmonic coefficnets with dimensions
!				(2, (lmax+1)*(lmax+2)/2).
!		OUT
!			cilm	Array of spherical harmonic coefficients with dimensions
!				(2, lmax+1, lmax+1).
!
!	Dependencies:	None
!
!	Written by Mark Wieczorek 2004.
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	real*8, intent(out) :: cilm(:,:,:)
	real*8, intent(in) ::	cindex(:,:)
	integer, intent(in), optional ::	degmax
	integer :: lmax, l, m, index, n

	n = size(cindex(1,:))

	if (present(degmax)) then
		lmax = degmax
		if (lmax > nint((-3.0d0 + sqrt(9.0d0 + 8.0d0*dble(n-2)) )/2.0d0) ) then
			print*, "Error - SHcindextocilm"
			print*, "The output spherical harmonic degree DEGMAX is larger than the input coefficients."
			print*, "Input value of DEGMAX ", degmax
			print*, "Maximum spherical harmonic degree of CINDEX ", nint((-3.0d0 + sqrt(9.0d0 + 8.0d0*dble(n-2)) )/2.0d0)
			stop
		elseif (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax + 1 .or. size(cilm(1,1,:)) < lmax+1 ) then
			print*, "Error --- SHcindextocilm"
			print*, "CILM must be dimensioned as (2, DEGMAX+1, DEGMAX+1) where DEGMAX is ", degmax
			print*, "Input array is dimensioned ", size(cilm(:,1,1)), size(cilm(1,:,1)), size(cilm(1,1,:))
			stop
		endif
	else
		lmax = nint((-3.0d0 + sqrt(9.0d0 + 8.0d0*dble(n-2)) )/2.0d0)

		if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax + 1 .or. size(cilm(1,1,:)) < lmax+1 ) then
			print*, "Error --- SHcindextocilm"
			print*, "CILM must be dimensioned as (2, DEGMAX+1, DEGMAX+1) where DEGMAX is ", degmax
			print*, "Input array is dimensioned ", size(cilm(:,1,1)), size(cilm(1,:,1)), size(cilm(1,1,:))
			stop
		endif
	endif

	do l=0, lmax
		do m=0, l
			index = l*(l+1)/2+m+1
			cilm(1,l+1,m+1) = cindex(1, index)
			cilm(2,l+1,m+1) = cindex(2, index)
		enddo
	enddo

end subroutine SHCindexToCilm


***********************************************************************
*	                    COORD_H2J.F
***********************************************************************
*     PURPOSE: Converts from Heliocentric to Jacobi coords.
*     ARGUMENTS:  Input is
*                    nbod ==> number of  objects (must be less than NBMAX)
*                             (integer)
*	             mass(*) ==> planetary masses (real array)
*		     xh(*),yh(*),zh(*) ==> barycentric particle coords
*                                            (real array)
*		     vxh(*),vyh(*),vzh(*) ==>barycentric particle velocities
*                                             (real array)
*                 Returned are
*                    xj(*),yj(*),zj(*) ==> jacobi. particle positions
*                                             (real array)
*                    vxj(*),vyj(*),vzj(*) ==> jacobi. particle velocities
*                                              (real array)
*
*     ALGORITHM: See my notes Nov 21/92
*     REMARKS:  Note that we set the Jacobi coord of the Sun = 0
*               This is not in accord with the definition, but
*               since we never use the Sun's Jacobi coord, it was the
*               fastest thing to do.
*
*     AUTHOR:  M. Duncan.
*     DATE WRITTEN:  Jan 27, 1993.
*     REVISIONS:  2/17/93 HFL

	subroutine coord_h2j(nbod,mass,xh,yh,zh,vxh,vyh,vzh,
     &      xj,yj,zj,vxj,vyj,vzj)

      include '../swift.inc'

c...  Inputs:
	integer nbod
	real*8 mass(NPLMAX)
	real*8 xh(NPLMAX),yh(NPLMAX),zh(NPLMAX)
	real*8 vxh(NPLMAX),vyh(NPLMAX),vzh(NPLMAX)

c...  Outputs:
	real*8 xj(NPLMAX),yj(NPLMAX),zj(NPLMAX)
	real*8 vxj(NPLMAX),vyj(NPLMAX),vzj(NPLMAX)

c...  Internals:
	real*8 eta(NPLMAX)
	real*8 sumx,sumy,sumz,sumvx,sumvy,sumvz
	real*8 capx,capy,capz,capvx,capvy,capvz
	integer n

c----
c...  Executable code

c First calc. the array eta(*) then convert to jacobi coords

	eta(1) = mass(1)
	do n = 2,nbod
	  eta(n) = eta(n-1) + mass(n)
	enddo

	xj(1) =0.d0
	yj(1) =0.d0
	zj(1) =0.d0
	vxj(1) =0.d0
	vyj(1) =0.d0
	vzj(1) =0.d0

	xj(2) = xh(2)
	yj(2) = yh(2)
	zj(2) = zh(2)
	vxj(2) = vxh(2)
	vyj(2) = vyh(2)
	vzj(2) = vzh(2)

	sumx = mass(2)*xh(2)
	sumy = mass(2)*yh(2)
	sumz = mass(2)*zh(2)
	sumvx = mass(2)*vxh(2)
	sumvy = mass(2)*vyh(2)
	sumvz = mass(2)*vzh(2)

	capx = sumx/eta(2)
	capy = sumy/eta(2)
	capz = sumz/eta(2)
	capvx = sumvx/eta(2)
	capvy = sumvy/eta(2)
	capvz = sumvz/eta(2)

	do n=3,nbod
	  xj(n) = xh(n) - capx
	  yj(n) = yh(n) - capy
	  zj(n) = zh(n) - capz
	  vxj(n) = vxh(n) - capvx
	  vyj(n) = vyh(n) - capvy
	  vzj(n) = vzh(n) - capvz

	  if(n.lt.nbod) then
             sumx = sumx + mass(n)*xh(n)
             sumy = sumy + mass(n)*yh(n)
             sumz = sumz + mass(n)*zh(n)
             sumvx = sumvx + mass(n)*vxh(n)
             sumvy = sumvy + mass(n)*vyh(n)
             sumvz = sumvz + mass(n)*vzh(n)

             capx = sumx/eta(n)
             capy = sumy/eta(n)
             capz = sumz/eta(n)
             capvx =sumvx/eta(n)
             capvy =sumvy/eta(n)
             capvz =sumvz/eta(n)
          endif

	enddo

  	return
	end    ! coord_h2j
c--------------------------------------------------------------------


! ---------------------------------------
!
!   This function calculates whether two cylinders with
!   hemispherical caps intersect.
!   Written by Quinn in Dec, 2017
!   General algorithm for closest approch of two lines by Dan Sunday
!
! ---------------------------------------
#include "../defines.inc"
function cylinders(x1, y1, x2, y2) result(collide)
   use params, only: dp, eps

   implicit none

   real(dp), intent(in) :: x1(3) ! start of segment 1
   real(dp), intent(in) :: y1(3) ! end of segment 1
   real(dp), intent(in) :: x2(3) ! start of segment 2
   real(dp), intent(in) :: y2(3) ! end of segment 2
   logical collide

   real(dp) distance
   real(dp) z1(3) ! nearest point on segment 1
   real(dp) z2(3) ! nearest point on segment 2
   real(dp) v1(3)
   real(dp) v2(3)
   real(dp) ww(3)
   real(dp) t1 ! parameter for distance along line 1. 0-1 is segment
   real(dp) t2
   real(dp) aa, bb, cc, dd, ee
   real(dp) denom
   logical linePoint !function
   real(dp) l1, l2, l3, l4
   real(dp) pp(3)
   real(dp) offset

   ! exclude interaction if it has no chance of happening
   if (min(x1(1), y1(1)) > max(x2(1), y2(1)) + WLC_P__CHAIN_D) then
      collide = .FALSE.
      return
   elseif (min(x2(1), y2(1)) > max(x1(1), y1(1)) + WLC_P__CHAIN_D) then
      collide = .FALSE.
      return
   elseif (min(x1(2), y1(2)) > max(x2(2), y2(2)) + WLC_P__CHAIN_D) then
      collide = .FALSE.
      return
   elseif (min(x2(2), y2(2)) > max(x1(2), y1(2)) + WLC_P__CHAIN_D) then
      collide = .FALSE.
      return
   elseif (min(x1(3), y1(3)) > max(x2(2), y2(2)) + WLC_P__CHAIN_D) then
      collide = .FALSE.
      return
   elseif (min(x2(3), y2(3)) > max(x1(3), y1(3)) + WLC_P__CHAIN_D) then
      collide = .FALSE.
      return
   endif

   v1 = y1 - x1
   v2 = y2 - x2
   ww = x1 - x2
   aa = dot_product(v1, v1)
   bb = dot_product(v1, v2)
   cc = dot_product(v2, v2)
   dd = dot_product(v1, ww)
   ee = dot_product(v2, ww)
   denom = aa*cc - bb*bb

   if (denom < eps) then
      !Nearly parallel
      pp = (y1 - x1)/norm2(y1 - x1)

      l1 = 0.0_dp
      l2 = dot_product(y1 - x1, pp)
      l3 = dot_product(x2 - x1, pp)
      l4 = dot_product(y2 - x1, pp)
      if (min(l1, l2) > max(l3, l4)) then
         offset = min(l1, l2) - max(l3, l4)
      elseif (max(l1, l2) < min(l3, l4)) then
         offset = min(l3, l4) - max(l1, l2)
      else
         offset = 0.0_dp
      endif
      ww = x2 - x1
      ww = ww - pp*dot_product(ww, pp)
      if (dot_product(ww, ww) + offset**2 > WLC_P__CHAIN_D**2) then
         collide = .FALSE.
         return
      else
         !print*, "Nearly parallel collide. offset=",offset
         collide = .True.
         return
      endif
   endif

   t1 = (bb*ee - cc*dd)/denom
   t2 = (aa*ee - bb*dd)/denom

   !print*, "denom=",denom," t1",t1," t2",t2
   if (t1 < 0.0_dp .and. t2 < 0.0_dp) then
      distance = dot_product(x1 - x2, x1 - x2)
      if (distance > WLC_P__CHAIN_D**2) then
         collide = .FALSE.
         return
      else
         !print*, "x ends collide"
         collide = .TRUE.
         return
      endif
   elseif (t1 < 0.0_dp .and. t2 > 1.0_dp) then
      distance = dot_product(x1 - y2, x1 - y2)
      if (distance > WLC_P__CHAIN_D**2) then
         collide = .FALSE.
         return
      else
         !print*, "x1 collides with y2"
         collide = .TRUE.
         return
      endif
   elseif (t1 > 1.0_dp .and. t2 < 0.0_dp) then
      distance = dot_product(y1 - x2, y1 - x2)
      if (distance > WLC_P__CHAIN_D**2) then
         collide = .FALSE.
         return
      else
         !print*, "y1 collides with x2"
         collide = .TRUE.
         return
      endif
   elseif (t1 > 1.0_dp .and. t2 > 1.0_dp) then
      distance = dot_product(y1 - y2, y1 - y2)
      if (distance > WLC_P__CHAIN_D**2) then
         collide = .FALSE.
         return
      else
         !print*, "y1 collides with y2"
         collide = .TRUE.
         return
      endif
   elseif (t1 < 0.0_dp) then
      collide = linePoint(v2, x1 - x2)
   elseif (t1 > 1.0_dp) then
      collide = linePoint(v2, y1 - x2)
   elseif (t2 < 0.0_dp) then
      collide = linePoint(v1, x2 - x1)
   elseif (t2 > 1.0_dp) then
      collide = linePoint(v1, y2 - x1)
   else
      ! intermediate segment
      distance = norm2(x1 - x2 + ((bb*ee - cc*dd)*v1 - (aa*ee - bb*dd)*v2)/denom)
      if (distance > WLC_P__CHAIN_D) then
         collide = .FALSE.
         return
      else
         !print*, "two stick collision"
         collide = .TRUE.
         return
      endif
   endif

end function cylinders

#include "../defines.inc"
function linePoint(vv, xx)
   use precision, only: dp

   implicit none

   real(dp), intent(in) :: vv(3) ! vector
   real(dp), intent(in) :: xx(3) ! point
   logical linePoint
   real(dp) dd(3)
   real(dp) pp(3)

   pp = vv/norm2(vv)
   dd = pp*dot_product(pp, xx) - xx

   if (dot_product(dd, dd) > WLC_P__CHAIN_D**2) then
      linePoint = .FALSE.
      return
   else
      linePoint = .TRUE.
      return
   endif
   return
end function linePoint


module ymom_mod
! Berechnet den Y-Impuls

USE Variablen
USE derivatives_x_mod
USE derivatives_y_mod
USE derivatives_z_mod
USE neumann_mod
contains

subroutine ymom
integer::i,j,h
!delta_u, delta_v , delta_w
! werden als subroutinen genutzt

! dphi Hilfsvariable
! rho_v*u-tau_xy
dphi(1:m_local,1:n_local,1:o_local)=&
rho_v(1:m_local,1:n_local,1:o_local)*&
u(1:m_local,1:n_local,1:o_local)+&
tau_xy(1:m_local,1:n_local,1:o_local)

!ableiten
CALL Dphi_Dx_p(dphi,delta_u,qxi_i,qxi_nr,qxi_r)

! rho_v*v+p-tau_yy
dphi(-1:m_local+2,-1:n_local+2,-1:o_local+2)=&
rho_v(-1:m_local+2,-1:n_local+2,-1:o_local+2)*&
v(-1:m_local+2,-1:n_local+2,-1:o_local+2)+&
p(-1:m_local+2,-1:n_local+2,-1:o_local+2)-&
tau_yy(-1:m_local+2,-1:n_local+2,-1:o_local+2)

!dphi=rho_v*v+p-tau_yy
!ableiten
!CALL Dphi_Dx_p(rho_w,delta_v,qxi_i,qxi_nr,qxi_r)

CALL Dphi_Dy_p(dphi,delta_v,qyi_i,qyi_nr,qyi_r)
!CALL Dphi_Dz_p(rho_w,delta_v,qzi_i,qzi_nr,qzi_r)

! rho_w*v-tau_yz
dphi(1:m_local,1:n_local,1:o_local)=&
rho_w(1:m_local,1:n_local,1:o_local)*&
v(1:m_local,1:n_local,1:o_local)-&
tau_zy(1:m_local,1:n_local,1:o_local)

!ableiten
CALL Dphi_Dz_p(dphi,delta_w,qzi_i,qzi_nr,qzi_r)

!rho_u_neu=rho_u-dt*(delta_u+delta_v+delta_w)
rho_v_neu(1:m_local,1:n_local,1:o_local)=&
rho_v(1:m_local,1:n_local,1:o_local)-&
dt*(delta_u(1:m_local,1:n_local,1:o_local)+&
delta_v(1:m_local,1:n_local,1:o_local)+&
delta_w(1:m_local,1:n_local,1:o_local))

!rho_v_neu=rho_v-dt*(delta_u+delta_v+delta_w)

end subroutine

end module


C/ ------------------------------------------------------------------- /
      PROGRAM W3SPLT
C/
C/                  +-----------------------------------+
C/                  | WAVEWATCH III           NOAA/NCEP |
C/                  |           H. L. Tolman            |
C/                  |                        FORTRAN 77 |
C/                  | Last update :         19-May-1999 |
C/                  +-----------------------------------+
C/
C  1. Purpose :
C
C     Read a WAVEWATCH III version 1.17 point output data file and
C     produces a table of mean parameters for all individual wave
C     systems.
C
C  2. Method :
C
C     Partitioning as devised by Gerling and similar to used in
C     WAM model. From standard input the following data is read :
C
C        name of output point to be considered.
C        name of run of model.
C        name of input file.
C        logical to indentify FORMATTED input file.
C        name of output file.
C
C     All strings are read as characters, therefore no quotes are
C     needed.
C
C  3. Parameters :
C
C     Parameter statements
C     ----------------------------------------------------------------
C       NFR     Int.   Number of frequencies in spectrum.
C       NTH     Int.   Number of directions in spectrum.
C       NPMAX   Int.   Maximum number of peaks to be looked for.
C       NPTAB   Int.   Number of columns in table.
C       HSMIN   Real   Minimum wave height for includion in table.
C       HSDROP  Real   Minimum wave high for system to be considered
C                      as separate wave system.
C       DHSMAX  Real   Max. change in Hs for system to be considered
C                      related to previous time.
C       DTPAX   Real   Id. Tp.
C       DDMMAX  Real   Id. Dm.
C       DDWMAX  Real   Maximum differences in wind and wave direction
C                      for marking of system as under the influence
C                      of the local wind,
C       AGEMIN  Real   Id. wave age.
C     ----------------------------------------------------------------
C
C  4. Subroutines used :
C
C       MPARS   Calculate mean parameters
C       FNDPRT  Get mask for partition.
C       WAVNU2  Solve dispersion relation.
C
C  5. Called by :
C
C     None, main program,
C
C  6. Error messages :
C
C     See "Error escape locations" at end of code.
C
C  7. Remarks :
C
C  8. Structure :
C
C     See source code.
C
C 10. Source code :
C
C/ ------------------------------------------------------------------- /
C/ Parameter statements
C/
      INTEGER         NFR, NTH, NPMAX, NPTAB
      REAL            XFR, HSMIN, HSDROP,
     &                DHSMAX, DTPAX, DDMMAX, DDWMAX, AGEMIN
*
      PARAMETER     ( NFR    =  25    )
      PARAMETER     ( NTH    =  24    )
      PARAMETER     ( NPMAX  =  20    )
      PARAMETER     ( NPTAB  =   6    )
      PARAMETER     ( XFR    =   1.1  )
      PARAMETER     ( HSMIN  =   0.15 )
      PARAMETER     ( HSDROP =   0.05 )
      PARAMETER     ( DHSMAX =   1.5  )
      PARAMETER     ( DTPMAX =   1.5  )
      PARAMETER     ( DDMMAX =  15.   )
      PARAMETER     ( DDWMAX =  30.   )
      PARAMETER     ( AGEMIN =   0.8  )
*
      INTEGER         NDSI, NDSO, IERR, NFRF, NTHF, IFR, ITH
      INTEGER         NPNTS, IP, TIME(2), IREAD
      INTEGER         IFL, IFH, ITHL, ITHH
      INTEGER         NPEAK, NFRP(NPMAX), NTHP(NPMAX), IPNOW, IOUT, ITAB
      INTEGER         NZERO
      REAL            PI, RADE, FR(NFR), TH(NTH), DTH, DFR(NFR),
     &                TAILF, SPEC(NFR,NTH), W1(NFR,NTH), W2(NFR,NTH),
     &                SP1D(NFR), HS, TP, DM, XFRV, STMAX, HMAX
      REAL            HSTOT, HSP(NPMAX), TPP(NPMAX), DMP(NPMAX)
      REAL            HST(NPMAX,2), TPT(NPMAX,2), DMT(NPMAX,2)
      REAL            D, UA, UD, UABS, UDIR, DELDW, DELHS, DELTP, DELDM
      REAL            AFR, WN, CG, AGE, Y, X
      LOGICAL         FORMI, DATA, FLAG(NPMAX), HEADER
      CHARACTER       POINT*10, PID*10, FNAMEI*40, FNAMEO*40, IDSTR*21
      CHARACTER       MODEL*40, RUN*20, GNAME*30, IDLAT*1, IDLON*1
      CHARACTER*129   BLANK, TAIL, STRING
      CHARACTER*15    PART
C/
C/ ------------------------------------------------------------------- /
C/
*
* 1.  Initializations ------------------------------------------------ *
* 1.a Constants etc.
*
      NDSI   = 10
      NDSO   = 50
*
      PI     = 4. * ATAN(1.)
      RADE   = 180. / PI
      XFRV   = XFR
*
      IREAD  = 0
*
      TAIL (  1: 40) = '+-------+-----------+-----------------+-'
      TAIL ( 41: 80) = '----------------+-----------------+-----'
      TAIL ( 81:120) = '------------+-----------------+---------'
      TAIL (120:129) = '---------+'
      BLANK(  1: 40) = '| nn nn |      nn   |                 | '
      BLANK( 41: 80) = '                |                 |     '
      BLANK( 81:120) = '            |                 |         '
      BLANK(120:129) = '         |'
      STRING       = BLANK
*
      DO 100, IP=1, NPTAB
        HST(IP,1) = -1.
        TPT(IP,1) = -1.
        DMT(IP,1) = -1.
  100   CONTINUE
*
* 1.b Initial I/O
*
      WRITE (*,900)
      READ (*,'(A)') POINT
      READ (*,'(A)') RUN
      WRITE (*,901) POINT, RUN
      READ (*,'(A)') FNAMEI
      READ (*,*) FORMI
      WRITE (*,902) FNAMEI, FORMI
      READ (*,'(A)') FNAMEO
      WRITE (*,903) FNAMEO
*
* 1.c Open input file and process header
*
      IF ( FORMI ) THEN
          OPEN (NDSI,FILE=FNAMEI,STATUS='OLD',ERR=800,IOSTAT=IERR)
        ELSE
          OPEN (NDSI,FILE=FNAMEI,STATUS='OLD',
     &               FORM='UNFORMATTED',ERR=800,IOSTAT=IERR)
        ENDIF
      WRITE (*,904)
*
      IF ( FORMI ) THEN
          READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR)
     &          IDSTR, NFRF, NTHF, NPNTS, GNAME
        ELSE
          READ (NDSI , END=801,ERR=802,IOSTAT=IERR)
     &          IDSTR, NFRF, NTHF, NPNTS, GNAME
        ENDIF
*
      IF ( IDSTR .NE. 'WAVEWATCH III SPECTRA' ) GOTO 803
      IF ( NFR.NE.NFRF .OR. NTH.NE.NTHF ) GOTO 804
      WRITE (*,905)
*
      IF ( FORMI ) THEN
          READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) FR
        ELSE
          READ (NDSI , END=801,ERR=802,IOSTAT=IERR) FR
        ENDIF
      WRITE (*,906)
*
      IF ( FORMI ) THEN
          READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) TH
        ELSE
          READ (NDSI , END=801,ERR=802,IOSTAT=IERR) TH
        ENDIF
      WRITE (*,907)
*
      DTH    = 2. * PI / REAL(NTH)
      TAILF  = 0.25 * FR(NFR)
*
      DO 110, IFR=1, NFR
        DFR(IFR) = 0.5 * (XFR-1./XFR) * FR(IFR)
  110   CONTINUE
      DFR(NFR) = 0.5 * DFR(NFR)
      WRITE (*,908)
*
* 1.d Open output file and process header
*
      OPEN (NDSO,FILE=FNAMEO,ERR=810,IOSTAT=IERR)
      WRITE (*,909)
      HEADER = .TRUE.
*
* === LOOP OVER DATA ================================================= *
*
  200 CONTINUE
*
* 2.  Read next data ------------------------------------------------- *
*
      IF ( FORMI ) THEN
          READ (NDSI,*,END=888,ERR=802,IOSTAT=IERR) TIME
        ELSE
          READ (NDSI , END=888,ERR=802,IOSTAT=IERR) TIME
        ENDIF
*
      DATA   = .FALSE.
      DO 210, IP=1, NPNTS
        IF ( FORMI ) THEN
            READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR)
     &                                     PID, Y, X, D, UA, UD
          ELSE
            READ (NDSI , END=801,ERR=802,IOSTAT=IERR)
     &                                     PID, Y, X, D, UA, UD
          ENDIF
        IF ( PID .EQ. POINT ) THEN
            IF ( FORMI ) THEN
                READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) SPEC
              ELSE
                READ (NDSI , END=801,ERR=802,IOSTAT=IERR) SPEC
              ENDIF
            DATA   = .TRUE.
            UABS   = UA
            UDIR   = MOD( UD+180., 360. )
          ELSE
            IF ( FORMI ) THEN
                READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) W1
              ELSE
                READ (NDSI , END=801,ERR=802,IOSTAT=IERR) W1
              ENDIF
          ENDIF
  210   CONTINUE
*
      IF ( .NOT. DATA ) GOTO 805
      IREAD  = IREAD + 1
*
      IF ( HEADER ) THEN
          X      = MOD ( X+720. , 360. )
          IF ( X .LE. 180. ) THEN
              IDLON  = 'E'
            ELSE
              X      = 360. - X
              IDLON  = 'W'
            ENDIF
          IF ( ABS(Y) .LE. 0.0049 ) THEN
              IDLAT  = ' '
            ELSE IF ( Y .GT. 0. ) THEN
              IDLAT  = 'N'
            ELSE
              IDLAT  = 'S'
              X      = -X
            ENDIF
          WRITE (NDSO,950) POINT, Y, IDLAT, X, IDLON, GNAME, RUN
          WRITE (NDSO,951) TAIL
          WRITE (NDSO,952)
          WRITE (NDSO,951) TAIL
          HEADER = .FALSE.
        ENDIF
*
* 3.  Get overall wave height ---------------------------------------- *
*
      DO 310, ITH=1, NTH
        DO 300, IFR=1, NFR
          W1(IFR,ITH) = 1.
  300     CONTINUE
  310   CONTINUE
*
      CALL MPARS ( NFR, NTH, SPEC, W1, FR, TH, DFR, DTH, TAILF, XFRV,
     &             SP1D, HS, TP, DM )
*
      HSTOT  = HS
*
* 4.  Determine maxima ----------------------------------------------- *
*
      NPEAK  = 0
*
      DO 410, IFR=NFR, 1, -1
        IFL    = MAX ( 1 , IFR-1 )
        IFH    = MIN ( NFR , IFR+1 )
        DO 400, ITH=1, NTH
          ITHL   = 1 + MOD(NTH+ITH-2,NTH)
          ITHH   = 1 + MOD(ITH,NTH)
          IF ( SPEC(IFR,ITH) .GE. SPEC(IFL,ITH ) .AND.
     &         SPEC(IFR,ITH) .GE. SPEC(IFH,ITH ) .AND.
     &         SPEC(IFR,ITH) .GE. SPEC(IFL,ITHL) .AND.
     &         SPEC(IFR,ITH) .GE. SPEC(IFR,ITHL) .AND.
     &         SPEC(IFR,ITH) .GE. SPEC(IFH,ITHL) .AND.
     &         SPEC(IFR,ITH) .GE. SPEC(IFL,ITHH) .AND.
     &         SPEC(IFR,ITH) .GE. SPEC(IFR,ITHH) .AND.
     &         SPEC(IFR,ITH) .GE. SPEC(IFH,ITHH) .AND.
     &         SPEC(IFR,ITH) .GT. 0.             ) THEN
              NPEAK  = NPEAK + 1
              NFRP(NPEAK) = IFR
              NTHP(NPEAK) = ITH
            ENDIF
          W1(IFR,ITH) = 0.
  400     CONTINUE
  410   CONTINUE
*
      IF ( NPEAK .LE. NPMAX ) THEN
          WRITE (*,910) TIME, NPEAK
        ELSE
          NPEAK  = NPMAX
          WRITE (*,911) TIME, NPEAK
        ENDIF
*
* 5.  Process all partial fields ------------------------------------- *
*
      NZERO  = 0
*
      DO 500, IP=1, NPEAK
*
        CALL FNDPRT ( NFR, NTH, NFRP(IP), NTHP(IP), SPEC, W1, W2 )
*
        CALL MPARS ( NFR, NTH, SPEC, W2, FR, TH, DFR, DTH, TAILF, XFRV,
     &               SP1D, HSP(IP), TPP(IP), DMP(IP) )
        IF ( HSP(IP) .LE. HSDROP ) NZERO = NZERO + 1
*
  500   CONTINUE
*
      DO 510, IP=NPEAK+1, NPMAX
        HSP(IP) =    0.00
        TPP(IP) = -999.99
        DMP(IP) = -999.99
  510   CONTINUE
*
      DO 520, IP=1, NPTAB
        HST(IP,2) = HST(IP,1)
        TPT(IP,2) = TPT(IP,1)
        DMT(IP,2) = DMT(IP,1)
        HST(IP,1) = -1.
        TPT(IP,1) = -1.
        DMT(IP,1) = -1.
  520   CONTINUE
*
* 6.  Generate output table ------------------------------------------ *
* 6.a Time and overall wave height to string
*
      STRING = BLANK
*
      WRITE (STRING(3:4),'(I2)') MOD(TIME(1),100)
      WRITE (STRING(6:7),'(I2)') TIME(2)/10000
      IF ( HSTOT .GT. 0. ) WRITE (STRING(11:14),'(F4.1)') HSTOT
      WRITE (STRING(16:17),'(I2)') NPEAK - NZERO
      IF ( NPEAK.EQ.0 .OR. HSTOT.LT.0.1 ) GOTO 699
*
* 6.b Switch off peak with too low wave height
*
      DO 600, IP=1, NPEAK
        FLAG(IP) = HSP(IP) .GT. HSMIN
  600   CONTINUE
*
* 6.c Find next highest wave height
*
      IOUT   = 0
  601 CONTINUE
*
      HMAX   = 0.
      IPNOW  = 0
      DO 610, IP=1, NPEAK
        IF ( HSP(IP).GT.HMAX .AND. FLAG(IP) ) THEN
            IPNOW  = IP
            HMAX   = HSP(IP)
          ENDIF
  610   CONTINUE
*
* 6.d No more peaks, skip to output
*
      IF ( IPNOW .EQ. 0 ) GOTO 699
*
* 6.e Find matching field
*
      ITAB   = 0
*
      DO 620, IP=1, NPTAB
        IF ( TPT(IP,2) .GT. 0. ) THEN
            DELHS  = ABS ( HST(IP,2) - HSP(IPNOW) )
            DELTP  = ABS ( TPT(IP,2) - TPP(IPNOW) )
            DELDM  = ABS ( DMT(IP,2) - DMP(IPNOW) )
            IF ( DELDM .GT. 180. ) DELDM = 360. - DELDM
            IF ( DELHS.LT.DHSMAX .AND.
     &           DELTP.LT.DTPMAX .AND.
     &           DELDM.LT.DDMMAX ) ITAB = IP
          ENDIF
  620   CONTINUE
*
* 6.f No matching field, find empty fields
*
      IF ( ITAB .EQ. 0 ) THEN
          DO 630, IP=NPTAB, 1, -1
            IF ( TPT(IP,1).LT.0. .AND. TPT(IP,2).LT.0. ) ITAB = IP
  630       CONTINUE
        ENDIF
*
* 6.g Slot in table found, write
*
      IF ( ITAB .NE. 0 ) THEN
*
          WRITE (PART,'(2X,F4.1,F5.1,I4)')
     &           HSP(IPNOW), TPP(IPNOW), NINT(DMP(IPNOW))
          DELDW  = MOD ( ABS ( UDIR - DMP(IPNOW) ) , 360. )
          IF ( DELDW .GT. 180. ) DELDW = 360. - DELDW
          AFR    = 2.*PI/TPP(IPNOW)
          CALL WAVNU2 ( AFR, D, WN, CG, 1.E-5, 15, ICON )
          AGE    = UABS * WN / AFR
          IF ( DELDW.LT.DDWMAX .AND. AGE.GT.AGEMIN ) PART(1:1) = '*'
*
          STRING(5+ITAB*18:19+ITAB*18) = PART
*
          HST(ITAB,1) = HSP(IPNOW)
          TPT(ITAB,1) = TPP(IPNOW)
          DMT(ITAB,1) = DMP(IPNOW)
*
* 6.g No slot in table found, write
*
        ELSE
*
          IOUT   = IOUT + 1
          WRITE (STRING(19:19),'(I1)') IOUT
*
        ENDIF
*
      FLAG(IPNOW) = .FALSE.
      GOTO 601
*
* 6.h End of processing, write line in table
*
  699 CONTINUE
*
      WRITE (NDSO,951) STRING
*
* === BRANCH BACK IN DATA LOOP ======================================= *
*
      GOTO 200
*
*     Error escape locations ----------------------------------------- *
*
c     GOTO 888
*
  800 CONTINUE
      WRITE (*,1000) FNAMEI, IERR
      STOP
*
  801 CONTINUE
      WRITE (*,1001) FNAMEI
      STOP
*
  802 CONTINUE
      WRITE (*,1002) FNAMEI, IERR
      STOP
*
  803 CONTINUE
      WRITE (*,1003) IDSTR, 'WAVEWATCH III SPECTRA'
      STOP
*
  804 CONTINUE
      WRITE (*,1004) NFR, NTH, NFRF, NTHF
      STOP
*
  805 CONTINUE
      WRITE (*,1005) POINT
      STOP
*
  810 CONTINUE
      WRITE (*,1010) FNAMEO, IERR
      STOP
*
  888 CONTINUE
      WRITE (NDSO,951) TAIL
      WRITE (NDSO,953) HSDROP, HSMIN
      WRITE (*,999)
*
*     Format statements ---------------------------------------------- *
*
  900 FORMAT (/' Splitting WAVEWATCH III spectra : '/
     &         ' ----------------------------------')
  901 FORMAT ( '    Location    : ',A/
     &         '    Run ID      : ',A)
  902 FORMAT ( '    Input file  : ',A,'  FORMATTED : ',L1)
  903 FORMAT ( '    Output file : ',A)
*
  904 FORMAT (/'    Input file opened ...')
  905 FORMAT ( '       Header read and processed.')
  906 FORMAT ( '       Frequency info read.')
  907 FORMAT ( '       Direction info read.')
  908 FORMAT ( '       Bin sizes preprocessed.')
*
  909 FORMAT (/'    Output file opened ...')
  910 FORMAT ( '       Processing ',I8.8,' ',I6.6,
     &         '  Number of peaks :',I3)
  911 FORMAT ( '       Processing ',I8.8,' ',I6.6,
     &         '  Number of peaks :',I3,'  (TRUNCATED)')
*
  950 FORMAT ( '  Location : ',A,' (',F5.2,A,1X,F6.2,A,')'/
     &         '  Model    : ',A/
     &         '  Cycle    : ',A)
  951 FORMAT (1X,A)
  952 FORMAT (' | day & |  Hst  n x |     Hs   Tp dir |',
     &                              '     Hs   Tp dir |',
     &                              '     Hs   Tp dir |',
     &                              '     Hs   Tp dir |',
     &                              '     Hs   Tp dir |',
     &                              '     Hs   Tp dir |'/
     &        ' |  hour |  (m)  - - |    (m)  (s) (d) |',
     &                              '    (m)  (s) (d) |',
     &                              '    (m)  (s) (d) |',
     &                              '    (m)  (s) (d) |',
     &                              '    (m)  (s) (d) |',
     &                              '    (m)  (s) (d) |')
  953 FORMAT (
     &  75X,'Hst : Total sigificant wave height.'/
     &  75X,'n   : Number of fields with Hs > ',f6.2,
     &           ' in 2-D spectrum.'/
     &  75X,'x   : Number of fields with Hs > ',f6.2,
     &           ' not in table.'/
     &  75X,'Hs  : Significant wave height of separate wave field.'/
     &  75X,'Tp  : Peak period of separate wave field.'/
     &  75X,'dir : Mean direction of separate wave field.'/
     &  75X,'*   : Wave generation due to local wind probable.')
*
  999 FORMAT (/' End of program '/)
*
 1000 FORMAT (/' *** ERROR IN OPENING INPUT FILE ',A/
     &         '     IOSTAT = ',I8/)
 1001 FORMAT (/' *** PREMATURE END OF INPUT FILE ',A/)
 1002 FORMAT (/' *** ERROR IN READING FROM INPUT FILE ',A/
     &         '     IOSTAT = ',I8/)
 1003 FORMAT (/' *** UNEXPECTED HEADER IN FILE : '/
     &         '     READ     : ',A/
     &         '     EXPECTED : ',A)
 1004 FORMAT (/' *** UNEXPECTED SPECTRAL DIMENSIONS : '/
     &         '     IN PROGRAM :',2I6/
     &         '     IN FILE    :',2I6/)
 1005 FORMAT (/' *** NO DATA FOUND FOR POINT ',A/)
*
 1010 FORMAT (/' *** ERROR IN OPENING OUTPUT FILE ',A/
     &         '     IOSTAT = ',I8/)
C/
C/ End of W3SPLT ----------------------------------------------------- /
C/
      END
C/ ------------------------------------------------------------------- /
      SUBROUTINE MPARS ( NFR, NTH, SPEC, MASK, FREQ, DIR, DFR, DTH,
     &                   TAILF, XFR, SP1D, HS, TP, DM )
C/
C/                  +-----------------------------------+
C/                  | WAVEWATCH III           NOAA/NCEP |
C/                  |           H. L. Tolman            |
C/                  |                        FORTRAN 77 |
C/                  | Last update :         15-Oct-1998 |
C/                  +-----------------------------------+
C/
C  1. Purpose :
C
C     Calculate mean parameters of a spectrum using a mask.
C
C  2. Method :
C
C     Wave height HS : Integral over spectrum using par. tail.
C     Peak period TP : Parabolic fit to 1-D spectrum.
C     Mean direction DM : From first Fourier components.
C
C  3. Parameters :
C
C     Parameter list
C     ----------------------------------------------------------------
C       NFR     Int.   I   Number of frequencies.
C       NTH     Int.   I   Number of directions.
C       SPEC    R.A.   I   Spectrum.
C       MASK    R.A.   I   Mask for spectrumi (real weight function).
C       FREQ    R.A.   I   Frequencies.
C       DIR     R.A.   I   Directions (radians).
C       DFR     R.A.   I   Bind width info for all frequencies.
C       DTH     R.A.   I   Directionsl increment.
C       TAILF   Real   I   Tail factor.
C       XFR     Real   I   Frequency increment factor.
C       SP1D    R.A.   O   1-D spectrum.
C       HS      Real   O   Wave height              -999.99 if undef.
C       TP      Real   O   Peak wave period         -999.99 if undef.
C       DM      Real   O   Mean wave direction      -999.99 if undef.
C     ----------------------------------------------------------------
C
C  4. Subroutines used :
C
C       None.
C
C  5. Called by :
C
C       Any.
C
C 10. Source code :
C
C/ ------------------------------------------------------------------- /
C/ Parameter list
C/
      INTEGER         NFR, NTH
      REAL            SPEC(NFR,NTH), MASK(NFR,NTH), FREQ(NFR), DIR(NTH),
     &                DFR(NFR), DTH, TAILF, XFR, SP1D(NFR), HS, TP, DM
C/
C/ ------------------------------------------------------------------- /
C/ Local parameters
C/
      INTEGER         IFR, ITH, IMAX, ILOW, IHGH
      REAL            COSMOM, SINMOM, TOTMOM, COS0, SIN0, PI, RADE, EMAX
      REAL            XL, XH, XL2, XH2, EL, EH, DENOM, FP
C/
C/ ------------------------------------------------------------------- /
*
      PI     = 4. * ATAN(1.)
      RADE   = 180./PI
*
      XL     = 1./XFR - 1.
      XH     =  XFR - 1.
      XL2    = XL**2
      XH2    = XH**2
*
      COSMOM = 0.
      SINMOM = 0.
      TOTMOM = 0.
*
      DO 110, IFR=1, NFR
*
        SP1D(IFR) = 0.
        COS0      = 0.
        SIN0      = 0.
*
        DO 100, ITH=1, NTH
          SP1D(IFR) = SP1D(IFR) + MASK(IFR,ITH)*SPEC(IFR,ITH)
          COS0      = COS0 + MASK(IFR,ITH)*SPEC(IFR,ITH) * COS(DIR(ITH))
          SIN0      = SIN0 + MASK(IFR,ITH)*SPEC(IFR,ITH) * SIN(DIR(ITH))
  100     CONTINUE
*
        SP1D(IFR) = SP1D(IFR) * DTH
        COSMOM    = COSMOM + COS0 * DTH * DFR(IFR)
        SINMOM    = SINMOM + SIN0 * DTH * DFR(IFR)
        TOTMOM    = TOTMOM + SP1D(IFR)*DFR(IFR)
*
  110   CONTINUE
*
      TOTMOM = TOTMOM + SP1D(NFR)*TAILF
      TOTMOM = MAX ( 0. , TOTMOM )
*
* 2.  Mean parameters ------------------------------------------------ *
* 2.a Set to undefined
*
      HS     =    0.00
      TP     = -999.99
      DM     = -999.99
*
      IF ( TOTMOM .GT. 0. ) THEN
*
* 2.b Wave height
*
          HS     = 4. * SQRT(TOTMOM)
*
* 2.c Mean direction
*
          DM     = RADE * ATAN2(SINMOM,COSMOM)
          IF ( DM .LT. 0. ) DM = DM + 360.
*
* 2.d Peak period
*
          EMAX   = 0.
*
          DO 200, IFR=1, NFR
            IF ( SP1D(IFR) .GT. EMAX ) THEN
                EMAX   = SP1D(IFR)
                IMAX   = IFR
              ENDIF
  200       CONTINUE
*
          ILOW   = MAX (  1 , IMAX-1 )
          IHGH   = MIN ( NFR , IMAX+1 )
          EL     = SP1D(ILOW) - SP1D(IMAX)
          EH     = SP1D(IHGH) - SP1D(IMAX)
          DENOM  = XL*EH - XH*EL
          FP     = FREQ(IMAX) * ( 1. + 0.5 * ( XL2*EH - XH2*EL )
     &                 / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) )
*
          TP     = 1. / FP
*
        ENDIF
*
      RETURN
C/
C/ End of MPARS ------------------------------------------------------ /
C/
      END
C/ ------------------------------------------------------------------- /
      SUBROUTINE FNDPRT ( NFR, NTH, IFRC, ITHC, SPEC, W1, W2 )
C/
C/                  +-----------------------------------+
C/                  | WAVEWATCH III           NOAA/NCEP |
C/                  |           H. L. Tolman            |
C/                  |                        FORTRAN 77 |
C/                  | Last update :         09-Sep-1998 |
C/                  +-----------------------------------+
C/
C  1. Purpose :
C
C     Find partition starting at given peak and given mask.
C
C  2. Method :
C
C  3. Parameters :
C
C     Parameter list
C     ----------------------------------------------------------------
C       NFR     Int.   I   Number of frequencies.
C       NTH     Int.   I   Number of directions.
C       IFRC    Int.   I   Peak discrete frequency.
C       ITHC    Int.   I   Peak discrete direction.
C       SPEC    R.A.   I   Spectrum.
C       W1      R.A.  I/O  Map of bins used so far.
C       W2      R.A.   O   Map of bins used now.
C     ----------------------------------------------------------------
C
C  4. Subroutines used :
C
C       None.
C
C  5. Called by :
C
C       Any.
C
C 10. Source code :
C
C/ ------------------------------------------------------------------- /
C/ Parameter list
C/
      INTEGER         NFR, NTH, IFRC, ITHC
      REAL            SPEC(NFR,NTH), W1(NFR,NTH), W2(NFR,NTH)
C/
C/ ------------------------------------------------------------------- /
C/ Local parameters
C/
      INTEGER         IFR, ITH, IFRL, ITHL
      LOGICAL         CHANGE, ADD
C/
C/ ------------------------------------------------------------------- /
*
* 1.  Set up the W2 map ---------------------------------------------- *
*
      DO 110, IFR=1, NFR
        DO 100, ITH=1, NTH
          W2(IFR,ITH) = 0.
  100     CONTINUE
  110   CONTINUE
*
      IFRL   = MAX ( 1 , IFRC-1 )
      IFRH   = MIN ( NFR , IFRC+1 )
      ITHL   = 1 + MOD(NTH+ITHC-2,NTH)
      ITHH   = 1 + MOD(ITHC,NTH)
*
      DO 130, ITH=ITHC-1, ITHC+1
        ITHL = 1 + MOD(NTH+ITH-1,NTH)
        DO 120, IFR=IFRC-1, IFRC+1
          IFRL = MAX(1,MIN(NFR,IFR))
          IF ( W1(IFRL,ITHL) .LE. 0.5 ) W2(IFRL,ITHL) = 0.5
  120     CONTINUE
  130   CONTINUE
*
      IF ( W1(IFRC,ITHC) .LT. 0.25 ) W2(IFRC,ITHC) = 1.0
*
* 2.  Itterate search ------------------------------------------------ *
*
      NITT   = 0
*
* 2.a Branch point
*
  200 CONTINUE
      NITT   = NITT + 1
      CHANGE = .FALSE.
*
* 2.b Determine central points
*
      DO 240, IFR=1, NFR
        DO 230, ITH=1, NTH
*
          IF ( W2(IFR,ITH).EQ.0.5 .AND. W1(IFR,ITH).LT.0.5 ) THEN
              ADD    = .TRUE.
              DO 220, ITHR=ITH-1, ITH+1
                ITHL = 1 + MOD(NTH+ITHR-1,NTH)
                DO 210, IFRL=MAX(1,IFR-1), MIN(NFR,IFR+1)
                  IF ( W2 (IFRL,ITHL).EQ.0. .AND.
     &                SPEC(IFRL,ITHL).GT.SPEC(IFR,ITH) ) ADD = .FALSE.
  210             CONTINUE
  220           CONTINUE
              IF ( ADD ) W2(IFR,ITH) = 1.
              CHANGE = CHANGE .OR. ADD
            ENDIF
*
  230     CONTINUE
  240   CONTINUE
*
* 2.c Determine central points
*
      DO 280, IFR=1, NFR
        DO 270, ITH=1, NTH
*
          IF ( W2(IFR,ITH).EQ.0. ) THEN
              ADD    = .FALSE.
              DO 260, ITHR=ITH-1, ITH+1
                ITHL = 1 + MOD(NTH+ITHR-1,NTH)
                DO 250, IFRL=MAX(1,IFR-1), MIN(NFR,IFR+1)
                  IF ( W2 (IFRL,ITHL).EQ.1. ) ADD = .TRUE.
  250             CONTINUE
  260           CONTINUE
              IF ( ADD ) W2(IFR,ITH) = 0.5
              CHANGE = CHANGE .OR. ADD
            ENDIF
*
  270     CONTINUE
  280   CONTINUE
*
* 2.d Branch back ?
*
      IF ( CHANGE .AND. NITT.LT.25 ) GOTO 200
*
* 3   Update the overall map ----------------------------------------- *
*
      DO 310, IFR=1, NFR
        DO 300, ITH=1, NTH
          W1(IFR,ITH) = W1(IFR,ITH) + W2(IFR,ITH)
  300     CONTINUE
  310   CONTINUE
*
      RETURN
C/
C/ End of FNDPRT ----------------------------------------------------- /
C/
      END
C/ ------------------------------------------------------------------- /
      SUBROUTINE WAVNU2 (W,H,K,CG,EPS,NMAX,ICON)
C/
C/                  +-----------------------------------+
C/                  | WAVEWATCH III           NOAA/NCEP |
C/                  |           H. L. Tolman            |
C/                  |                        FORTRAN 77 |
C/                  | Last update :         17-Jul-1990 |
C/                  +-----------------------------------+
C/
C  1. Purpose :
C
C     Calculation of wavenumber K from a given angular
C     frequency W and waterdepth H.
C
C  2. Method :
C
C     Used equation :
C                        2
C                       W  = G*K*TANH(K*H)
C
C     Because of the nature of the equation, K is calculated
C     with an itterative procedure.
C
C  3. Parameters :
C
C     Parameter list
C     ----------------------------------------------------------------
C       W       Real   I   Angular frequncy
C       H       Real   I   Waterdepth
C       K       Real   O   Wavenumber ( same sign as W )
C       CG      Real   O   Group velocity (same sign as W)
C       EPS     Real   I   Wanted max. difference between K and Kold
C       NMAX    Int.   I   Max number of repetitions in calculation
C       ICON    Int.   O   Contol counter ( See error messages )
C     ----------------------------------------------------------------
C
C  9. Switches :
C
C     C/S  Enable subroutine tracing.
C
C 10. Source code :
C/
C/ ------------------------------------------------------------------- /
C/ Parameter list
C/
      INTEGER         ICON, NMAX
      REAL            EPS, CG, K, H, W
C/
C/ ------------------------------------------------------------------- /
C/ Local parameters
C/
      INTEGER         I
C/S      INTEGER         IENT
      REAL            G, F, W0, FD, DIF, RDIF, KOLD
C/
C/ ------------------------------------------------------------------- /
C/
      DATA G / 9.81 /
*
*     Initialisations :
*
      CG   = 0
      KOLD = 0
      ICON = 0
      W0   = ABS(W)
*
*     1st approach :
*
      IF (W0.LT.SQRT(G/H)) THEN
          K = W0/SQRT(G*H)
        ELSE
          K = W0*W0/G
        END IF
*
*     Refinement :
*
      DO 7, I=1, NMAX
        DIF = ABS(K-KOLD)
      IF (K.NE.0) THEN
          RDIF = DIF/K
        ELSE
          RDIF = 0
        END IF
      IF (DIF .LT. EPS .AND. RDIF .LT. EPS) THEN
          ICON = 1
          GOTO 8
        ELSE
          KOLD = K
          F    = G*KOLD*TANH(KOLD*H)-W0**2
          IF (KOLD*H.GT.25) THEN
              FD = G*TANH(KOLD*H)
            ELSE
              FD = G*TANH(KOLD*H) + G*KOLD*H/((COSH(KOLD*H))**2)
            END IF
          K    = KOLD - F/FD
        END IF
7       CONTINUE
      DIF   = ABS(K-KOLD)
      RDIF  = DIF/K
      IF (DIF .LT. EPS .AND. RDIF .LT. EPS) ICON = 1
8     CONTINUE
      IF (2*K*H.GT.25) THEN
          CG = W0/K * 0.5
        ELSE
          CG = W0/K * 0.5*(1+(2*K*H/SINH(2*K*H)))
        END IF
      IF (W.LT.0.0) THEN
          K  = (-1)*K
          CG = CG*(-1)
        END IF
*
      RETURN
C/
C/ End of WAVNU2 ----------------------------------------------------- /
C/
      END


      subroutine atod ( qa,qd,im,jm,lm,itype )

C ******************************************************************
C ****                                                          ****
C ****  This program converts 'A' gridded data                  ****
C ****                     to 'D' gridded data.                 ****
C ****                                                          ****
C ****  The D-Grid Triplet is defined as:                       ****
C ****                                                          ****
C ****              u(i,j+1)                                    ****
C ****                |                                         ****
C ****     v(i,j)---delp(i,j)---v(i+1,j)                        ****
C ****                |                                         ****
C ****              u(i,j)                                      ****
C ****                                                          ****
C ****  Thus, v is shifted left (westward),                     ****
C ****        u is shifted down (southward)                     ****
C ****                                                          ****
C ****  An FFT shift transformation is made in x for itype = 1  ****
C ****  An FFT shift transformation is made in y for itype = 2  ****
C ****                                                          ****
C ******************************************************************

      real qa   (im,jm,lm)
      real qd   (im,jm,lm)

      real qax  (   im+2 ,lm)
      real  cx  (2*(im+2),lm)
      real qay  (   2*jm ,lm)
      real  cy  (2*(2*jm),lm)

      real    cosx (im/2), sinx(im/2)
      real    cosy (jm)  , siny(jm)
      real      trigx(3*(im+1))
      real      trigy(3*(2*jm))

      integer IFX (100)
      integer IFY (100)

      jmm1  = jm-1
      jp    = 2*jmm1

      imh   = im/2
      pi    = 4.0*atan(1.0)
      dx    = 2*pi/im
      dy    = pi/jmm1

C *********************************************************
C ****             shift left (-dx/2)                  ****
C *********************************************************

      if (itype.eq.1) then

         call fftfax (im,ifx,trigx)

         do k=1,imh
         thx = k*dx*0.5
         cosx(k) = cos(thx)
         sinx(k) = sin(thx)
         enddo

      do j=1,jm
         do L=1,lm
         do i=1,im
         qax(i,L) = qa(i,j,L)
         enddo
         enddo
         call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm,-1)

         do L=1,lm
         do k=1,imh
         kr = 2*k+1
         ki = 2*k+2
         crprime = qax(kr,L)*cosx(k) + qax(ki,L)*sinx(k)
         ciprime = qax(ki,L)*cosx(k) - qax(kr,L)*sinx(k)
         qax(kr,L) = crprime
         qax(ki,L) = ciprime
         enddo
         enddo

         call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm, 1)
         do L=1,lm
         do i=1,im
         qd(i,j,L) = qax(i,L)
         enddo
         enddo
      enddo

      endif

C *********************************************************
C ****             shift down (-dy/2)                  ****
C *********************************************************

      if (itype.eq.2) then

         call fftfax (jp,ify,trigy)

         do L=1,jmm1
         thy = L*dy*0.5
         cosy(L) = cos(thy)
         siny(L) = sin(thy)
         enddo

      do i=1,imh
         do L=1,lm
         do j=1,jmm1
         qay(j,L)      =  qa(i,j+1,L)
         qay(j+jmm1,L) = -qa(i+imh,jm-j,L)
         enddo
         enddo

         call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm,-1)

         do L=1,lm
         do k=1,jmm1
         kr = 2*k+1
         ki = 2*k+2
         crprime = qay(kr,L)*cosy(k) + qay(ki,L)*siny(k)
         ciprime = qay(ki,L)*cosy(k) - qay(kr,L)*siny(k)
         qay(kr,L) = crprime
         qay(ki,L) = ciprime
         enddo
         enddo

         call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm, 1)

         do L=1,lm
         do j=1,jmm1
         qd(i,j+1,L)        =  qay(j,L)
         qd(i+imh,jm-j+1,L) = -qay(j+jmm1,L)
         enddo
         enddo
      enddo
      endif

      return
      end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
program xqtess
!
!   Test driver of "qtess", the quadruple precision Fortran subroutine to compute
!   the gravitational potential/acceleration/gradient tensor of a tesseroid.
!
!    Reference:
!           Fukushima T (2018) Accurate computation of gravitational field of a tesseroid.
!                Journal of Geodesy 92(12):1371–1386, doi:10.1007/s00190-018-1126-2
!
implicit integer (i-n)
implicit real*16 (q)
implicit real*8 (a-h,o,p,r-z)
!
qPI=atan(1.q0)*4.q0
qraddeg=qPI/180.q0
qdelta=1.q-33
write (*,"(a15,1pe15.7)") "# qdelta=", qdelta
!
!   A sample tesseroid covering an eastern Himalaya:
!   (Note) Mt. Everest: h = 8.848 km, phi = 27 deg 59 min, lat = 86 deg 55 min
!
qR0=6380.q0
qHB=-40.q0
qHT=10.q0
qPhiS=27.q0*qraddeg
qPhiN=28.q0*qraddeg
qFlamW=86.q0*qraddeg
qFlamE=87.q0*qraddeg
!
!   Test evaluation points are located along a radial straight line passing through
!    the geometrical center of the tesseroid
!
qphi=27.5q0*qraddeg
qflam=86.5q0*qraddeg
!
write (*,"(a15,1p3e15.7)") "# R0,HT,HB=",qR0,qHT,qHB
write (*,"(a15,1p2e15.7)") "# PhiN,PhiS=",qPhiN/qraddeg,qPhiS/qraddeg
write (*,"(a15,1p2e15.7)") "# LamdaE,LamdaW=",qFlamE/qraddeg,qFlamW/qraddeg
write (*,"(a15,1p2e15.7)") "# phi,lambda=",qphi/qraddeg,qflam/qraddeg
write (*,"(a15,a45)") "# H","V"
write (*,"(a15,3a45)") "#","gPhi","gLambda","gH"
write (*,"(a15,3a45)") "#","GammaPhiPhi","GammaPhiLambda","GammaPhiH"
write (*,"(a15,3a45)") "#","GammaLambdaLambda","GammaLambdaH","GammaHH"
!
!    Compute the field at the reference sphere
!
qh=0.q0
!
call cpu_time(time_begin)
call qtess(qPhiN,qPhiS,qFlamE,qFlamW,qHT,qHB,qR0,qdelta, &
    qphi,qflam,qh,qv,qgPhi,qgLam,qgH, &
    qggPhiPhi,qggPhiLam,qggPhiH,qggLamLam,qggLamH,qggHH)
write (*,"(1pe15.7,1pe45.35)") qh,qv
write (*,"(15x,1p3e45.35)") qgPhi,qgLam,qgH
write (*,"(15x,1p3e45.35)") qggPhiPhi,qggPhiLam,qggPhiH
write (*,"(15x,1p3e45.35)") qggLamLam,qggLamH,qggHH
!
call cpu_time(time_end)
write(*,*) "The total time is",time_end-time_begin,"seconds."
stop
end program xqtess
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine qtess(PhiN0,PhiS0,FlamE0,FlamW0,HT0,HB0,R00,delta0, &
    phi,flam,h, &
    v,gPhi,gLam,gH,ggPhiPhi,ggPhiLam,ggPhiH,ggLamLam,ggLamH,ggHH)
!
!   The quadruple precision Fortran subroutine to compute
!   the gravitational potential, V, the gravitational acceleration vector, g,
!   and the gravity gradient tensor, Gamma, of a tesseroid.
!
!   Input parameters:
!       PhiN0: Latitude of the north end point of the tesseroid
!       PhiS0: Latitude of the south end point of the tesseroid, PhiS0 < PhiN0
!       FlamE0: Longitude of the east end point of the tesseroid
!       FlamW0: Longitude of the west end point of the tesseroid, FlamW0 < FlamE0
!       HT0: Height of the top end point of the tesseroid
!       HB0: Height of the bottom end point of the tesseroid, HB0 < HT0
!       R00: Radius of the reference spherical surface from which H is counted
!       delta0: the relative error tolerance (typical value is 1q-24 or 1q-30)
!   Input variables:
!       phi: Latitude of the evaluation point
!       flam: Longitude of the evaluation point
!       h: Height from the reference sphere of the evaluation point
!   Output variables:
!       v: Normalized gravitational potential at the evaluation point
!       (Note) normalization constant: V0 = G rho R00^2
!       gPhi: Latitude component of normalized gravitational acceleration vector
!       gLam: Longitude component of normalized gravitational acceleration vector
!       gH: Height component of normalized gravitational acceleration vector
!       (Note) normalization constant: g0 = G rho R00
!       ggPhiPhi: Latitude-latitude component of normalized Gamma
!       ggPhiLam: Latitude-longitude component of normalized Gamma
!       ggPhiH: Latitude-height component of normalized Gamma
!       ggLamLam: Longitude-longitude component of normalized Gamma
!       ggLamH: Longitude-height component of normalized Gamma
!       ggHH: Height-height component of normalized Gamma
!       (Note) normalization constant: Gamma0 = G rho
!
implicit integer (i-n)
implicit real*16 (a-h,o-z)
!
external qvtess
!
real*16 eps
common /qepsV/eps
real*16 R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
common /qparamV/R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
real*16 delta,delta1,delta2,d1phi,d1lam,d1h,d2phi,d2lam,d2h
common /qdeltaV/delta,delta1,delta2,d1phi,d1lam,d1h,d2phi,d2lam,d2h
!
PhiN=PhiN0
PhiS=PhiS0
FlamE=FlamE0
FlamW=FlamW0
HT=HT0
HB=HB0
R0=R00
eps=delta0
delta=delta0
delta1=delta**(1.q0/3.q0)
delta2=sqrt(sqrt(delta))
!
deltaH=HT-HB
deltaPhi=PhiN-PhiS
deltaFlam=FlamE-FlamW
beta=deltaH/R0
RC=R0+(HT+HB)*0.5q0
PhiC=(PhiN+PhiS)*0.5q0
FlamC=(FlamE+FlamW)*0.5q0
sinPhiC=sin(PhiC)
cosPhiC=cos(PhiC)
!
r=R0+h
sinphi=sin(phi)
cosphi=cos(phi)
cosdlam=cos(flam-FlamC)
scale0=0.5q0*sqrt(deltaH*deltaH+RC*RC*(deltaPhi*deltaPhi &
    +cosPhiC*cosPhiC*deltaFlam*deltaFlam))
scale1=sqrt(r*r+RC*RC-2.q0*RC*r*(sinphi*sinPhiC+cosphi*cosPhiC*cosdlam))
scale=max(scale0,scale1)
d1h=scale*delta1
d2h=scale*delta2
! add d1phi, d1lam
d1phi=d1h/r
d1lam=d1h/(r*cosphi)
! add d2phi, d2lam
d2phi=d2h/r
d2lam=d2h/(r*cosphi)
!
v=qvtess(phi,flam,h)
call qgtess(qvtess,phi,flam,h,v,gPhi,gLam,gH)
call qggtess(qvtess,phi,flam,h,v,gPhi,gLam,gH, &
    ggPhiPhi,ggPhiLam,ggPhiH,ggLamLam,ggLamH,ggHH)
!
return;end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
real*16 function qvtess(phi,flam,h)
!
!   The quadruple precision Fortran function to compute
!   the gravitational potential by the conditional split quadrature method
!
implicit integer (i-n)
implicit real*16 (a-h,o-z)
!
external qstess
!
real*16 eps
common /qepsV/eps
real*16 R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
common /qparamV/R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
real*16 phi0,flam0,h0,xiN,xiS,etaE,etaW
common /qargV/phi0,flam0,h0,xiN,xiS,etaE,etaW
real*16 alpha,gamma,zetaT,zetaB,sigma,fmu
common /qparamV2/alpha,gamma,zetaT,zetaB,sigma,fmu
!
phi0=phi
flam0=flam
h0=h
!
xiN=PhiN-phi
xiS=PhiS-phi
etaE=FlamE-flam
etaW=FlamW-flam
!
alpha=1.q0+h/R0
gamma=cos(phi)
zetaB=(HB-h)/R0
zetaT=zetaB+beta
!
!   Split quadrature
!
if(xiS.lt.0.q0.and.xiN.gt.0.q0) then
    call qqde(qstess,xiS,0.q0,eps,v1)
    call qqde(qstess,0.q0,xiN,eps,v2)
    v=v1+v2
else
    call qqde(qstess,xiS,xiN,eps,v)
endif
qvtess=v
!
return; end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
real*16 function qstess(xi)
!
!   The quadruple precision Fortran function to compute
!   the latitude line integral requried in "vtess"
!
implicit integer (i-n)
implicit real*16 (a-h,o-z)
!
external qvkern
!
real*16 eps
common /qepsV/eps
real*16 phi0,flam0,h0,xiN,xiS,etaE,etaW
common /qargV/phi0,flam0,h0,xiN,xiS,etaE,etaW
real*16 alpha,gamma,zetaT,zetaB,sigma,fmu
common /qparamV2/alpha,gamma,zetaT,zetaB,sigma,fmu
!
sigma=cos(phi0+xi)
fmu=sin(xi*0.5q0)
!
!   Split quadrature
!
if(etaW.lt.0.q0.and.etaE.gt.0.q0) then
    call qqde1(qvkern,etaW,0.q0,eps,s1)
    call qqde1(qvkern,0.q0,etaE,eps,s2)
    s=s1+s2
else
    call qqde1(qvkern,etaW,etaE,eps,s)
endif
qstess=s
!write (*,"(a15,1p2e15.7)") "(qstess) xi,s=",xi,s
!
return; end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
real*16 function qvkern(eta)
!
!   The quadruple precision Fortran function to compute
!   the kernel function expressed in a cancellation-free form
!
implicit integer (i-n)
implicit real*16 (a-h,o-z)
!
real*16 R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
common /qparamV/R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
real*16 alpha,gamma,zetaT,zetaB,sigma,fmu
common /qparamV2/alpha,gamma,zetaT,zetaB,sigma,fmu
!
fnu=sin(eta*0.5q0)
B=2.q0*alpha*(fmu*fmu+gamma*sigma*fnu*fnu)
A=B*(2.q0*alpha-B)
C=(alpha-B)*(alpha-B)-A*0.5q0
D=0.5q0*(zetaT+4.q0*alpha-3.q0*B)
ST=sqrt(A+(B+zetaT)*(B+zetaT))
SB=sqrt(A+(B+zetaB)*(B+zetaB))
T=(zetaT+zetaB+2.q0*B)/(ST+SB)
if(zetaB+B.lt.0.q0) then
    fl=qlog1p((1.q0+T)*beta*(-zetaB-B+SB)/A)
else
    fl=qlog1p((1.q0+T)*beta/(zetaB+B+SB))
endif
qvkern=sigma*(C*fl+beta*(D*T+SB*0.5q0))
!write (*,"(a15,1p2e15.7)") "(qvkern) eta,vk=",eta,qvkern
!
return; end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine qgtess(qvtess,phi,flam,h,v,gPhi,gLam,gH)
!
!   Compute the gravitational acceleration vector by the conditional switch
!   of the central and single-sided second order finite difference formulas
!
implicit integer (i-n)
implicit real*16 (a-h,o-z)
real*16 R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
common /qparamV/R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
real*16 delta,delta1,delta2,d1phi,d1lam,d1h,d2phi,d2lam,d2h
common /qdeltaV/delta,delta1,delta2,d1phi,d1lam,d1h,d2phi,d2lam,d2h
r=R0+h
c=cos(phi)
if((flam.ge.FlamW.and.flam.le.FlamE).and.(h.ge.HB.and.h.le.HT)) then
    if((phi.gt.PhiS.and.phi-d1phi.lt.PhiS).or.(phi.gt.PhiN.and.phi-d1phi.lt.PhiN)) then
        gPhi=(-qvtess(phi+2.q0*d1phi,flam,h)+4.q0*qvtess(phi+d1phi,flam,h)-3.q0*v)/(2.q0*d1phi)
    elseif((phi.lt.PhiS.and.phi+d1phi.gt.PhiS).or.(phi.lt.PhiN.and.phi+d1phi.gt.PhiN)) then
        gPhi=(qvtess(phi-2.q0*d1phi,flam,h)-4.q0*qvtess(phi-d1phi,flam,h)+3.q0*v)/(2.q0*d1phi)
    else
        gPhi=(qvtess(phi+d1phi,flam,h)-qvtess(phi-d1phi,flam,h))/(2.q0*d1phi)
    endif
else
    gPhi=(qvtess(phi+d1phi,flam,h)-qvtess(phi-d1phi,flam,h))/(2.q0*d1phi)
endif
gPhi=gPhi/r
if((phi.ge.PhiS.and.phi.le.PhiN).and.(h.ge.HB.and.h.le.HT)) then
    if((flam.gt.FlamW.and.flam-d1lam.lt.FlamW).or.(flam.gt.FlamE.and.flam-d1lam.lt.FlamE)) then
        gLam=(-qvtess(phi,flam+2.q0*d1lam,h)+4.q0*qvtess(phi,flam+d1lam,h)-3.q0*v)/(2.q0*d1lam)
    elseif((flam.lt.FlamW.and.flam+d1lam.gt.FlamW).or.(flam.lt.FlamE.and.flam+d1lam.gt.FlamE)) then
        gLam=(qvtess(phi,flam-2.q0*d1lam,h)-4.q0*qvtess(phi,flam-d1lam,h)+3.q0*v)/(2.q0*d1lam)
    else
        gLam=(qvtess(phi,flam+d1lam,h)-qvtess(phi,flam-d1lam,h))/(2.q0*d1lam)
    endif
else
    gLam=(qvtess(phi,flam+d1lam,h)-qvtess(phi,flam-d1lam,h))/(2.q0*d1lam)
endif
gLam=gLam/(r*c)
if((phi.ge.PhiS.and.phi.le.PhiN).and.(flam.ge.FlamW.and.flam.le.FlamE)) then
    if((h.gt.HB.and.h-d1h.lt.HB).or.(h.gt.HT.and.h-d1h.lt.HT)) then
        gH=(-qvtess(phi,flam,h+2.q0*d1h)+4.q0*qvtess(phi,flam,h+d1h)-3.q0*v)/(2.q0*d1h)
    elseif((h.lt.HB.and.h+d1h.gt.HB).or.(h.lt.HT.and.h+d1h.gt.HT)) then
        gH=(qvtess(phi,flam,h-2.q0*d1h)-4.q0*qvtess(phi,flam,h-d1h)+3.q0*v)/(2.q0*d1h)
    else
        gH=(qvtess(phi,flam,h+d1h)-qvtess(phi,flam,h-d1h))/(2.q0*d1h)
    endif
else
    gH=(qvtess(phi,flam,h+d1h)-qvtess(phi,flam,h-d1h))/(2.q0*d1h)
endif
return; end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine qggtess(qvtess,phi,flam,h,v,gPhi,gLam,gH, &
    ggPhiPhi,ggPhiLam,ggPhiH,ggLamLam,ggLamH,ggHH)
!
!   Compute the gravity gradient tensor by the conditional switch
!   of the central and single-sided second order finite difference formulas
!
implicit integer (i-n)
implicit real*16 (a-h,o-z)
real*16 R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
common /qparamV/R0,HT,HB,PhiN,PhiS,FlamE,FlamW,beta
real*16 delta,delta1,delta2,d1phi,d1lam,d1h,d2phi,d2lam,d2h
common /qdeltaV/delta,delta1,delta2,d1phi,d1lam,d1h,d2phi,d2lam,d2h
r=R0+h
c=cos(phi)
t=tan(phi)
if((flam.ge.FlamW.and.flam.le.FlamE).and.(h.ge.HB.and.h.le.HT)) then
    if((phi.gt.PhiS.and.phi-d2phi.lt.PhiS).or.(phi.gt.PhiN.and.phi-d2phi.lt.PhiN)) then
        ggPhiPhi=(-qvtess(phi+3.q0*d2phi,flam,h)+4.q0*qvtess(phi+2.q0*d2phi,flam,h) &
            -5.q0*qvtess(phi+d2phi,flam,h)+2.q0*v)/(d2phi*d2phi)
    elseif((phi.lt.PhiS.and.phi+d2phi.gt.PhiS).or.(phi.lt.PhiN.and.phi+d2phi.gt.PhiN)) then
        ggPhiPhi=(-qvtess(phi-3.q0*d2phi,flam,h)+4.q0*qvtess(phi-2.q0*d2phi,flam,h) &
            -5.q0*qvtess(phi-d2phi,flam,h)+2.q0*v)/(d2phi*d2phi)
    else
        ggPhiPhi=(qvtess(phi+d2phi,flam,h)-2.q0*v+qvtess(phi-d2phi,flam,h))/(d2phi*d2phi)
    endif
else
    ggPhiPhi=(qvtess(phi+d2phi,flam,h)-2.q0*v+qvtess(phi-d2phi,flam,h))/(d2phi*d2phi)
endif
ggPhiPhi=ggPhiPhi/(r*r)+gH/r
if((phi.ge.PhiS.and.phi.le.PhiN).and.(h.ge.HB.and.h.le.HT)) then
    if((flam.gt.FlamW.and.flam-d2lam.lt.FlamW).or.(flam.gt.FlamE.and.flam-d2lam.lt.FlamE)) then
        ggLamLam=(-qvtess(phi,flam+3.q0*d2lam,h)+4.q0*qvtess(phi,flam+2.q0*d2lam,h) &
            -5.q0*qvtess(phi,flam+d2lam,h)+2.q0*v)/(d2lam*d2lam)
    elseif((flam.lt.FlamW.and.flam+d2lam.gt.FlamW).or.(flam.lt.FlamE.and.flam+d2lam.gt.FlamE)) then
        ggLamLam=(-qvtess(phi,flam-3.q0*d2lam,h)+4.q0*qvtess(phi,flam-2.q0*d2lam,h) &
            -5.q0*qvtess(phi,flam-d2lam,h)+2.q0*v)/(d2lam*d2lam)
    else
        ggLamLam=(qvtess(phi,flam+d2lam,h)-2.q0*v+qvtess(phi,flam-d2lam,h))/(d2lam*d2lam)
    endif
else
    ggLamLam=(qvtess(phi,flam+d2lam,h)-2.q0*v+qvtess(phi,flam-d2lam,h))/(d2lam*d2lam)
endif
ggLamLam=ggLamLam/(r*r*c*c)+(gH-gPhi*t)/r
if((phi.ge.PhiS.and.phi.le.PhiN).and.(flam.ge.FlamW.and.flam.le.FlamE)) then
    if((h.gt.HB.and.h-d2h.lt.HB).or.(h.gt.HT.and.h-d2h.lt.HT)) then
        ggHH=(-qvtess(phi,flam,h+3.q0*d2h)+4.q0*qvtess(phi,flam,h+2.q0*d2h) &
            -5.q0*qvtess(phi,flam,h+d2h)+2.q0*v)/(d2h*d2h)
    elseif((h.lt.HB.and.h+d2h.gt.HB).or.(h.lt.HT.and.h+d2h.gt.HT)) then
        ggHH=(-qvtess(phi,flam,h-3.q0*d2h)+4.q0*qvtess(phi,flam,h-2.q0*d2h) &
            -5.q0*qvtess(phi,flam,h-d2h)+2.q0*v)/(d2h*d2h)
    else
        ggHH=(qvtess(phi,flam,h+d2h)-2.q0*v+qvtess(phi,flam,h-d2h))/(d2h*d2h)
    endif
else
    ggHH=(qvtess(phi,flam,h+d2h)-2.q0*v+qvtess(phi,flam,h-d2h))/(d2h*d2h)
endif

if(h.ge.HB.and.h.le.HT) then
    if(((phi.gt.PhiS.and.phi-d2phi.lt.PhiS).or.(phi.gt.PhiN.and.phi-d2phi.lt.PhiN)).and. &
        ((flam.gt.FlamW.and.flam-d2lam.lt.FlamW).or.(flam.gt.FlamE.and.flam-d2lam.lt.FlamE))) then
        ggPhiLam=(qvtess(phi+2.q0*d2phi,flam+2.q0*d2lam,h) &
            -4.q0*qvtess(phi+2.q0*d2phi,flam+d2lam,h)+3.q0*qvtess(phi+2.q0*d2phi,flam,h) &
            -4.q0*qvtess(phi+d2phi,flam+2.q0*d2lam,h)+16.q0*qvtess(phi+d2phi,flam+d2lam,h) &
            -12.q0*qvtess(phi+d2phi,flam,h)+3.q0*qvtess(phi,flam+2.q0*d2lam,h) &
            -12.q0*qvtess(phi,flam+d2lam,h)+9.q0*v)/(4.q0*d2phi*d2lam)
    elseif(((phi.gt.PhiS.and.phi-d2phi.lt.PhiS).or.(phi.gt.PhiN.and.phi-d2phi.lt.PhiN)).and. &
        ((flam.lt.FlamW.and.flam+d2lam.gt.FlamW).or.(flam.lt.FlamE.and.flam+d2lam.gt.FlamE))) then
        ggPhiLam=-(qvtess(phi+2.q0*d2phi,flam-2.q0*d2lam,h) &
            -4.q0*qvtess(phi+2.q0*d2phi,flam-d2lam,h)+3.q0*qvtess(phi+2.q0*d2phi,flam,h) &
            -4.q0*qvtess(phi+d2phi,flam-2.q0*d2lam,h)+16.q0*qvtess(phi+d2phi,flam-d2lam,h) &
            -12.q0*qvtess(phi+d2phi,flam,h)+3.q0*qvtess(phi,flam-2.q0*d2lam,h) &
            -12.q0*qvtess(phi,flam-d2lam,h)+9.q0*v)/(4.q0*d2phi*d2lam)
    elseif(((phi.lt.PhiS.and.phi+d2phi.gt.PhiS).or.(phi.lt.PhiN.and.phi+d2phi.gt.PhiN)).and. &
        ((flam.gt.FlamW.and.flam-d2lam.lt.FlamW).or.(flam.gt.FlamE.and.flam-d2lam.lt.FlamE))) then
        ggPhiLam=-(qvtess(phi-2.q0*d2phi,flam+2.q0*d2lam,h) &
            -4.q0*qvtess(phi-2.q0*d2phi,flam+d2lam,h)+3.q0*qvtess(phi-2.q0*d2phi,flam,h) &
            -4.q0*qvtess(phi-d2phi,flam+2.q0*d2lam,h)+16.q0*qvtess(phi-d2phi,flam+d2lam,h) &
            -12.q0*qvtess(phi-d2phi,flam,h)+3.q0*qvtess(phi,flam+2.q0*d2lam,h) &
            -12.q0*qvtess(phi,flam+d2lam,h)+9.q0*v)/(4.q0*d2phi*d2lam)
    elseif(((phi.lt.PhiS.and.phi+d2phi.gt.PhiS).or.(phi.lt.PhiN.and.phi+d2phi.gt.PhiN)).and. &
        ((flam.lt.FlamW.and.flam+d2lam.gt.FlamW).or.(flam.lt.FlamE.and.flam+d2lam.gt.FlamE))) then
        ggPhiLam=(qvtess(phi-2.q0*d2phi,flam-2.q0*d2lam,h) &
            -4.q0*qvtess(phi-2.q0*d2phi,flam-d2lam,h)+3.q0*qvtess(phi-2.q0*d2phi,flam,h) &
            -4.q0*qvtess(phi-d2phi,flam-2.q0*d2lam,h)+16.q0*qvtess(phi-d2phi,flam-d2lam,h) &
            -12.q0*qvtess(phi-d2phi,flam,h)+3.q0*qvtess(phi,flam-2.q0*d2lam,h) &
            -12.q0*qvtess(phi,flam-d2lam,h)+9.q0*v)/(4.q0*d2phi*d2lam)
    elseif(((phi.gt.PhiS.and.phi-d2phi.lt.PhiS).or.(phi.gt.PhiN.and.phi-d2phi.lt.PhiN)).and. &
        ((flam+d2lam.lt.FlamW).or.(flam-d2lam.gt.FlamE).or. &
        (flam-d2lam.gt.FlamW.and.flam+d2lam.lt.FlamE))) then
        ggPhiLam=(-qvtess(phi+2.q0*d2phi,flam+d2lam,h)+qvtess(phi+2.q0*d2phi,flam-d2lam,h) &
            +4.q0*qvtess(phi+d2phi,flam+d2lam,h)-4.q0*qvtess(phi+d2phi,flam-d2lam,h) &
            -3.q0*qvtess(phi,flam+d2lam,h)+3.q0*qvtess(phi,flam-d2lam,h))/(4.q0*d2phi*d2lam)
    elseif(((phi.lt.PhiS.and.phi+d2phi.gt.PhiS).or.(phi.lt.PhiN.and.phi+d2phi.gt.PhiN)).and. &
        ((flam+d2lam.lt.FlamW).or.(flam-d2lam.gt.FlamE).or. &
        (flam-d2lam.gt.FlamW.and.flam+d2lam.lt.FlamE))) then
        ggPhiLam=(qvtess(phi-2.q0*d2phi,flam+d2lam,h)-qvtess(phi-2.q0*d2phi,flam-d2lam,h) &
            -4.q0*qvtess(phi-d2phi,flam+d2lam,h)+4.q0*qvtess(phi-d2phi,flam-d2lam,h) &
            +3.q0*qvtess(phi,flam+d2lam,h)-3.q0*qvtess(phi,flam-d2lam,h))/(4.q0*d2phi*d2lam)
    elseif(((flam.gt.FlamW.and.flam-d2lam.lt.FlamW).or. &
        (flam.gt.FlamE.and.flam-d2lam.lt.FlamE)).and. &
        ((phi+d2phi.lt.PhiS).or.(phi-d2phi.gt.PhiN).or.(phi-d2phi.gt.PhiS.and.phi+d2phi.lt.PhiN))) then
        ggPhiLam=(-qvtess(phi+d2phi,flam+2.q0*d2lam,h)+qvtess(phi-d2phi,flam+2.q0*d2lam,h) &
            +4.q0*qvtess(phi+d2phi,flam+d2lam,h)-4.q0*qvtess(phi-d2phi,flam+d2lam,h) &
            -3.q0*qvtess(phi+d2phi,flam,h)+3.q0*qvtess(phi-d2phi,flam,h))/(4.q0*d2phi*d2lam)
    elseif(((flam.lt.FlamW.and.flam+d2lam.gt.FlamW).or. &
        (flam.lt.FlamE.and.flam+d2lam.gt.FlamE)).and. &
        ((phi+d2phi.lt.PhiS).or.(phi-d2phi.gt.PhiN).or.(phi-d2phi.gt.PhiS.and.phi+d2phi.lt.PhiN))) then
        ggPhiLam=-(-qvtess(phi+d2phi,flam-2.q0*d2lam,h)+qvtess(phi-d2phi,flam-2.q0*d2lam,h) &
            +4.q0*qvtess(phi+d2phi,flam-d2lam,h)-4.q0*qvtess(phi-d2phi,flam-d2lam,h) &
            -3.q0*qvtess(phi+d2phi,flam,h)+3.q0*qvtess(phi-d2phi,flam,h))/(4.q0*d2phi*d2lam)
    else
        ggPhiLam=(qvtess(phi+d2phi,flam+d2lam,h)-qvtess(phi-d2phi,flam+d2lam,h) &
            -qvtess(phi+d2phi,flam-d2lam,h)+qvtess(phi-d2phi,flam-d2lam,h))/(4.q0*d2phi*d2lam)
    endif
else
    ggPhiLam=(qvtess(phi+d2phi,flam+d2lam,h)-qvtess(phi-d2phi,flam+d2lam,h) &
        -qvtess(phi+d2phi,flam-d2lam,h)+qvtess(phi-d2phi,flam-d2lam,h))/(4.q0*d2phi*d2lam)
endif
ggPhiLam=ggPhiLam/(r*r*c)+gLam*t/r

if(flam.ge.FlamW.and.flam.le.FlamE) then
    if(((phi.gt.PhiS.and.phi-d2phi.lt.PhiS).or.(phi.gt.PhiN.and.phi-d2phi.lt.PhiN)).and. &
        ((h.gt.HB.and.h-d2h.lt.HB).or.(h.gt.HT.and.h-d2h.lt.HT))) then
        ggPhiH=(qvtess(phi+2.q0*d2phi,flam,h+2.q0*d2h)-4.q0*qvtess(phi+2.q0*d2phi,flam,h+d2h) &
            +3.q0*qvtess(phi+2.q0*d2phi,flam,h)-4.q0*qvtess(phi+d2phi,flam,h+2.q0*d2h) &
            +16.q0*qvtess(phi+d2phi,flam,h+d2h)-12.q0*qvtess(phi+d2phi,flam,h) &
            +3.q0*qvtess(phi,flam,h+2.q0*d2h)-12.q0*qvtess(phi,flam,h+d2h)+9.q0*v)/(4.q0*d2phi*d2h)
    elseif(((phi.gt.PhiS.and.phi-d2phi.lt.PhiS).or.(phi.gt.PhiN.and.phi-d2phi.lt.PhiN)).and. &
        ((h.lt.HB.and.h+d2h.gt.HB).or.(h.lt.HT.and.h+d2h.gt.HT))) then
        ggPhiH=-(qvtess(phi+2.q0*d2phi,flam,h-2.q0*d2h)-4.q0*qvtess(phi+2.q0*d2phi,flam,h-d2h) &
            +3.q0*qvtess(phi+2.q0*d2phi,flam,h)-4.q0*qvtess(phi+d2phi,flam,h-2.q0*d2h) &
            +16.q0*qvtess(phi+d2phi,flam,h-d2h)-12.q0*qvtess(phi+d2phi,flam,h) &
            +3.q0*qvtess(phi,flam,h-2.q0*d2h)-12.q0*qvtess(phi,flam,h-d2h)+9.q0*v)/(4.q0*d2phi*d2h)
    elseif(((phi.lt.PhiS.and.phi+d2phi.gt.PhiS).or.(phi.lt.PhiN.and.phi+d2phi.gt.PhiN)).and. &
        ((h.gt.HB.and.h-d2h.lt.HB).or.(h.gt.HT.and.h-d2h.lt.HT))) then
        ggPhiH=-(qvtess(phi-2.q0*d2phi,flam,h+2.q0*d2h)-4.q0*qvtess(phi-2.q0*d2phi,flam,h+d2h) &
            +3.q0*qvtess(phi-2.q0*d2phi,flam,h)-4.q0*qvtess(phi-d2phi,flam,h+2.q0*d2h) &
            +16.q0*qvtess(phi-d2phi,flam,h+d2h)-12.q0*qvtess(phi-d2phi,flam,h) &
            +3.q0*qvtess(phi,flam,h+2.q0*d2h)-12.q0*qvtess(phi,flam,h+d2h)+9.q0*v)/(4.q0*d2phi*d2h)
    elseif(((phi.lt.PhiS.and.phi+d2phi.gt.PhiS).or.(phi.lt.PhiN.and.phi+d2phi.gt.PhiN)).and. &
        ((h.lt.HB.and.h+d2h.gt.HB).or.(h.lt.HT.and.h+d2h.gt.HT))) then
        ggPhiH=(qvtess(phi-2.q0*d2phi,flam,h-2.q0*d2h)-4.q0*qvtess(phi-2.q0*d2phi,flam,h-d2h) &
            +3.q0*qvtess(phi-2.q0*d2phi,flam,h)-4.q0*qvtess(phi-d2phi,flam,h-2.q0*d2h) &
            +16.q0*qvtess(phi-d2phi,flam,h-d2h)-12.q0*qvtess(phi-d2phi,flam,h) &
            +3.q0*qvtess(phi,flam,h-2.q0*d2h)-12.q0*qvtess(phi,flam,h-d2h)+9.q0*v)/(4.q0*d2phi*d2h)
    elseif(((phi.gt.PhiS.and.phi-d2phi.lt.PhiS).or.(phi.gt.PhiN.and.phi-d2phi.lt.PhiN)).and. &
        ((h+d2h.lt.HB).or.(h-d2h.gt.HT).or.(h-d2h.gt.HB.and.h+d2h.lt.HT))) then
        ggPhiH=(-qvtess(phi+2.q0*d2phi,flam,h+d2h)+qvtess(phi+2.q0*d2phi,flam,h-d2h) &
            +4.q0*qvtess(phi+d2phi,flam,h+d2h)-4.q0*qvtess(phi+d2phi,flam,h-d2h) &
            -3.q0*qvtess(phi,flam,h+d2h)+3.q0*qvtess(phi,flam,h-d2h))/(4.q0*d2phi*d2h)
    elseif(((phi.lt.PhiS.and.phi+d2phi.gt.PhiS).or.(phi.lt.PhiN.and.phi+d2phi.gt.PhiN)).and. &
        ((h+d2h.lt.HB).or.(h-d2h.gt.HT).or.(h-d2h.gt.HB.and.h+d2h.lt.HT))) then
        ggPhiH=-(-qvtess(phi-2.q0*d2phi,flam,h+d2h)+qvtess(phi-2.q0*d2phi,flam,h-d2h) &
            +4.q0*qvtess(phi-d2phi,flam,h+d2h)-4.q0*qvtess(phi-d2phi,flam,h-d2h) &
            -3.q0*qvtess(phi,flam,h+d2h)+3.q0*qvtess(phi,flam,h-d2h))/(4.q0*d2phi*d2h)
    elseif(((h.gt.HB.and.h-d2h.lt.HB).or.(h.gt.HT.and.h-d2h.lt.HT)).and.((phi+d2phi.lt.PhiS) &
        .or.(phi-d2phi.gt.PhiN).or.(phi-d2phi.gt.PhiS.and.phi+d2phi.lt.PhiN))) then
        ggPhiH=(-qvtess(phi+d2phi,flam,h+2.q0*d2h)+qvtess(phi-d2phi,flam,h+2.q0*d2h) &
            +4.q0*qvtess(phi+d2phi,flam,h+d2h)-4.q0*qvtess(phi-d2phi,flam,h+d2h) &
            -3.q0*qvtess(phi+d2phi,flam,h)+3.q0*qvtess(phi-d2phi,flam,h))/(4.q0*d2phi*d2h)
    elseif(((h.lt.HB.and.h+d2h.gt.HB).or.(h.lt.HT.and.h+d2h.gt.HT)).and.((phi+d2phi.lt.PhiS) &
        .or.(phi-d2phi.gt.PhiN).or.(phi-d2phi.gt.PhiS.and.phi+d2phi.lt.PhiN))) then
        ggPhiH=-(-qvtess(phi+d2phi,flam,h-2.q0*d2h)+qvtess(phi-d2phi,flam,h-2.q0*d2h) &
            +4.q0*qvtess(phi+d2phi,flam,h-d2h)-4.q0*qvtess(phi-d2phi,flam,h-d2h) &
            -3.q0*qvtess(phi+d2phi,flam,h)+3.q0*qvtess(phi-d2phi,flam,h))/(4.q0*d2phi*d2h)
    else
        ggPhiH=(qvtess(phi+d2phi,flam,h+d2h)-qvtess(phi-d2phi,flam,h+d2h) &
            -qvtess(phi+d2phi,flam,h-d2h)+qvtess(phi-d2phi,flam,h-d2h))/(4.q0*d2phi*d2h)
    endif
else
    ggPhiH=(qvtess(phi+d2phi,flam,h+d2h)-qvtess(phi-d2phi,flam,h+d2h) &
        -qvtess(phi+d2phi,flam,h-d2h)+qvtess(phi-d2phi,flam,h-d2h))/(4.q0*d2phi*d2h)
endif
ggPhiH=ggPhiH/r-gPhi/r

if(phi.ge.PhiS.and.phi.le.PhiN) then
    if(((flam.gt.FlamW.and.flam-d2flam.lt.FlamW).or.(flam.gt.FlamE.and.flam-d2flam.lt.FlamE)).and. &
        ((h.gt.HB.and.h-d2h.lt.HB).or.(h.gt.HT.and.h-d2h.lt.HT))) then
        ggLamH=(qvtess(phi,flam+2.q0*d2lam,h+2.q0*d2h)-4.q0*qvtess(phi,flam+2.q0*d2lam,h+d2h) &
            +3.q0*qvtess(phi,flam+2.q0*d2lam,h)-4.q0*qvtess(phi,flam+d2lam,h+2.q0*d2h) &
            +16.q0*qvtess(phi,flam+d2lam,h+d2h)-12.q0*qvtess(phi,flam+d2lam,h) &
            +3.q0*qvtess(phi,flam,h+2.q0*d2h)-12.q0*qvtess(phi,flam,h+d2h)+9.q0*v)/(4.q0*d2lam*d2h)
    elseif(((flam.gt.FlamW.and.flam-d2lam.lt.FlamW).or.(flam.gt.FlamE.and.flam-d2lam.lt.FlamE)).and. &
        ((h.lt.HB.and.h+d2h.gt.HB).or.(h.lt.HT.and.h+d2h.gt.HT))) then
        ggLamH=-(qvtess(phi,flam+2.q0*d2lam,h-2.q0*d2h)-4.q0*qvtess(phi,flam+2.q0*d2lam,h-d2h) &
            +3.q0*qvtess(phi,flam+2.q0*d2lam,h)-4.q0*qvtess(phi,flam+d2lam,h-2.q0*d2h) &
            +16.q0*qvtess(phi,flam+d2lam,h-d2h)-12.q0*qvtess(phi,flam+d2lam,h) &
            +3.q0*qvtess(phi,flam,h-2.q0*d2h)-12.q0*qvtess(phi,flam,h-d2h)+9.q0*v)/(4.q0*d2lam*d2h)
    elseif(((flam.lt.FlamW.and.flam+d2lam.gt.FlamW).or.(flam.lt.FlamE.and.flam+d2lam.gt.FlamE)).and. &
        ((h.gt.HB.and.h-d2h.lt.HB).or.(h.gt.HT.and.h-d2h.lt.HT))) then
        ggLamH=-(qvtess(phi,flam-2.q0*d2lam,h+2.q0*d2h)-4.q0*qvtess(phi,flam-2.q0*d2lam,h+d2h) &
            +3.q0*qvtess(phi,flam-2.q0*d2lam,h)-4.q0*qvtess(phi,flam-d2lam,h+2.q0*d2h) &
            +16.q0*qvtess(phi,flam-d2lam,h+d2h)-12.q0*qvtess(phi,flam-d2lam,h) &
            +3.q0*qvtess(phi,flam,h+2.q0*d2h)-12.q0*qvtess(phi,flam,h+d2h)+9.q0*v)/(4.q0*d2lam*d2h)
    elseif(((flam.lt.FlamW.and.flam+d2lam.gt.FlamW).or.(flam.lt.FlamE.and.flam+d2lam.gt.FlamE)).and. &
        ((h.lt.HB.and.h+d2h.gt.HB).or.(h.lt.HT.and.h+d2h.gt.HT))) then
        ggLamH=(qvtess(phi,flam-2.q0*d2lam,h-2.q0*d2h)-4.q0*qvtess(phi,flam-2.q0*d2lam,h-d2h) &
            +3.q0*qvtess(phi,flam-2.q0*d2lam,h)-4.q0*qvtess(phi,flam-d2lam,h-2.q0*d2h) &
            +16.q0*qvtess(phi,flam-d2lam,h-d2h)-12.q0*qvtess(phi,flam-d2lam,h) &
            +3.q0*qvtess(phi,flam,h-2.q0*d2h)-12.q0*qvtess(phi,flam,h-d2h)+9.q0*v)/(4.q0*d2lam*d2h)
    elseif(((flam.gt.FlamW.and.flam-d2lam.lt.FlamW).or.(flam.gt.FlamE.and.flam-d2lam.lt.FlamE)).and. &
        ((h+d2h.lt.HB).or.(h-d2h.gt.HT).or.(h-d2h.gt.HB.and.h+d2h.lt.HT))) then
        ggLamH=(-qvtess(phi,flam+2.q0*d2lam,h+d2h)+qvtess(phi,flam+2.q0*d2lam,h-d2h) &
            +4.q0*qvtess(phi,flam+d2lam,h+d2h)-4.q0*qvtess(phi,flam+d2lam,h-d2h) &
            -3.q0*qvtess(phi,flam,h+d2h)+3.q0*qvtess(phi,flam,h-d2h))/(4.q0*d2lam*d2h)
    elseif(((flam.lt.FlamW.and.flam+d2lam.gt.FlamW).or.(flam.lt.FlamE.and.flam+d2lam.gt.FlamE)).and. &
        ((h+d2h.lt.HB).or.(h-d2h.gt.HT).or.(h-d2h.gt.HB.and.h+d2h.lt.HT))) then
        ggLamH=-(-qvtess(phi,flam-2.q0*d2lam,h+d2h)+qvtess(phi,flam-2.q0*d2lam,h-d2h) &
            +4.q0*qvtess(phi,flam-d2lam,h+d2h)-4.q0*qvtess(phi,flam-d2lam,h-d2h) &
            -3.q0*qvtess(phi,flam,h+d2h)+3.q0*qvtess(phi,flam,h-d2h))/(4.q0*d2lam*d2h)
    elseif(((h.gt.HB.and.h-d2h.lt.HB).or.(h.gt.HT.and.h-d2h.lt.HT)).and.((flam+d2lam.lt.FlamW).or. &
        (flam-d2lam.gt.FlamE).or.(flam-d2lam.gt.FlamW.and.flam+d2lam.lt.FlamE))) then
        ggLamH=(-qvtess(phi,flam+d2lam,h+2.q0*d2h)+qvtess(phi,flam-d2lam,h+2.q0*d2h) &
            +4.q0*qvtess(phi,flam+d2lam,h+d2h)-4.q0*qvtess(phi,flam-d2lam,h+d2h) &
            -3.q0*qvtess(phi,flam+d2lam,h)+3.q0*qvtess(phi,flam-d2lam,h))/(4.q0*d2lam*d2h)
    elseif(((h.lt.HB.and.h+d2h.gt.HB).or.(h.lt.HT.and.h+d2h.gt.HT)).and.((flam+d2lam.lt.FlamW).or. &
        (flam-d2lam.gt.FlamE).or.(flam-d2lam.gt.FlamW.and.flam+d2lam.lt.FlamE))) then
        ggLamH=-(-qvtess(phi,flam+d2lam,h-2.q0*d2h)+qvtess(phi,flam-d2lam,h-2.q0*d2h) &
            +4.q0*qvtess(phi,flam+d2lam,h-d2h)-4.q0*qvtess(phi,flam-d2lam,h-d2h) &
            -3.q0*qvtess(phi,flam+d2lam,h)+3.q0*qvtess(phi,flam-d2lam,h))/(4.q0*d2lam*d2h)
    else
        ggLamH=(qvtess(phi,flam+d2lam,h+d2h)-qvtess(phi,flam-d2lam,h+d2h) &
            -qvtess(phi,flam+d2lam,h-d2h)+qvtess(phi,flam-d2lam,h-d2h))/(4.q0*d2lam*d2h)
    endif
else
    ggLamH=(qvtess(phi,flam+d2lam,h+d2h)-qvtess(phi,flam-d2lam,h+d2h) &
        -qvtess(phi,flam+d2lam,h-d2h)+qvtess(phi,flam-d2lam,h-d2h))/(4.q0*d2lam*d2h)
endif
ggLamH=ggLamH/(r*c)-gLam/r
return; end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine qqde(f,a,b,delta0,s)
!
!   The subroutine to compute a given integral by the quadruple precision
!    double exponential (DE) quadrature rule.
!
!   Reference: "Accurate computation of gravitational field of a tesseroid"
!   authored by T. Fukushima and submitted to J. Geodesy (2017)
!
!    Input function/variables:
!         f(t): a function to be integrated
!         a: the lower end point of the integration interval
!         b: the upper end point of the integration interval
!         delta0: the relative error tolerance (typically 1d-15)
!    Output variable:
!         s: the definite integral, s=int_a^b f(t) dt
!         (Note) "errd" is the latest relative error estimate o "s"
!
real*16 f,a,b,delta0,s
integer MMAX
real*16 SAFETY,TWOPI
parameter (MMAX=4092,SAFETY=10.q0)
parameter (TWOPI=6.283185307179586476925286766559q0)
integer m
real*16 delta,hmax,deltax,factor,deltah,h0,eph,emh,deltat,apb,bma,sr,h
real*16 sprev,srprev,t,ep,em,eppem,xw,xa,wg,fa,fb,fapfb,errt
real*16 errh,errd
delta=max(1.q-33,min(0.01q0,delta0))
if(delta.gt.1.q-4) then
    hmax=2.75q0+(-log10(delta))*0.75q0
elseif(delta.gt.1.q-6) then
    hmax=3.75q0+(-log10(delta))*0.5q0
elseif(delta.gt.1.q-10) then
    hmax=5.25q0+(-log10(delta))*0.25q0
else
    hmax=6.5q0+(-log10(delta))*0.125q0
endif
!hmax=sqrt(-2.q0*log10(delta))+2.5q0
!write(*,*) "(qqde) hmax=",hmax
deltax=SAFETY*delta
factor=1.q0-log(deltax)
deltah=sqrt(deltax)
h0=hmax/factor
eph=exp(h0)
emh=1.q0/eph
deltat=exp(-emh*factor)
apb=a+b
bma=b-a
sr=f(apb*0.5q0)*(bma*0.25q0)
s=sr*(2.q0*TWOPI)
err=abs(s)*deltat
h=2.q0*h0
m=1
1 continue
    sprev=s
    srprev=sr
    t=h*0.5q0
2 continue
        em=exp(t)
        ep=TWOPI*em
        em=TWOPI/em
3 continue
            eppem=ep+em
            xw=1.q0/(1.q0+exp(ep-em))
            xa=bma*xw
            wg=xa*(1.q0-xw)
            fa=f(a+xa)*wg
            fb=f(b-xa)*wg
            fapfb=fa+fb
            sr=sr+fapfb
            s=s+fapfb*eppem
            errt=(abs(fa)+abs(fb))*eppem
            if(m.eq.1) err=err+errt*deltat
            ep=ep*eph
            em=em*emh
            if(errt.gt.err.or.xw.gt.deltah) goto 3
        t=t+h
        if(t.lt.h0) goto 2
    if(m.eq.1) then
        errh=(err/deltat)*deltah*h0
        errd=1.q0+2.q0*errh
    else
        errd=h*(abs(s-2.q0*sprev)+4.q0*abs(sr-2.q0*srprev))
    endif
    h=h*0.5q0
    m=m*2
    if(errd.gt.errh.and.m.lt.MMAX) goto 1
!if(errd.gt.errh) write(*,*)"(qqde) Required too many grids: >", MMAX
s=s*h
return;end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine qqde1(f,a,b,delta0,s)
!
!   The first copy of "qqde" to be used in computing the internal
!    line integral called by "qqde"
!
real*16 f,a,b,delta0,s
integer MMAX
real*16 SAFETY,TWOPI
parameter (MMAX=4092,SAFETY=10.q0)
parameter (TWOPI=6.283185307179586476925286766559q0)
integer m
real*16 delta,hmax,deltax,factor,deltah,h0,eph,emh,deltat,apb,bma,sr,h
real*16 sprev,srprev,t,ep,em,eppem,xw,xa,wg,fa,fb,fapfb,errt
real*16 errh,errd
delta=max(1.q-33,min(0.01q0,delta0))
if(delta.gt.1.q-4) then
    hmax=2.75q0+(-log10(delta))*0.75q0
elseif(delta.gt.1.q-6) then
    hmax=3.75q0+(-log10(delta))*0.5q0
elseif(delta.gt.1.q-10) then
    hmax=5.25q0+(-log10(delta))*0.25q0
else
    hmax=6.5q0+(-log10(delta))*0.125q0
endif
!hmax=sqrt(-2.q0*log10(delta))+2.5q0
!write(*,*) "(qqde1) hmax=",hmax
deltax=SAFETY*delta
factor=1.q0-log(deltax)
deltah=sqrt(deltax)
h0=hmax/factor
eph=exp(h0)
emh=1.q0/eph
deltat=exp(-emh*factor)
apb=a+b
bma=b-a
sr=f(apb*0.5q0)*(bma*0.25q0)
s=sr*(2.q0*TWOPI)
err=abs(s)*deltat
h=2.q0*h0
m=1
1 continue
    sprev=s
    srprev=sr
    t=h*0.5q0
2 continue
        em=exp(t)
        ep=TWOPI*em
        em=TWOPI/em
3 continue
            eppem=ep+em
            xw=1.q0/(1.q0+exp(ep-em))
            xa=bma*xw
            wg=xa*(1.q0-xw)
            fa=f(a+xa)*wg
            fb=f(b-xa)*wg
            fapfb=fa+fb
            sr=sr+fapfb
            s=s+fapfb*eppem
            errt=(abs(fa)+abs(fb))*eppem
            if(m.eq.1) err=err+errt*deltat
            ep=ep*eph
            em=em*emh
            if(errt.gt.err.or.xw.gt.deltah) goto 3
        t=t+h
        if(t.lt.h0) goto 2
    if(m.eq.1) then
        errh=(err/deltat)*deltah*h0
        errd=1.q0+2.q0*errh
    else
        errd=h*(abs(s-2.q0*sprev)+4.q0*abs(sr-2.q0*srprev))
    endif
    h=h*0.5q0
    m=m*2
    if(errd.gt.errh.and.m.lt.MMAX) goto 1
!if(errd.gt.errh) write(*,*)"(qqde1) Required too many grids: >", MMAX
s=s*h
return;end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
real*16 function qlog1p(x0)
!
!   The quadruple precision Fortran function to compute precisely log1p(x),
!    a special logarithm function defined as log1p(x) = ln(1+x),
!    by the (13,13) rational minimax approximation evaluated by Estrin's scheme
!
!   Reference: "Accurate computation of gravitational field of a tesseroid"
!   authored by T. Fukushima and submitted to J. Geodesy (2017)
!
real*16 x0,x1,x2,x4,x8
real*16 a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13
real*16 b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13
parameter (a1=0.999999999999999999999999999999999989679405409q0)
parameter (a2=5.43952695470870990343440472736508508440853974q0)
parameter (a3=12.8687954156331531486576454765577285904854589q0)
parameter (a4=17.3813399893763161892491716455513072747241961q0)
parameter (a5=14.7937221247975315812946713068099324296210500q0)
parameter (a6=8.26554125834405953536667781138761190677622028q0)
parameter (a7=3.06422110888383600247671821221533143683683084q0)
parameter (a8=0.745288118102087966956230766831419822309727243q0)
parameter (a9=0.115047592893588673011032562622446366266055797q0)
parameter (a10=0.0105968202344748100801276898051500664263281933q0)
parameter (a11=0.000522466799810767549674343323841954134608619668q0)
parameter (a12=0.0000112217383140869479740242371068976645949743233q0)
parameter (a13=6.39672301036246645989908315040681256718633817q-8)
parameter (b1=5.93952695470870990343440472736506510635091212q0)
parameter (b2=15.5052255596541747670415145069133006422898887q0)
parameter (b3=23.4041104509671669382917939890824601741965693q0)
parameter (b4=22.6122505690735676039519980345629102098426624q0)
parameter (b5=14.6253640581969227356522409769061106689586552q0)
parameter (b6=6.43653279869637374357975617245086508089670491q0)
parameter (b7=1.92137412606261539134961029284884346128770878q0)
parameter (b8=0.381097234341555148065443000297505125713856247q0)
parameter (b9=0.0482176170045436717981339396150227533590537972q0)
parameter (b10=0.00362957310087890393686248940312126067485435786q0)
parameter (b11=0.000144194286147019122572434476322438425343273856q0)
parameter (b12=2.40586135243166027564864363686803405251652763q-6)
parameter (b13=9.53384644636009246025258296194840899175886989q-9)
if(x0.lt.-0.5q0.or.x0.gt.1.q0) then
    qlog1p=log(1.q0+x0)
elseif(x0.lt.0.q0) then
    x1=-x0/(1.q0+x0)
    x2=x1*x1; x4=x2*x2; x8=x4*x4
    qlog1p=-x1*((((a1+x1*a2)+x2*(a3+x1*a4)) &
        +x4*((a5+x1*a6)+x2*(a7+x1*a8))) &
        +x8*(((a9+x1*a10)+x2*(a11+x1*a12))+x4*a13)) &
        /((((1.q0+x1*b1)+x2*(b2+x1*b3)) &
        +x4*((b4+x1*b5)+x2*(b6+x1*b7))) &
        +x8*(((b8+x1*b9)+x2*(b10+x1*b11))+x4*(b12+x1*b13)))
else
    x1=x0
    x2=x1*x1; x4=x2*x2; x8=x4*x4
    qlog1p=x1*((((a1+x1*a2)+x2*(a3+x1*a4)) &
        +x4*((a5+x1*a6)+x2*(a7+x1*a8))) &
        +x8*(((a9+x1*a10)+x2*(a11+x1*a12))+x4*a13)) &
        /((((1.q0+x1*b1)+x2*(b2+x1*b3)) &
        +x4*((b4+x1*b5)+x2*(b6+x1*b7))) &
        +x8*(((b8+x1*b9)+x2*(b10+x1*b11))+x4*(b12+x1*b13)))
endif
return; end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!    output of "xqtess"
!      (Note) It took 50.463 s at a PC with an Intel Core i5-10400 running at 2.90 GHz
!      The ifort version is
!           Intel(R) Fortran Intel(R) 64 Compiler Classic for applications running on
!            Intel(R) 64, Version 2021.4.0 Build 20210910_000000
!            Copyright (C) 1985-2021 Intel Corporation.  All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!       # qdelta=  1.0000000E-33
!     # R0,HT,HB=  6.3800000E+03  1.0000000E+01 -4.0000000E+01
!    # PhiN,PhiS=  2.8000000E+01  2.7000000E+01
! # LamdaE,LamdaW  8.7000000E+01  8.6000000E+01
!   # phi,lambda=  2.7500000E+01  8.6500000E+01
!             # H                                            V
!               #                                         gPhi                                      gLambda                                           gH
!               #                                  GammaPhiPhi                               GammaPhiLambda                                    GammaPhiH
!               #                            GammaLambdaLambda                                 GammaLambdaH                                      GammaHH
!   0.0000000E+00    3.48325322193870636629659255498939089E-04
!                   -2.46036392570567795088050350602583752E-09    0.00000000000000000000000000000000000E+00   -2.85123442878667527113560010904584978E-06
!                   -5.08904505133959948029056972137904267E-08    0.00000000000000000000000000000000000E+00    2.18878445224546923434052589802025524E-11
!                   -6.30472396588766653064121274000352571E-08    0.00000000000000000000000000000000000E+00   -1.94784969155936898885842505981320626E-07
!  The total time is   50.4631370000000      seconds.
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


      SUBROUTINE HOTSYS
*
*
*       Hot initial system.
*       -------------------
*
      INCLUDE 'common6.h'
*
*
*       Determine the rms velocity from current kinetic energy.
      VRMS = 0.0
      DO 10 I = 1,N
          DO 5 K = 1,3
              VRMS = VRMS + BODY(I)*XDOT(K,I)**2
    5     CONTINUE
   10 CONTINUE
      VRMS = SQRT(VRMS/ZMASS)
*
*       Define GM & PC in cgs units and form velocity scale in km/sec.
      GM = 6.67E-08*1.989E+33
      PC = 3.0857E+18
      VSTAR = 1.0E-05*SQRT(GM/PC)
*
*       Ensure ZMBAR & RBAR > 0 (=0: assume <M>/Sun = 1, RBAR = 1 pc).
      IF (ZMBAR.LE.0.0D0) ZMBAR = FLOAT(N)/ZMASS
      IF (RBAR.LE.0.0D0) RBAR = 1.0
*
*       Scale to working units of RBAR in pc & ZMBAR in solar masses.
      VSTAR = VSTAR*SQRT(ZMASS*ZMBAR/RBAR)
*
*       Read central velocity dispersion and form scaling factor.
      READ (5,*)  SIGMA0
      VSCALE = SIGMA0/(VSTAR*VRMS)
*
*       Scale the velocities to central velocity dispersion of SIGMA0 km/sec.
      DO 20 I = 1,N
          DO 15 K = 1,3
              XDOT(K,I) = VSCALE*XDOT(K,I)
              X0DOT(K,I) = XDOT(K,I)
   15     CONTINUE
   20 CONTINUE
*
*       Rescale crossing time, output times & termination time.
      RATIO = SIGMA0/VSTAR
      TCR = TCR/RATIO
      TCR0 = TCR
      DTADJ = DTADJ/RATIO
      DELTAT = DELTAT/RATIO
      TCRIT = TCRIT/RATIO
      VC = VSCALE*VC
*
      WRITE (6,30)  SIGMA0, VRMS, VSCALE
   30 FORMAT (/,12X,'HOT SYSTEM:   SIGMA0 =',F5.1,'  <V> =',F6.3,
     &                                              '  VSCALE =',F6.3,/)
*
      RETURN
*
      END


      program DRMACH
c>> 1996-05-28 DRMACH Krogh Added external statement, moved formats.
c>> 1994-08-09 DRMACH WVS Removed '0' from format
c>> 1991-11-20 DRMACH CLL Edited for Fortran 90.
c>> 1989-10-30 DRMACH CLL Changed format to handle 14 digit Cray integer
c>> 1987-12-09 DRMACH   Lawson  Initial Code.
c                        Demo driver for D1MACH, I1MACH, and R1MACH
      external D1MACH, I1MACH, R1MACH
      double precision D1MACH, D1
      integer I1MACH, I1, J
      real R1MACH, R1
   10 format(15X,A)
   20 format(15X,41('-'))
   30 format(/2X,'J',6X,'I1MACH(J)',7X,'R1MACH(J)',13X,'D1MACH(J)')
   40 format(I3, I15,3X,G15.8,3X,G25.18)
   50 format(I3, I15)
c     ------------------------------------------------------------------
      print 10,'MACHINE CONSTANTS for ...                '
      print 20
      print 30
      print*,' '
      do 60 J=1,5
        I1 = I1MACH(J)
        R1 = R1MACH(J)
        D1 = D1MACH(J)
        print 40, J,I1,R1,D1
   60 continue
      do 70 J=6,16
        print 50, J,I1MACH(J)
   70 continue
c
      end


program main
  logical :: x
  logical :: y = .true.
  logical :: z = .false.

  x = y .and. z
  x = y .or. z
  x = y .eqv. z
  x = y .neqv. z

  x = 1 < 2
  x = 1 .lt. 2
  x = 1 <= 2
  x = 1 .le. 2

  x = 1 > 2
  x = 1 .gt. 2
  x = 1 >= 2
  x = 1 .ge. 2

  x = 1 == 1
  x = 1 .eq. 1
  x = 1 /= 1
  x = 1 .ne. 1

end program main


program main

  use init_data_module, only : multifab, init_data

  implicit none

  integer, parameter :: dm = 3
  type(multifab) :: data
  double precision, allocatable :: dx(:)

  data%dim = dm

  allocate(dx(data%dim))
  dx = 1.d-1

  call init_data(data,dx)

end program main


!> @brief This module defines variable data types
!!
!! This module defines the precision of logical, integer, long integer,
!! and real data types used in MODFLOW 6 and are available to all other
!! modules.
!!
!<
module KindModule
  use, intrinsic:: iso_fortran_env, only: I4B => int32, &
                                          I8B => int64,  &
                                          LGP => int32, &
                                          DP => real64

  implicit none

  public:: I4B, I8B, LGP, DP, write_kindinfo

  contains

    !> @brief Write variable data types
    !!
    !! This subroutine writes the precision of logical, integer, long integer,
    !! and real data types used in MODFLOW 6.
    !!
    !<
    subroutine write_kindinfo(iout)
        ! -- dummy variables
        integer(I4B), intent(in) :: iout  !< file unit to output kind variables
        ! -- local variables
        integer(LGP) :: ldum = 0
        integer(I4B) :: idum = 0
        integer(I8B) :: long_idum = 0
        integer(DP) :: irdum = 0 ! for bit size of real variables
        real(DP) :: rdum = 0._DP
        !
        ! -- write kind information
        write(iout, '(/a)') 'Real Variables'
        write(iout, '(2x,a,i0)') 'KIND: ', DP
        write(iout, '(2x,a,1pg15.6)') 'TINY (smallest non-zero value): ', tiny(rdum)
        write(iout, '(2x,a,1pg15.6)') 'HUGE (largest value): ', huge(rdum)
        write(iout, '(2x,a,i0)') 'PRECISION: ', precision(rdum)
        write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(irdum)

        write(iout, '(/a)') 'Integer Variables'
        write(iout, '(2x,a,i0)') 'KIND: ', I4B
        write(iout, '(2x,a,i0)') 'HUGE (largest value): ', huge(idum)
        write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(idum)

        write(iout, '(/a)') 'Long Integer Variables'
        write(iout, '(2x,a,i0)') 'KIND: ', I8B
        write(iout, '(2x,a,i0)') 'HUGE (largest value): ', huge(long_idum)
        write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(long_idum)

        write(iout, '(/a)') 'Logical Variables'
        write(iout, '(2x,a,i0)') 'KIND: ', LGP
        write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(ldum)
        !
        ! -- Return
        return
      end subroutine write_kindinfo

end module KindModule


C     Scalar replacement in the presence of conditional control flow
C
C     Steve Carr and Ken Kennedy
C
C     Software - Practive and Experience, Vol. 24, No. 1, pp. 51-77, 1994
C
C     Sixth example, page 24: Livermore Loop 6 (or 11) cannot be handled
C     by PIPS because we do not exploit dependence arcs and because
C     regions fuse here two independent references

      subroutine scalarization36(b, w, n)
      real b(n,n), w(n)

      do i = 2, n
         do k = 1, i-1
            w(i) = w(i)+b(i,k)*w(i-k)
         enddo
      enddo

      print *, w

      end