program SWEDivergenceEquationTerms

use NumberKindsModule
use LoggerModule
use SphereGeomModule
use ParticlesModule
use EdgesModule
use PanelsModule
use SphereMeshModule
!use LAPACK95
use STRIPACKInterfaceModule
use SSRFPACKInterfaceModule
use VTKOutputModule

implicit none

include 'mpif.h'

!
! mesh variables
!
type(SphereMesh) :: sphere
integer(kint) :: panelKind, initNest, AMR, nTracer
type(Particles), pointer :: sphereParticles => null()
type(Edges), pointer :: sphereEdges => null()
type(Panels), pointer :: spherePanels => null()
namelist /sphereDefine/ panelKind, initNest, AMR

!
! output variables
!
type(VTKSource) :: vtkOut
character(len=MAX_STRING_LENGTH) :: vtkRoot, vtkFile, outputDir, jobPrefix
character(len=MAX_STRING_LENGTH) :: dataFile, summaryFile
character(len=56) :: amrString
namelist /fileIO/ outputDir, jobPrefix

!
! user input
!
character(len=MAX_STRING_LENGTH) :: namelistInputFile = 'sweDerivativeTests.namelist'

!
! logging
!
type(Logger) :: exeLog
character(len=28) :: logkey
character(len=MAX_STRING_LENGTH) :: logstring

!
! general and mpi variables
!
integer(kint) :: i, j, k, errCode
integer(kint), parameter :: BROADCAST_INT_SIZE = 3, BROADCAST_REAL_SIZE = 1
integer(kint) :: broadcastIntegers(BROADCAST_INT_SIZE)
real(kreal) :: broadcastReals(BROADCAST_REAL_SIZE)
real(kreal) :: wallClock, testClock

!
! program-specific variables
!
real(kreal) :: test1method1Error(6), test1method2Error(6), test1method3Error(6), test2method1Error(6), test2method2Error(6), &
			   test3method1Error(6), test3method2Error(6)

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!	PROGRAM START
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
call MPI_INIT(errCode)
call MPI_COMM_SIZE(MPI_COMM_WORLD,numProcs,errCode)
call MPI_COMM_RANK(MPI_COMM_WORLD,procRank,errCode)

call InitLogger(exeLog,procRank)

wallClock = MPI_WTIME()

!
!	read user input from namelist file, set starting state
!
call ReadNamelistInputFile(procRank)
call LogMessage(exeLog,DEBUG_LOGGING_LEVEL,logkey,'PROGRAM START')

!
!	initialize sphere
!
nTracer = 3
call New(sphere, panelKind, initNest, AMR, nTracer, SWE_SOLVER)
sphereParticles => sphere%particles
sphereEdges => sphere%edges
spherePanels => sphere%panels

!	TO DO : AMR
write(amrString,'(A,I1)') 'quadNest', initNest

if ( procRank == 0 ) then
	write(vtkRoot, '(5A)') trim(outputDir), '/vtkOut/', trim(jobPrefix), trim(amrString), '_'
	write(vtkFile,'(A,A,I0.4,A)') trim(vtkRoot),'test1_', 0, '.vtk'
	call New(vtkOut, sphere, vtkFile, 'quadratic polynomials in r3')
endif

!
!	For each test function, for each method
!
	! store function values in relvort variable
	! store computed gradient in u variable
	! store computed laplacian in h variable
	! store exact values of laplacian in potvort variable
	! store exact values of gradient in x0 variable
	! store gradient linf error in tracer 1
	! store laplacian linf error in tracer 2
!
!	output results to vtk, store error norms in log messages
!

!
!	test function 1
!
call StartSection(exeLog,'Test function 1 : f(x,y,z) = x')
call TestLinearFunction(sphere)

	!
	!	method 1 : trivariate quadratic polynomials, least squares
	!
!	write(logstring,'(A,I8,A)') 'trivariate least squares : ', spherePanels%N_Active, ' panels'
!	call StartSection(exeLog, trim(logstring))
!	testClock = MPI_WTIME()
!	call TrivariateQuadraticApproximations(sphere)
!
!	write(logstring,'(A,F15.4,A)') 'trivariate quadratic elapsed time = ', MPI_WTIME() - testClock, ' seconds.'
!	call LogMessage(exeLog, TRACE_LOGGING_LEVEL,'test 1, method 1 : ', trim(logString) )
!
!	call CalculateError(sphere, test1method1Error(1), test1method1Error(2), test1method1Error(3), test1method1Error(4), &
!		test1method1Error(5), test1method1Error(6) )
!	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'scalar interp linf err = ', test1method1Error(5) )
!	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'scalar interp err = ', test1method1Error(6) )
!	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'gradient linf err = ', test1method1Error(1) )
!	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'gradient l2 err = ', test1method1Error(2) )
!	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'Laplacian linf err = ', test1method1Error(3) )
!	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'Laplacian l2 err = ', test1method1Error(4) )
!	if ( procRank == 0 ) then
!		call VTKOutput(vtkOut, sphere)
!	endif
!	call EndSection(exeLog)

	!
	!	method 2 : SSRFPACK
	!
	call TestLinearFunction(sphere)
	write(logstring,'(A,I8,A)') 'SSRFPACK : ', spherePanels%N_Active, ' panels'
	call StartSection(exeLog, trim(logstring))
	testClock = MPI_WTIME()
	call SSRFPACKApproximations(sphere)

	write(logstring,'(A,F15.4,A)') 'SSRFPACK elapsed time = ', MPI_WTIME() - testClock, ' seconds.'
	call LogMessage(exeLog, TRACE_LOGGING_LEVEL,'test 1, method 2 : ', trim(logString) )

	call CalculateError(sphere, test1method2Error(1), test1method2Error(2), test1method2Error(3), test1method2Error(4), &
		test1method2Error(5), test1method2Error(6) )
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'scalar interp linf err = ', test1method2Error(5) )
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'scalar interp err = ', test1method2Error(6) )
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'gradient linf err = ', test1method2Error(1) )
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'gradient l2 err = ', test1method2Error(2) )
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'Laplacian linf err = ', test1method2Error(3) )
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'Laplacian l2 err = ', test1method2Error(4) )
	if ( procRank == 0 ) then
		write(vtkFile,'(A,A,I0.4,A)') trim(vtkRoot), 'test1_', 1, '.vtk'
		call UpdateFilename(vtkOut, vtkFile)
		call UpdateTitle(vtkOut, 'ssrfpack')
		call VTKOutput(vtkOut, sphere)
	endif
	call EndSection(exeLog)
	!
	!	method 3 : singular kernels
	!
	!	testClock = MPI_WTIME()
	!
	!	write(logstring,'(A,F15.4,A)') 'singular kernel elapsed time = ', MPI_WTIME() - testClock, ' seconds.'
	!	call LogMessage(exeLog, TRACE_LOGGING_LEVEL,'test 1, method 3 : ', trim(logString) )
	!
	!	if ( procRank == 0 ) then
	!		write(vtkFile,'(A,A,I0.4,A)') trim(vtkRoot), 'test1_', 2, '.vtk'
	!		call UpdateFilename(vtkOut, vtkFile)
	!		call UpdateTitle(vtkOut, 'singular kernels')
	!		call VTKOutput(vtkOut, sphere)
	!	endif
call EndSection(exeLog)
call Delete(sphere)
if ( procRank == 0 ) call Delete(vtkOut)

!
!	test function 2
!

call New(sphere, panelKind, initNest, AMR, nTracer, SWE_SOLVER)
sphereParticles => sphere%particles
sphereEdges => sphere%edges
spherePanels => sphere%panels
if ( procRank == 0 ) then
	write(vtkRoot, '(5A)') trim(outputDir), '/vtkOut/', trim(jobPrefix), trim(amrString), '_'
	write(vtkFile,'(A,A,I0.4,A)') trim(vtkRoot),'test1_', 0, '.vtk'
	call New(vtkOut, sphere, vtkFile, 'quadratic polynomials in r3')
endif

call StartSection(exeLog,'Test function 2 : f(x,y,z) = RESCALED P_10^3( z/R) * cos(3 atan(y,x) ) ')
!	call TestSphericalHarmonic10_3(sphere, .TRUE.)
!	!
!	!	method 1 : trivariate quadratic polynomials, least squares
!	!
!	write(logstring,'(A,I8,A)') 'trivariate least squares : ', spherePanels%N_Active, ' panels'
!	call StartSection(exeLog, trim(logstring))
!	testClock = MPI_WTIME()
!	call TrivariateQuadraticApproximations(sphere)
!
!	write(logstring,'(A,F15.4,A)') 'trivariate quadratic elapsed time = ', MPI_WTIME() - testClock, ' seconds.'
!	call LogMessage(exeLog, TRACE_LOGGING_LEVEL,'test 2, method 1 : ', trim(logString) )
!
!	call CalculateError(sphere, test2method1Error(1), test2method1Error(2), test2method1Error(3), test2method1Error(4), &
!		test2method1Error(5), test2method1Error(6) )
!	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'scalar interp linf err = ', test2method1Error(5) )
!	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'scalar interp err = ', test2method1Error(6) )
!	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'gradient linf err = ', test2method1Error(1) )
!	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'gradient l2 err = ', test2method1Error(2) )
!	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'Laplacian linf err = ', test2method1Error(3) )
!	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'Laplacian l2 err = ', test2method1Error(4) )
!	if ( procRank == 0 ) then
!		write(vtkFile,'(A,A,I0.4,A)') trim(vtkRoot), 'test2_', 0, '.vtk'
!		call UpdateFilename(vtkOut, vtkFile)
!		call UpdateTitle(vtkOut, 'trivariate least squares')
!		call VTKOutput(vtkOut, sphere)
!	endif
!	call EndSection(exeLog)

	!
	!	method 2 : SSRFPACK
	!
	call TestSphericalHarmonic10_3(sphere, .TRUE.)
	write(logstring,'(A,I8,A)') 'SSRFPACK : ', spherePanels%N_Active, ' panels'
	call StartSection(exeLog, trim(logstring))
	testClock = MPI_WTIME()
	call SSRFPACKApproximations(sphere)

	write(logstring,'(A,F15.4,A)') 'SSRFPACK elapsed time = ', MPI_WTIME() - testClock, ' seconds.'
	call LogMessage(exeLog, TRACE_LOGGING_LEVEL,'test 2, method 2 : ', trim(logString) )

	call CalculateError(sphere, test2method2Error(1), test2method2Error(2), test2method2Error(3), test2method2Error(4), &
		test2method2Error(5), test2method2Error(6) )
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'scalar interp linf err = ', test2method2Error(5) )
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'scalar interp err = ', test2method2Error(6) )
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'gradient linf err = ', test2method2Error(1) )
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'gradient l2 err = ', test2method2Error(2) )
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'Laplacian linf err = ', test2method2Error(3) )
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'Laplacian l2 err = ', test2method2Error(4) )
	if ( procRank == 0 ) then
		write(vtkFile,'(A,A,I0.4,A)') trim(vtkRoot), 'test2_', 1, '.vtk'
		call UpdateFilename(vtkOut, vtkFile)
		call UpdateTitle(vtkOut, 'ssrfpack')
		call VTKOutput(vtkOut, sphere)
	endif
	call EndSection(exeLog)
call EndSection(exeLog)
call Delete(sphere)
if ( procRank == 0 ) call Delete(vtkOut)

!
!	test function 3
!
call New(sphere, panelKind, initNest, AMR, nTracer, SWE_SOLVER)
sphereParticles => sphere%particles
sphereEdges => sphere%edges
spherePanels => sphere%panels
if ( procRank == 0 ) then
	write(vtkRoot, '(5A)') trim(outputDir), '/vtkOut/', trim(jobPrefix), trim(amrString), '_'
	write(vtkFile,'(A,A,I0.4,A)') trim(vtkRoot),'test3_', 0, '.vtk'
	call New(vtkOut, sphere, vtkFile, 'quadratic polynomials in r3')
endif

call StartSection(exeLog,'Test function 3 : f(x,y,z) = NORMAL  P_10^3( z/R) * cos(3 atan(y,x) ) ')
!	call TestSphericalHarmonic10_3(sphere, .FALSE.)
!	!
!	!	method 1 : trivariate quadratic polynomials, least squares
!	!
!	write(logstring,'(A,I8,A)') 'trivariate least squares : ', spherePanels%N_Active, ' panels'
!	call StartSection(exeLog, trim(logstring))
!	testClock = MPI_WTIME()
!	call TrivariateQuadraticApproximations(sphere)
!
!	write(logstring,'(A,F15.4,A)') 'trivariate quadratic elapsed time = ', MPI_WTIME() - testClock, ' seconds.'
!	call LogMessage(exeLog, TRACE_LOGGING_LEVEL,'test 2, method 1 : ', trim(logString) )
!
!	call CalculateError(sphere, test3method1Error(1), test3method1Error(2), test3method1Error(3), test3method1Error(4), &
!		test3method1Error(5), test3method1Error(6) )
!	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'scalar interp linf err = ', test3method1Error(5) )
!	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'scalar interp err = ', test3method1Error(6) )
!	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'gradient linf err = ', test3method1Error(1) )
!	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'gradient l2 err = ', test3method1Error(2) )
!	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'Laplacian linf err = ', test3method1Error(3) )
!	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'Laplacian l2 err = ', test3method1Error(4) )
!	if ( procRank == 0 ) then
!		write(vtkFile,'(A,A,I0.4,A)') trim(vtkRoot), 'test3_', 0, '.vtk'
!		call UpdateFilename(vtkOut, vtkFile)
!		call UpdateTitle(vtkOut, 'trivariate least squares')
!		call VTKOutput(vtkOut, sphere)
!	endif
!	call EndSection(exeLog)

	!
	!	method 2 : SSRFPACK
	!
	call TestSphericalHarmonic10_3(sphere, .FALSE.)
	write(logstring,'(A,I8,A)') 'SSRFPACK : ', spherePanels%N_Active, ' panels'
	call StartSection(exeLog, trim(logstring))
	testClock = MPI_WTIME()
	call SSRFPACKApproximations(sphere)

	write(logstring,'(A,F15.4,A)') 'SSRFPACK elapsed time = ', MPI_WTIME() - testClock, ' seconds.'
	call LogMessage(exeLog, TRACE_LOGGING_LEVEL,'test 2, method 2 : ', trim(logString) )

	call CalculateError(sphere, test3method2Error(1), test3method2Error(2), test3method2Error(3), test3method2Error(4), &
		test3method2Error(5), test3method2Error(6) )
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'scalar interp linf err = ', test3method2Error(5) )
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'scalar interp err = ', test3method2Error(6) )
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'gradient linf err = ', test3method2Error(1) )
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'gradient l2 err = ', test3method2Error(2) )
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'Laplacian linf err = ', test3method2Error(3) )
	call LogMessage(exelog, TRACE_LOGGING_LEVEL, 'Laplacian l2 err = ', test3method2Error(4) )
	if ( procRank == 0 ) then
		write(vtkFile,'(A,A,I0.4,A)') trim(vtkRoot), 'test3_', 1, '.vtk'
		call UpdateFilename(vtkOut, vtkFile)
		call UpdateTitle(vtkOut, 'ssrfpack')
		call VTKOutput(vtkOut, sphere)
	endif
	call EndSection(exeLog)
call EndSection(exeLog)

!
!
!
!	test function 3
!
!call TestSphericalHarmonic10_3(sphere)
!call UpdateTitle(vtkOut, 'spherical harmonic 10 3')

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!	Clear memory and Finalize
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

write(logstring,'(A, F8.2,A)') 'elapsed time = ', (MPI_WTIME() - wallClock)/60.0, ' minutes.'
call LogMessage(exelog,TRACE_LOGGING_LEVEL,'PROGRAM COMPLETE : ',trim(logstring))

call Delete(sphere)

call MPI_FINALIZE(errCode)

contains

subroutine ReadNamelistInputFile(rank)
	integer(kint), intent(in) :: rank
	integer(kint) :: readWriteStat
	if ( rank == 0 ) then
		open(unit = READ_UNIT, file=namelistInputFile, status = 'OLD', action = 'READ', iostat = readWriteStat)
		if ( readWriteStat /= 0 ) then
			stop 'cannot read namelist file'
		endif
		read(READ_UNIT,nml=sphereDefine)
		rewind(READ_UNIT)
		read(READ_UNIT,nml=fileIO)
		rewind(READ_UNIT)

		broadcastIntegers(1) = panelKind
		broadcastIntegers(2) = initNest
		broadcastIntegers(3) = AMR
	endif

	call MPI_BCAST(broadcastIntegers, BROADCAST_INT_SIZE, MPI_INTEGER, 0, MPI_COMM_WORLD, errCode)
	panelKind = broadcastIntegers(1)
	initNest = broadcastIntegers(2)
	AMR = broadcastIntegers(3)
end subroutine

subroutine InitLogger(aLog, rank)
	type(Logger), intent(out) :: aLog
	integer(kint), intent(in) :: rank
	if (rank == 0 ) then
		call New(aLog,DEBUG_LOGGING_LEVEL)
	else
		call New(aLog,DEBUG_LOGGING_LEVEL)
	endif
	write(logkey,'(A,I0.2,A)') 'EXE_LOG',rank,' : '
end subroutine

function LegendreP10_3(z)
	real(kreal) :: LegendreP10_3
	real(kreal), intent(in) :: z
	LegendreP10_3 = sqrt(1.0_kreal-z*z)*(-1.0_kreal+z*z)*(-7.0_kreal*z+105.0_kreal*z**3-357.0_kreal*z**5+323.0_kreal*z**7)
end function

function LegendreP54(z)
! Legendre polynomial P_5^4(z)
	real(kreal) :: LegendreP54
	real(kreal), intent(in) :: z
	LegendreP54 = z*(-1.0_kreal + z*z)*(-1.0_kreal + z*z)
end function

function LegendreP52(z)
! Legendre polynomial P_5^2(z)
	real(kreal) :: LegendreP52
	real(kreal), intent(in) :: z
	LegendreP52 = -(-1.0_kreal + z*z)*(-z + 3.0_kreal*z*z*z)
end function

subroutine TestLinearFunction(aMesh)
	type(SphereMesh), intent(inout) :: aMesh
	!
	type(Particles), pointer :: aParticles
	type(Panels), pointer :: aPanels
	integer(kint) :: j
	aParticles => aMesh%particles
	aPanels => aMesh%panels

	do j = 1, aParticles%N
		aParticles%relVort(j) = aParticles%x(1,j)
		aParticles%x0(:,j) = [1.0_kreal - aParticles%x(1,j) * aParticles%x(1,j) /EARTH_RADIUS/EARTH_RADIUS, &
							  -aparticles%x(2,j)*aParticles%x(1,j)/EARTH_RADIUS/EARTH_RADIUS, &
							  -aParticles%x(3,j)*aparticles%x(1,j)/EARTH_RADIUS/EARTH_RADIUS]
		aParticles%potVort(j) = - 2.0_kreal * aParticles%x(1,j)/EARTH_RADIUS / EARTH_RADIUS
	enddo
	do j = 1, aPanels%N
		if ( .NOT. aPanels%hasChildren(j) ) then
			aPanels%relVort(j) = apanels%x(1,j)
			aPanels%x0(:,j) = [1.0_kreal - aPanels%x(1,j) * aPanels%x(1,j)  /EARTH_RADIUS/EARTH_RADIUS, &
							   - aPanels%x(2,j) * aPanels%x(1,j) / EARTH_RADIUS / EARTH_RADIUS, &
							   - aPanels%x(3,j) * aPanels%x(1,j) /EARTH_RADIUS/EARTH_RADIUS]
!			aPanels%potVort(j) = -2.0_kreal * cos( Longitude(aPanels%x(:,j)) ) * cos( Latitude( aPanels%x(:,j) ) ) / EARTH_RADIUS
			aPanels%potVort(j) = -2.0_kreal * aPanels%x(1,j) / EARTH_RADIUS / EARTH_RADIUS
		else
			aPanels%relVort(j) = 0.0_kreal
			aPanels%potVort(j) = 0.0_kreal
		endif
	enddo
end subroutine

subroutine TestSphericalHarmonic52(amesh)
	type(SphereMesh), intent(inout) :: aMesh
	!
	type(Particles), pointer :: aparticles
	type(Panels), pointer :: apanels
	integer(kint) :: j

	aParticles => aMesh%particles
	aPanels => aMesh%panels

	do j = 1, aParticles%N
		aParticles%relVort(j) = LegendreP52( aParticles%x(3,j)/EARTH_RADIUS ) * cos( 2.0_kreal * Longitude( aParticles%x(:,j) ))/EARTH_RADIUS
		aParticles%x0(:,j) = 0.0_kreal
		aParticles%potVort(j) = -30.0_kreal * aParticles%relVort(j)
	enddo
	do j = 1, aPanels%N
		if ( .NOT. aPanels%hasChildren(j) ) then
			aPanels%relVort(j) = LegendreP52( aPanels%x(3,j)/EARTH_RADIUS) * cos( 2.0_kreal * Longitude( aPanels%x(:,j) ) )/EARTH_RADIUS
			aPanels%potVort(j) = -30.0_kreal * aPanels%relVort(j)
			aPanels%x0(:,j) = 0.0_kreal
		else
			aPanels%relVort(j) = 0.0_kreal
			aPanels%potVort(j) = 0.0_kreal
		endif
	enddo
end subroutine

subroutine TestSphericalHarmonic54(amesh)
	type(SphereMesh), intent(inout) :: aMesh
	!
	type(Particles), pointer :: aparticles
	type(Panels), pointer :: apanels
	integer(kint) :: j

	aParticles => aMesh%particles
	aPanels => aMesh%panels

	do j = 1, aParticles%N
		aParticles%relVort(j) = LegendreP54( aParticles%x(3,j)/EARTH_RADIUS ) * cos( 4.0_kreal * Longitude( aParticles%x(:,j) ))/EARTH_RADIUS

		aParticles%potVort(j) = -30.0_kreal * aParticles%relVort(j)
	enddo
	do j = 1, aPanels%N
		if ( .NOT. aPanels%hasChildren(j) ) then
			aPanels%relVort(j) = LegendreP54( aPanels%x(3,j)/EARTH_RADIUS )* cos( 4.0_kreal * Longitude( aPanels%x(:,j) ) )/EARTH_RADIUS
			aPanels%potVort(j) = -30.0_kreal * aPanels%relVort(j)
		else
			aPanels%relVort(j) = 0.0_kreal
			aPanels%potVort(j) = 0.0_kreal
		endif
	enddo
end subroutine

subroutine TestSphericalHarmonic10_3(amesh, rescale)
	type(SphereMesh), intent(inout) :: aMesh
	logical(klog), intent(in) :: rescale
	!
	type(Particles), pointer :: aparticles
	type(Panels), pointer :: apanels
	integer(kint) :: j
	real(kreal) :: qt(3,3), lat, lon, u(3)

	aParticles => aMesh%particles
	aPanels => aMesh%panels
	u = 0.0_kreal
	do j = 1, aParticles%N
		lat = Latitude(aParticles%x(:,j))
		lon = Longitude(aParticles%x(:,j))
		qt(:,1) = [ - sin(lon), cos(lon), 0.0_kreal]
		qt(:,2) = [ - sin(lat)*cos(lon), -sin(lat)*sin(lon), cos(lat) ]
		qt(:,3) = [ cos(lat)*cos(lon), cos(lat)*sin(lon), sin(lat) ]
		if ( rescale ) then
			u(1) = 3.0_kreal * cos(lat)*cos(lat)*sin(3.0_kreal*lon)* &
						( -7.0_kreal*sin(lat) + 105.0_kreal*sin(lat)**3 - 357.0_kreal*sin(lat)**5 + 325.0_kreal*sin(lat)**7) !/ EARTH_RADIUS
			u(2) = (3.0_kreal*cos(lat)**2*sin(lat)*cos(3.0_kreal*lon)* &
					( -7.0_kreal*sin(lat) + 105.0_kreal*sin(lat)**3 - 357.0_kreal*sin(lat)**5 + 325.0_kreal*sin(lat)**7) - &
					cos(lat)**3*cos(3.0_kreal*lon)*&
					( -7.0_kreal*cos(lat) + 315.0_kreal*sin(lat)**2*cos(lat) - 1785.0_kreal*sin(lat)**4*cos(lat) + 2275.0_kreal*sin(lat)**6*cos(lat))) !/EARTH_RADIUS
			aParticles%relVort(j) = LegendreP10_3( aParticles%x(3,j)/EARTH_RADIUS ) * cos( 3.0_kreal * Longitude( aParticles%x(:,j) ))!/EARTH_RADIUS
		else
			u(1) = 3.0_kreal * cos(lat)*cos(lat)*sin(3.0_kreal*lon)* &
						( -7.0_kreal*sin(lat) + 105.0_kreal*sin(lat)**3 - 357.0_kreal*sin(lat)**5 + 325.0_kreal*sin(lat)**7) / EARTH_RADIUS
			u(2) = (3.0_kreal*cos(lat)**2*sin(lat)*cos(3.0_kreal*lon)* &
					( -7.0_kreal*sin(lat) + 105.0_kreal*sin(lat)**3 - 357.0_kreal*sin(lat)**5 + 325.0_kreal*sin(lat)**7) - &
					cos(lat)**3*cos(3.0_kreal*lon)*&
					( -7.0_kreal*cos(lat) + 315.0_kreal*sin(lat)**2*cos(lat) - 1785.0_kreal*sin(lat)**4*cos(lat) + 2275.0_kreal*sin(lat)**6*cos(lat))) /EARTH_RADIUS
			aParticles%relVort(j) = LegendreP10_3( aParticles%x(3,j)/EARTH_RADIUS ) * cos( 3.0_kreal * Longitude( aParticles%x(:,j) )) / EARTH_RADIUS
		endif
		aParticles%x0(:,j) = matmul(qt,u)
		aParticles%potVort(j) = -110.0_kreal * aParticles%relVort(j)
	enddo
	do j = 1, aPanels%N
		if ( .NOT. aPanels%hasChildren(j) ) then
			lat = Latitude(aPanels%x(:,j))
			lon = Longitude(aPanels%x(:,j))
			if ( rescale ) then
				aPanels%relVort(j) = LegendreP10_3( aPanels%x(3,j)/EARTH_RADIUS )* cos( 3.0_kreal * Longitude( aPanels%x(:,j) ) )!/EARTH_RADIUS
				u(1) = 3.0_kreal * cos(lat)*cos(lat)*sin(3.0_kreal*lon)* &
						( -7.0_kreal*sin(lat) + 105.0_kreal*sin(lat)**3 - 357.0_kreal*sin(lat)**5 + 325.0_kreal*sin(lat)**7) !/ EARTH_RADIUS
				u(2) = (3.0_kreal*cos(lat)**2*sin(lat)*cos(3.0_kreal*lon)* &
					( -7.0_kreal*sin(lat) + 105.0_kreal*sin(lat)**3 - 357.0_kreal*sin(lat)**5 + 325.0_kreal*sin(lat)**7) - &
					cos(lat)**3*cos(3.0_kreal*lon)*&
					( -7.0_kreal*cos(lat) + 315.0_kreal*sin(lat)**2*cos(lat) - 1785.0_kreal*sin(lat)**4*cos(lat) + 2275.0_kreal*sin(lat)**6*cos(lat)))!/EARTH_RADIUS
			else
				aPanels%relVort(j) = LegendreP10_3( aPanels%x(3,j)/EARTH_RADIUS )* cos( 3.0_kreal * Longitude( aPanels%x(:,j) ) ) / EARTH_RADIUS
				u(1) = 3.0_kreal * cos(lat)*cos(lat)*sin(3.0_kreal*lon)* &
						( -7.0_kreal*sin(lat) + 105.0_kreal*sin(lat)**3 - 357.0_kreal*sin(lat)**5 + 325.0_kreal*sin(lat)**7) / EARTH_RADIUS
				u(2) = (3.0_kreal*cos(lat)**2*sin(lat)*cos(3.0_kreal*lon)* &
					( -7.0_kreal*sin(lat) + 105.0_kreal*sin(lat)**3 - 357.0_kreal*sin(lat)**5 + 325.0_kreal*sin(lat)**7) - &
					cos(lat)**3*cos(3.0_kreal*lon)*&
					( -7.0_kreal*cos(lat) + 315.0_kreal*sin(lat)**2*cos(lat) - 1785.0_kreal*sin(lat)**4*cos(lat) + 2275.0_kreal*sin(lat)**6*cos(lat))) / EARTH_RADIUS
			endif
			qt(:,1) = [ - sin(lon), cos(lon), 0.0_kreal]
			qt(:,2) = [ - sin(lat)*cos(lon), -sin(lat)*sin(lon), cos(lat) ]
			qt(:,3) = [ cos(lat)*cos(lon), cos(lat)*sin(lon), sin(lat) ]
			aPanels%x0(:,j) = matmul(qt,u)
			aPanels%potVort(j) = -110.0_kreal * aPanels%relVort(j)
		else
			aPanels%x0(:,j) = 0.0_kreal
			aPanels%relVort(j) = 0.0_kreal
			aPanels%potVort(j) = 0.0_kreal
		endif
	enddo
end subroutine

subroutine SSRFPACKApproximations( aMesh )
	type(SphereMesh), intent(inout) :: aMesh
	!
	type(STRIPACKData) :: delTri
	type(SSRFPACKData) :: relVortSource
	type(Particles), pointer :: aParticles
	type(Panels), pointer :: aPanels
	integer(kint) :: j, k, errCode
	real(kreal) :: grad1grad(3), grad2grad(3), grad3grad(3)
	! store computed laplacian in h variable
	! store computed gradient in u variable

	aParticles => aMesh%particles
	aPanels => aMesh%panels

	! build delaunay triangulation of particles
	call New(delTri, aMesh)
	! use Relative Vorticity as source data for interpolation / approximation
	call New(relVortSource, delTri, .FALSE. )
	call SetSourceRelVort(relVortSource, delTri)

	do j = 1, aParticles%N
		aParticles%div(j) = InterpolateScalar(aParticles%x(:,j), relVortSource, delTri)
		aParticles%u(:,j) = relVortSource%grad1(:,aPanels%N_Active + j)/EARTH_RADIUS
	enddo
	k = 1
	do j = 1, aPanels%N
		if ( .NOT. aPanels%hasChildren(j) ) then
			aPanels%div(j) = InterpolateScalar(aPanels%x(:,j), relVortSource, delTri)
			aPanels%u(:,delTri%activeMap(k)) = relVortSource%grad1(:,k)/EARTH_RADIUS
			k = k+1
		endif
	enddo

	k = 1
	do j = 1, aPanels%N
		if ( .NOT. aPanels%hasChildren(j) ) then
			call GRADL(delTri%n, k, delTri%x, delTri%y, delTri%z, relVortSource%grad1(1,:), &
				delTri%list, delTri%lptr, delTri%lend, grad1grad, errCode)
			call GRADL(delTri%n, k, delTri%x, delTri%y, delTri%z, relVortSource%grad1(2,:), &
				delTri%list, delTri%lptr, delTri%lend, grad2grad, errCode)
			call GRADL(delTri%n, k, delTri%x, delTri%y, delTri%z, relVortSource%grad1(3,:), &
				delTri%list, delTri%lptr, delTri%lend, grad3grad, errCode)
			aPanels%h(j) = (grad1grad(1) + grad2grad(2) + grad3grad(3))!/EARTH_RADIUS
			k = k + 1
		endif
	enddo
	do j = 1, aParticles%N
		call GRADL(delTri%n, aPanels%N_Active + j, delTri%x, delTri%y, delTri%z, relVortSource%grad1(1,:), &
			delTri%list, delTri%lptr, delTri%lend, grad1grad, errCode)
		call GRADL(delTri%n, aPanels%N_Active + j, delTri%x, delTri%y, delTri%z, relVortSource%grad1(2,:), &
			delTri%list, delTri%lptr, delTri%lend, grad2grad, errCode)
		call GRADL(delTri%n, aPanels%N_Active + j, delTri%x, delTri%y, delTRi%z, relVortSource%grad1(3,:), &
			delTri%list, delTri%lptr, delTri%lend, grad3grad, errCode)
		aParticles%h(j) = (grad1grad(1) + grad2grad(2) + grad3grad(3))!/EARTH_RADIUS
	enddo
	call Delete(delTri)
end subroutine

subroutine TrivariateQuadraticApproximations( aMesh )
	type(SphereMesh), intent(inout) :: aMesh
	!
	type(Particles), pointer :: aParticles
	type(Panels), pointer :: aPanels
	integer(kint) :: i, j, k, n, m, errCode
	real(kreal) :: A(31,10), AT(10,31), ATA(10,10), ATAInvAT(10,31), coeffs(10), scalarData(31), datalocs(3,31)
	real(kreal) :: work(41), coeffs2(10), scalarData2(31), rwork(20), tau(10)
	integer(kint) :: lsqM, lsqN, nrhs, info, jpivot(10)
	integer(kint), save :: lWork = -1
	integer(kint) :: adjPanels(8), nAdj, edgeList(8), vertList(8), nVerts, nearbyParticles(20), nNear
	logical(klog) :: isNewPoint, lworkLogged
	integer(kint), allocatable :: particleChecked(:)

	aParticles => aMesh%particles
	aPanels => aMesh%panels
	allocate(particleChecked(aParticles%N))
	particleChecked = 0
print *, "Trivariate do loop ..."
	do j = 1, aPanels%N
		if ( .NOT. aPanels%hasChildren(j) ) then
			! start fresh
			A = 0.0_kreal
			AT = 0.0_kreal
			ATA = 0.0_kreal
			ATAInvAT = 0.0_kreal
			datalocs = 0.0_kreal
			scalardata = 0.0_kreal

			nearbyParticles = 0
			nNear = 0
			adjPanels = 0
			nAdj = 0

			work = 0.0_kreal
			rwork = 0.0_kreal
			jpivot = 0

			!
			!	get list of nearby passive particles using adjacent panels
			!
			!	start with panel j
			call CCWEdgesAndParticlesAroundPanel(edgeList, vertList, nVerts, aMesh, j)
			nearbyParticles(1:nverts) = vertList
			nNear = nVerts
			! 	continue with panels adjacent to panel j
			call FindAdjacentPanels(adjPanels, nAdj, aMesh, j)
			do k = 1, nAdj
				call CCWEdgesAndParticlesAroundPanel(edgeList, vertList, nVerts, amesh, adjPanels(k) )
				do i = 1, nVerts
					isNewPoint = .TRUE.
					do m = 1, nNear
						if ( nearbyParticles(m) == vertList(i) ) isNewPoint = .FALSE. ! skip duplicates
					enddo
					if ( isNewPoint ) then
						nearbyParticles( nNear + 1 ) = vertList(i)
						nNear = nNear + 1
					endif
				enddo
			enddo

			!
			! gather data and locations for interpolation matrix
			!
			! start with panel j
			dataLocs(:,1) = aPanels%x(:,j)
			scalarData(1) = aPanels%relVort(j)
			! continue with adjacent panels
			do k = 1, nAdj
				dataLocs(:,k+1) = aPanels%x(:, adjPanels(k))
				scalarData(k+1) = aPanels%relVort(adjPanels(k))
			enddo
			! continue with passive particles
			do k = 1, nNear
				dataLocs(:, 1 + nAdj + k) = aParticles%x(:, nearbyParticles(k))
				scalarData(1 + nAdj + k) = aParticles%relVort(nearbyParticles(k))
			enddo
			!	add two points off the sphere to improve the condition number of the interpolation matrix
			dataLocs(:, 1 + nAdj + nNear + 1) = 2.0_kreal * aPanels%x(:, j)
			scalarData(1 + nAdj + nNear + 1) = aPanels%relVort(j)
			dataLocs(:, 1 + nAdj + nNear + 2) = 0.0_kreal
			scalarData(1 + nAdj + nNear + 2) = apanels%relVort(j)

			n = 1 + nAdj + nNear + 2

			scalarData2 = scalarData

			!
			!	data collected. ready for least squares
			!
			!		setup interpolation matrix A
			!		A is an n x 10 matrix with n > 10
			A(1:n,1) = 1.0_kreal !* EARTH_RADIUS
			A(1:n,2) = dataLocs(1,1:n)
			A(1:n,3) = dataLocs(2,1:n)
			A(1:n,4) = dataLocs(3,1:n)
			A(1:n,5) = dataLocs(1,1:n) * dataLocs(2,1:n)
			A(1:n,6) = dataLocs(1,1:n) * dataLocs(3,1:n)
			A(1:n,7) = dataLocs(2,1:n) * dataLocs(3,1:n)
			A(1:n,8) = dataLocs(1,1:n) * dataLocs(1,1:n)
			A(1:n,9) = dataLocs(2,1:n) * dataLocs(2,1:n)
			A(1:n,10) = dataLocs(3,1:n) * dataLocs(3,1:n)

			!
			!	solve least squares problem with QR factorization using MKL Lapack
			!
			lsqM = n
			lsqN = 10
!			nRHS = 1
!			call dgels( 'N', lsqM, lsqN, nRHS, A(1:lsqM,10), lsqM, scalarData(1:lsqM), lsqM, work, lWork, info)
!			if ( info < 0 ) then
!				call LogMessage(exelog,ERROR_LOGGING_LEVEL,trim(logkey)//' dgels ERROR : found illegal value at position ',info)
!				call LogMessage(exelog,ERROR_LOGGING_LEVEL,trim(logKey)//' error found at panel ',j)
!			elseif ( info > 0 ) then
!				call LogMessage(exelog,ERROR_LOGGING_LEVEL,logKey,'dgels ERROR : found zero on diagonal of interpolation matrix')
!				call LogMessage(exelog,ERROR_LOGGING_LEVEL,trim(logKey)//' error found at panel ',j)
!			endif
!			coeffs = scalarData(1:10)

			call dgeqpf(lsqM, lsqN, A(1:lsqM,lsqN), lsqM, jpivot, tau, work, info)
			k = 0
			call dormqr('L', 'T', k, A(1:lsqM,lsqN), lsqM, tau, scalarData(1:lsqM), lsqM, work, lwork, info)

!
!			! setup normal equations
!
			!		setup interpolation matrix A
			!		A is an n x 10 matrix with n > 10
			A(1:n,1) = 1.0_kreal ! * EARTH_RADIUS
			A(1:n,2) = dataLocs(1,1:n)
			A(1:n,3) = dataLocs(2,1:n)
			A(1:n,4) = dataLocs(3,1:n)
			A(1:n,5) = dataLocs(1,1:n) * dataLocs(2,1:n)
			A(1:n,6) = dataLocs(1,1:n) * dataLocs(3,1:n)
			A(1:n,7) = dataLocs(2,1:n) * dataLocs(3,1:n)
			A(1:n,8) = dataLocs(1,1:n) * dataLocs(1,1:n)
			A(1:n,9) = dataLocs(2,1:n) * dataLocs(2,1:n)
			A(1:n,10) = dataLocs(3,1:n) * dataLocs(3,1:n)
			AT = transpose(A)
			ATA = matmul(AT,A)
			!
			!	find Cholesky factorization and invert ATA using LAPACK
			!
			call dpotrf('U', 10, ATA, 10, errCode)
			if ( errCode < 0 ) then
				call LogMessage(exeLog, ERROR_LOGGING_LEVEL, 'potrf ERROR : found illegal value at position ',errCode)
			elseif ( errCode > 0 ) then
				call LogMessage(exeLog, ERROR_LOGGING_LEVEL, 'potrf ERROR : ', 'non symmetric positive definite matrix.')
			endif
			call dpotri( 'U', 10, ATA, 10, errCode)
			if ( errCode < 0 ) then
				call LogMessage(exelog,ERROR_LOGGING_LEVEL,trim(logkey)//' potri ERROR : found illegal value at position ',errCode)
				call LogMessage(exelog,ERROR_LOGGING_LEVEL,trim(logKey)//' error found at panel ',j)
			elseif (errCode > 0 ) then
				call LogMessage(exelog,ERROR_LOGGING_LEVEL,logKey,'potri ERROR : found zero on diagonal of Cholesky matrix')
				call LogMessage(exelog,ERROR_LOGGING_LEVEL,trim(logKey)//' error found at panel ',j)
			endif
			! Unpack LAPACK's symmetric storage
			do m=1,10
				do k=m+1,10
					ata(k,m) = ata(m,k)
				enddo
			enddo

			ATAInvAT = matmul(ATA,AT)
			! find coefficients of quadratic approximating polynomial
			coeffs2 = matmul(ATAInvAT(:,1:n),scalarData2(1:n))

			!DEBUG
			if ( sum( ( coeffs2 - coeffs) * (coeffs2 - coeffs) ) > 1.0e-6 ) then
				call LogMessage(exeLog,ERROR_LOGGING_LEVEL,'LSQ Error : different coefficients at panel ', j)
				write(logstring,'(10(F16.8,A))') coeffs(1), ' ', coeffs(2), ' ', coeffs(3), ' ', coeffs(4), ' ', coeffs(5), ' ', &
												 coeffs(6), ' ', coeffs(7), ' ', coeffs(8), ' ', coeffs(9), ' ', coeffs(10)
				call LogMessage(exeLog, ERROR_LOGGING_LEVEL, 'QRFactor output : ', logstring)
				write(logstring,'(10(F16.8,A))') coeffs2(1), ' ', coeffs2(2), ' ', coeffs2(3), ' ', coeffs2(4), ' ', coeffs2(5), ' ', &
												 coeffs2(6), ' ', coeffs2(7), ' ', coeffs2(8), ' ', coeffs2(9), ' ', coeffs2(10)
				call LogMessage(exeLog, ERROR_LOGGING_LEVEL, 'Cholesky output : ', logstring)
				!coeffs = coeffs2
			endif

			!
			! compute approximations
			!
			! store approximate relVort in div variable
			! store computed gradient in u variable
			! store computed laplacian in h variable
			aPanels%div(j) = QuadraticScalarAppx( coeffs, aPanels%x(:,j))
			aPanels%u(:,j) = QuadraticGradAppx( coeffs, aPanels%x(:,j))
			aPanels%h(j) = QuadraticLaplacianAppx(coeffs, aPanels%x(:,j))

			call CCWEdgesAndParticlesAroundPanel(edgeList, vertList, nVerts, aMesh, j)
			do k = 1, nVerts
				aParticles%div(vertList(k)) = aParticles%div(vertList(k)) + QuadraticScalarAppx(coeffs,aParticles%x(:,vertList(k)))
				aParticles%u(:,vertList(k)) = aParticles%u(:,vertList(k)) + QuadraticGradAppx( coeffs, aParticles%x(:,vertList(k)))
				aParticles%h(vertList(k)) = aParticles%h(vertList(k)) + QuadraticLaplacianAppx(coeffs, aParticles%x(:,vertList(k)))
				particleChecked(vertList(k)) = particleChecked(vertList(k)) + 1
			enddo

		endif
	enddo
	do j = 1, aParticles%N
		aParticles%div(j) = aParticles%div(j) / real(particleChecked(j),kreal)
		aParticles%u(:,j) = aParticles%u(:,j)/real(particleChecked(j), kreal)
		aParticles%h(j) = aParticles%h(j)/real(particleChecked(j), kreal)
	enddo
	deallocate(particleChecked)
end subroutine

function QuadraticScalarAppx( coeffs, xyz)
	real(kreal) :: QuadraticScalarAppx
	real(kreal), intent(in) :: coeffs(10), xyz(3)
	QuadraticScalarAppx = coeffs(1) + coeffs(2) * xyz(1) + coeffs(3) * xyz(2) + coeffs(4) * xyz(3) + &
						  coeffs(5) * xyz(1) * xyz(2) + coeffs(6) * xyz(1) * xyz(3) + coeffs(7) * xyz(2) * xyz(3) + &
						  coeffs(8) * xyz(1) * xyz(1) + coeffs(9) * xyz(2) * xyz(2) + coeffs(10)* xyz(3) * xyz(3)
end function

function QuadraticGradAppx( coeffs, xyz)
	real(kreal) :: QuadraticGradAppx(3)
	real(kreal), intent(in) :: coeffs(10), xyz(3)
	!
	real(kreal) :: cartGrad(3), dotProd

	cartGrad = [ coeffs(2) + coeffs(5) * xyz(2) + coeffs(6) * xyz(3) + 2.0_kreal * coeffs(8) * xyz(1) , &
			     coeffs(3) + coeffs(5) * xyz(1) + coeffs(7) * xyz(3) + 2.0_kreal * coeffs(9) * xyz(2) , &
			     coeffs(4) + coeffs(6) * xyz(1) + coeffs(7) * xyz(2) + 2.0_kreal * coeffs(10) * xyz(3) ]

	dotProd = sum( xyz * cartGrad)

	QuadraticGradAppx = cartGrad - dotProd * xyz / EARTH_RADIUS / EARTH_RADIUS
end function

function QuadraticLaplacianAppx( coeffs, xyz )
	real(kreal)  :: QuadraticLaplacianAppx
	real(kreal), intent(in) :: coeffs(10), xyz(3)
	!
	real(kreal) :: projterm, sqRad, term_x, term_y, term_z

	sqRad = EARTH_RADIUS * EARTH_RADIUS

	projterm = coeffs(2) * xyz(1) + coeffs(3) * xyz(2) + coeffs(4) * xyz(3) + 2.0_kreal * coeffs(5) * xyz(1) * xyz(2) + &
			   2.0_kreal * coeffs(6) * xyz(1) * xyz(3) + 2.0_kreal * coeffs(7) * xyz(2) * xyz(3) + &
			   2.0_kreal * coeffs(8) * xyz(1) * xyz(1) + 2.0_kreal * coeffs(9) * xyz(2) * xyz(2) + &
			   2.0_kreal * coeffs(10)* xyz(3) * xyz(3)
	term_x = coeffs(2) + 2.0_kreal*coeffs(5)*xyz(2) + 2.0_kreal*coeffs(6)*xyz(3) + 4.0_kreal*coeffs(8)*xyz(1)
	term_y = coeffs(3) + 2.0_kreal*coeffs(5)*xyz(1) + 2.0_kreal*coeffs(7)*xyz(3) + 4.0_kreal*coeffs(9)*xyz(2)
	term_z = coeffs(4) + 2.0_kreal*coeffs(6)*xyz(1) + 2.0_kreal*coeffs(7)*xyz(2) + 4.0_kreal*coeffs(10)*xyz(3)

	QuadraticLaplacianAppx = (sqRad - xyz(1) * xyz(1)) * ( 2.0_kreal * coeffs(8) - projTerm / sqRad - xyz(1)*term_x / sqRad  ) - &
			 xyz(1)*xyz(2)*( coeffs(5) - xyz(1)*term_y /sqRad ) - &
			 xyz(1)*xyz(3)*( coeffs(6) - xyz(1)*term_z /sqRad ) - &
			 xyz(1)*xyz(2)*( coeffs(5) - xyz(2)*term_x /sqRad ) + &
			 ( sqRad - xyz(2)*xyz(2) ) * ( 2.0_kreal * coeffs(9) - projTerm/sqRad - xyz(2)*term_y/sqrad) - &
			 xyz(2)*xyz(3)*( coeffs(7) - xyz(2)*term_z /sqrad ) - &
			 xyz(1)*xyz(3)*( coeffs(6) - xyz(3)*term_x /sqrad ) - &
			 xyz(2)*xyz(3)*( coeffs(7) - xyz(3)*term_y /sqrad ) + &
			 ( sqrad - xyz(3)*xyz(3) ) * ( 2.0_kreal * coeffs(10) - projTerm/sqrad - xyz(3)*term_z/sqrad)

	QuadraticLaplacianAppx = QuadraticLaplacianAppx / (sqRad)

!	QuadraticLaplacianAppx = 2.0_kreal * sum(coeffs(8:10)) - 3.0_kreal * projterm / sqrad - &
!							 xyz(1) * term_x / sqrad - xyz(2) * term_y / sqrad - xyz(3) * term_z / sqrad
end function

subroutine CalculateError(amesh, gradLinf, gradL2, lapLinf, lapL2, scalarLinf, scalarL2)
	type(SphereMesh), intent(inout) :: amesh
	real(kreal), intent(out) :: gradLinf, gradL2, lapLinf, lapL2, scalarLinf, scalarL2
	! store spherical harmonic in relvort variable
	! store exact value of laplacian in potvort variable
	! store computed laplacian in h variable
	! store exact value of gradient in x0 variable
	! store computed gradient in u variable
	! store gradient linf error in tracer
	! store laplacian linf error in tracer
	type(Particles), pointer :: aParticles
	type(Panels), pointer :: aPanels
	integer(kint) :: j
	real(kreal) :: denomGradPinf, denomLapPinf, denomGradAinf, denomGradA2, denomLapAinf, denomLapA2

	aParticles => amesh%particles
	aPanels => amesh%panels

	denomGradPinf = 0.0_kreal
	denomLapPinf = 0.0_kreal
	do j = 1, aParticles%N
		aParticles%tracer(j,1) = sqrt(sum( (aParticles%x0(:,j) - aParticles%u(:,j)) * ( aParticles%x0(:,j) - aParticles%u(:,j) ) ))
		aParticles%tracer(j,2) = abs( aParticles%h(j) - aParticles%potVort(j) )
		aParticles%tracer(j,3) = abs( aparticles%div(j) - aParticles%relVort(j))
		if ( sqrt( sum( aParticles%x0(:,j)*aParticles%x0(:,j))) > denomGradPinf ) then
			denomGradPInf = sqrt(sum( aParticles%x0(:,j)*aParticles%x0(:,j)))
		endif
		if ( abs( aParticles%potVort(j)) > denomLapPinf  ) then
			denomLapPinf = abs( aParticles%potVort(j) )
		endif
	enddo

	denomGradAinf = 0.0_kreal
	denomGradA2 = 0.0_kreal
	denomLapAinf = 0.0_kreal
	denomLapA2 = 0.0_kreal
	do j = 1, aPanels%N
		if ( .NOT. aPanels%hasChildren(j) ) then
			aPanels%tracer(j,1) = sqrt(sum( (aPanels%x0(:,j) - aPanels%u(:,j)) * (aPanels%x0(:,j) - aPanels%u(:,j))))
			aPanels%tracer(j,2) = abs( aPanels%h(j) - aPanels%potVort(j))
			aPanels%tracer(j,3) = abs( aPanels%div(j) - apanels%relVort(j))
			if ( sqrt(sum( aPanels%x0(:,j)*aPanels%x0(:,j))) > denomGradAinf ) then
				denomGradAinf = sqrt(sum( aPanels%x0(:,j) * aPanels%x0(:,j) ))
			endif
			if ( abs( aPanels%potVort(j) ) > denomLapAinf ) then
				denomLapAinf = abs( aPanels%potVort(j) )
			endif

			denomGradA2 = denomGradA2 + sum(aPanels%x0(:,j) * aPanels%x0(:,j) ) * aPanels%area(j)
			denomLapA2 = denomLapA2 + aPanels%potVort(j) * aPanels%potVort(j) * aPanels%area(j)
		endif
	enddo
	denomGradA2 = sqrt(denomGradA2)
	denomLapA2 = sqrt(denomLapA2)

	aParticles%tracer(:,1) = aParticles%tracer(:,1) / max( denomGradPInf, denomGradAinf )
	aPanels%tracer(:,1) = aPanels%tracer(:,1) / max( denomGradPInf, denomGradAInf)
	aParticles%tracer(:,2) = aParticles%tracer(:,2) / max( denomLapPinf, denomLapAinf)
	aPanels%tracer(:,2) = aPanels%tracer(:,2) / max( denomLapPinf, denomLapAinf)
	aPanels%tracer(:,3) = apanels%tracer(:,3) / maxval(abs(aPanels%relVort(:)))
	aParticles%tracer(:,3) = aparticles%tracer(:,3) / maxval(abs(aparticles%relvort(:)))

!	if ( max( denomGradPInf, denomGradAinf ) > 2.0_kreal * ZERO_TOL ) then
!	endif
!	if ( max( denomLapPinf, denomLapAinf) > 2.0_kreal * ZERO_TOL ) then
!	endif

	gradLinf = max( maxval(aParticles%tracer(1:aParticles%N,1)), maxval(aPanels%tracer(1:aPanels%N,1))) / &
			   max( denomGradPinf, denomGradAinf)
	gradL2 = sqrt( sum( aPanels%tracer(1:aPanels%N,1) * aPanels%tracer(1:aPanels%N,1) * aPanels%area(1:aPanels%N) ) )/denomGradA2

	lapLinf = max( maxval(aParticles%tracer(1:aParticles%N, 2)), maxval(aPanels%tracer(1:aPanels%N,2))) / &
			 max( denomLapPinf, denomLapAInf)
	lapL2 = sqrt( sum( aPanels%tracer(1:aPanels%N,2) * aPanels%tracer(1:aPanels%N,2) * aPanels%area(1:aPanels%N) ) ) / denomLapA2

	scalarLinf = max( maxval(aParticles%tracer(1:aParticles%N,3)), maxval(aPanels%tracer(1:aPanels%N,3)) ) / maxval(abs(aParticles%relvort(1:aParticles%N)))
	scalarL2 = sqrt(sum( aPanels%tracer(1:aPanels%N,3) * aPanels%tracer(1:aPanels%N,3) * aPanels%area(1:aPanels%N) ))  / &
			   sqrt(sum( aPanels%relVort(:) * aPanels%relvort(:) * aPanels%area(:) ))
end subroutine

end program


module SphereBVEModule
!> @file SphereBVE.f90
!> Data structure for representing solutions of the Barotropic Vorticity Equation (BVE) on the surface of a rotating sphere
!> @author Peter Bosler, Sandia National Laboratories Center for Computing Research
!>
!>
!> @defgroup SphereBVE SphereBVE
!> @brief Data structure for representing solutions of the Barotropic Vorticity Equation (BVE) on the surface of a rotating sphere.
!>
!> Combines a @ref PolyMesh2d with the data @ref Field objects for the BVE.
!> Allows users to optionally add @ref Field objects for passive tracers.
!>
!> In addition to the variables carried by the base @ref Particles object (e.g., physical and Lagrangian coordinates),
!> the BVEMesh data type adds fields for relative vorticity @f$ \zeta(x,y,z,t) @f$ and the materially conserved absolute vorticity @f$ \omega(x_0,y_0,z_0) @f$.
!> These variables are related by the equation
!> @f[
!> 		\omega = \zeta + f,
!> @f]
!> where @f$ f = \frac{2\Omega}{a}z(t) @f$ is the Coriolis parameter, @f$ \Omega @f$ is the constant angular velocity of the sphere about the z-axis,
!> and @f$ a @f$ is the radius of the sphere.
!>
!> Two stream functions are defined on the particles, @f$ \psi_r(x,y,z,t) @f$ is defined with respect to the rotating frame
!> and @f$ \psi_a(x,y,z,t) @f$ is defined with respect to the inertial frame.
!> Both are represented (and computed) by convolution with the Green's function kernel,
!> @f{align*}{
!> 		\psi_r(\vec{x},t) &= \frac{1}{4\pi a}\int_{S} \log( 1 - \vec{x} \cdot \vec{\tilde{x}})\zeta(\vec{\tilde{x}})\,dA, \\
!> 	    \psi_a(\vec{x},t) &= \frac{1}{4\pi a}\int_{S} \log( 1 - \vec{x} \cdot \vec{\tilde{x}})\omega(\vec{\tilde{x}})\,dA.
!> @f}
!>
!> The particles also have a @ref Field to track their velocity, which is given by convolution with the Biot-Savart kernel,
!> @f[
!> 		\vec{u}(\vec{x},t) = -\frac{1}{4\pi a}\int_{S} \frac{ \vec{x} \times \vec{\tilde{x}} }{a^2 - \vec{x}\cdot\vec{\tilde{x}}} \zeta(\vec{\tilde{x}})\,dA.
!> @f]
!>
!>	For a more detailed discussion, see @n
!> * P. Bosler, L. Wang, C. Jablonowski, and R. Krasny, A Lagrangian particle/panel method for the barotropic vorticity
!> 	equations on a rotating sphere, _Fluid Dynamics Research_ 46 (2014).  DOI: 10.1088/0169-5983/46/3/031406.
!>
!>
!> @{
use NumberKindsModule
use OutputWriterModule
use LoggerModule
use ParticlesModule
use EdgesModule
use FacesModule
use PolyMesh2dModule
use FieldModule
use MPISetupModule
use SphereGeomModule

implicit none

include 'mpif.h'

private
!
!----------------
! Module types and public declarations
!----------------
!
public BVEMesh, New, Delete, Copy
public AddTracers
public LogStats
public OutputToVTK
public SetInitialVorticityOnMesh, SetVelocityOnMesh, SetStreamFunctionsOnMesh
public TotalKE, TotalEnstrophy
public MaxCirculationMagnitudePerFace

!> @brief Defines a spherical mesh and the appropriate variables for solving the Barotropic Vorticity Equation (BVE) on a rotating sphere.
type BVEMesh
	type(PolyMesh2d) :: mesh !< @ref PolyMesh2d for spatial discretization
	type(Field) :: absVort !< scalar @ref Field
	type(Field) :: relVort !< scalar @ref Field
	type(Field) :: relStream !< scalar @ref Field
	type(Field) :: absStream !< scalar @ref Field
	type(Field) :: velocity !< vector @ref Field
	type(Field), dimension(:), allocatable :: tracers !< allocatable array of scalar and vector @ref Field objects
	real(kreal) :: radius = 1.0_kreal !< radius of sphere
	real(kreal) :: rotationRate = 0.0_kreal !< background rotation rate (angular velocity)
	type(MPISetup) :: mpiParticles !< @ref MPISetup to distribute all particles over the available MPI ranks

	contains
		final :: deletePrivate
end type

!
!----------------
! Module interfaces
!----------------
!

interface New
	module procedure newPrivate
end interface

interface Delete
	module procedure deletePrivate
end interface

interface Copy
	module procedure copyPrivate
end interface

interface LogStats
	module procedure logStatsPrivate
end interface

interface SetVelocityOnMesh
	module procedure setVelocityFromFunction
	module procedure setVelocityFromVorticity
end interface

interface OutputToVTK
	module procedure outputVTKPrivate
end interface

!
!----------------
! Logging
!----------------
!
logical(klog), save :: logInit = .FALSE.
type(Logger) :: log
character(len=28), save :: logKey = 'BVE'
integer(kint), parameter :: logLevel = DEBUG_LOGGING_LEVEL

contains
!
!----------------
! public methods
!----------------
!

!> @brief Allocates memory and initializes a spherical mesh for BVE applications.
!>
!> @param[out] self new BVE mesh
!> @param[in] meshSeed mesh seed integer, as defined in @ref NumberKinds
!> @param[in] initNest initial level of uniform refinement
!> @param[in] maxNest maximum level of uniform refinment
!> @param[in] amrLimit maximum number of times an individual face can be divided beyond initNest
!> @param[in] sphereRadius radius of sphere
!> @param[in] rotationRate background angular velocity of sphere
subroutine newPrivate( self, meshSeed, initNest, maxNest, amrLimit, sphereRadius, rotationRate )
	type(BVEMesh), intent(out) :: self
	integer(kint), intent(in) :: meshSeed
	integer(kint), intent(in) :: initNest
	integer(kint), intent(in) :: maxNest
	integer(kint), intent(in) :: amrLimit
	real(kreal), intent(in) :: sphereRadius
	real(kreal), intent(in) :: rotationRate

	if ( .NOT. logInit) call InitLogger(log, procRank)

	if ( meshSeed /= ICOS_TRI_SPHERE_SEED .AND. meshSeed /= CUBED_SPHERE_SEED ) then
		call LogMessage(log, ERROR_LOGGING_LEVEL, trim(logKey), "new BVEMesh ERROR : invalid meshSeed.")
		return
	endif

	call New(self%mesh, meshSeed, initNest, maxNest, amrLimit, sphereRadius)

	call New(self%absVort, 1, self%mesh%particles%N_Max, "absVort", "1/s")
	call New(self%relVort, 1, self%mesh%particles%N_Max, "relVort", "1/s")
	call New(self%absStream, 1, self%mesh%particles%N_Max, "absStreamFn", "m^2/s")
	call New(self%relStream, 1, self%mesh%particles%N_Max, "relStreamFn", "m^2/s")
	call New(self%velocity, 3, self%mesh%particles%N_Max, "velocity", "m/s")
	call New(self%mpiParticles, self%mesh%particles%N, numProcs)

	self%radius = sphereRadius
	self%rotationRate = rotationRate
end subroutine

!> @brief Deletes and frees memory associated with a spherical BVE Mesh
!> @param[inout] self Target BVE Mesh
subroutine deletePrivate( self )
	type(BVEMesh), intent(inout) :: self
	integer(kint) :: i

	call Delete(self%mpiParticles)
	call Delete(self%velocity)
	call Delete(self%relStream)
	call Delete(self%absStream)
	call Delete(self%absVort)
	call Delete(self%relVort)
	call Delete(self%mesh)
	if ( allocated(self%tracers) ) then
		do i = 1, size(self%tracers)
			call Delete(self%tracers(i))
		enddo
		deallocate(self%tracers)
	endif
end subroutine

!> @brief Performs a deep copy of a BVE mesh and all of its variables.
!> The target mesh must have been allocated prior to calling this subroutine.
!>
!> @param[inout] self Target BVE mesh
!> @param[in] other Source BVE Mesh
subroutine copyPrivate(self, other)
	type(BVEMesh), intent(inout) :: self
	type(BVEMesh), intent(in) :: other
	integer(kint) :: i

	call Copy(self%mesh, other%mesh)
	call Copy(self%relVort, other%relVort)
	call Copy(self%absVort, other%absVort)
	call Copy(self%velocity, other%velocity)
	call Copy(self%absStream, other%absStream)
	call Copy(self%relStream, other%relStream)
	call Copy(self%mpiParticles, other%mpiParticles)
	self%rotationRate = other%rotationRate
	self%radius = other%radius

	if ( allocated(other%tracers)) then
		if ( allocated(self%tracers)) then
			if ( size(self%tracers) /= size(other%tracers) ) then
				call LogMessage(log, ERROR_LOGGING_LEVEL, logkey, " copy BVEMesh ERROR : tracers not allocated properly.")
			else
				do i = 1, size(other%tracers)
					call Copy(self%tracers(i), other%tracers(i))
				enddo
			endif
		else
			call LogMessage(log, WARNING_LOGGING_LEVEL, logKey, " copy BVEMesh WARNING : tracers not copied.")
		endif
	endif
end subroutine

!> @brief Adds memory for passive tracers to a spherical BVE mesh.
!> @param[inout] self Target BVE mesh
!> @param[in] nTracers number of tracers to add
!> @param[in] tracerDims array of values (each 1, 2, or 3) corresponding to the dimensions of each tracer.
!> Scalar tracers will have dimension 1, vector tracers will have dimension 2 or 3, depending on their coordinate system.
subroutine AddTracers(self, nTracers, tracerDims)
	type(BVEMesh), intent(inout) :: self
	integer(kint), intent(in) :: nTracers
	integer(kint), dimension(:), intent(in) :: tracerDims
	integer(kint) :: i

	if ( size(tracerDims) /= nTracers ) then
		call LogMessage(log, ERROR_LOGGING_LEVEL, trim(logkey)//" AddTracers ERROR : ", &
			" must specify dimension of each tracer field.")
		return
	endif

	allocate(self%tracers(nTracers))
	do i = 1, nTracers
		call New(self%tracers(i), tracerDims(i), self%mesh%particles%N_Max)
	enddo
end subroutine

!> @brief Output basic information about a BVE mesh to a @ref Logger
!> @param[in] self BVE mesh
!> @param[inout] aLog @ref Logger
subroutine logStatsPrivate( self, aLog)
	type(BVEMEsh), intent(in) :: self
	type(Logger), intent(inout) :: aLog
	!
	integer(kint) :: i

	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "BVEMesh ", "stats : ")
	call LogStats(self%mesh, aLog)
	call LogStats(self%velocity, aLog)
	call LogStats(self%relVort, aLog)
	call LogStats(self%absVort, aLog)
	call LogStats(self%relStream, aLog)
	call LogStats(self%absStream, aLog)
	if ( allocated( self%tracers ) ) then
		do i = 1, size(self%tracers)
			call LogStats(self%tracers(i), aLog)
		enddo
	endif
end subroutine

!> @brief Writes a BVE mesh to a legacy formatted .vtk file, including all @ref Field data for variables and tracers.
!> @param[in] self BVE mesh
!> @param[in] filename Name of output file
subroutine outputVTKPrivate(self, filename)
	type(BVEMesh), intent(in) :: self
	character(len=*), intent(in) :: filename
	integer(kint) :: i, writeStat

	open(unit=WRITE_UNIT_1, file=filename, status='REPLACE', action='WRITE', iostat=writeStat)
		if ( writeStat /= 0 ) then
			call LogMessage(log, ERROR_LOGGING_LEVEL, trim(logkey)//" OutputToVTK ERROR writing to file = ", trim(filename))
			return
		endif
		!
		!	write points and topology
		!
		call WriteVTKPoints(self%mesh%particles, WRITE_UNIT_1)
		call WriteFacesToVTKPolygons(self%mesh%faces, WRITE_UNIT_1)
		!
		!	write vtk point data
		!
		call WriteVTKPointDataSectionHeader(WRITE_UNIT_1, self%mesh%particles%N)
		call WriteVTKLagCoords( self%mesh%particles, WRITE_UNIT_1)
		call WriteFieldToVTKPointData( self%relVort, WRITE_UNIT_1)
		call WriteFieldToVTKPointData( self%absVort, WRITE_UNIT_1)
		call WriteFieldToVTKPointData( self%velocity, WRITE_UNIT_1)
		call WriteFieldToVTKPointData( self%relStream, WRITE_UNIT_1)
		call WriteFieldToVTKPointData( self%absStream, WRITE_UNIT_1)
		if ( allocated( self%tracers ) ) then
			do i = 1, size(self%tracers)
				call WriteFieldToVTKPointData( self%tracers(i), WRITE_UNIT_1)
			enddo
		endif
		!
		!	write vtk cell data
		!
		call WriteFaceAreaToVTKCellData( self%mesh%faces, self%mesh%particles, WRITE_UNIT_1)
	close(WRITE_UNIT_1)
end subroutine

!> @brief Defines an initial vorticity distribution on a BVE mesh.
!>
!> @param[inout] self BVE mesh
!> @param[in] relVortFn Vorticity distribution function.  Must have same interface as numberkindsmodule::scalarFnOf3DSpace
subroutine SetInitialVorticityOnMesh(self, relVortFn )
	type(BVEMesh), intent(inout) :: self
	procedure(scalarFnOf3DSpace) :: relVortFn
	integer(kint) :: i
	real(kreal) :: zeta

	self%relVort%N = self%mesh%particles%N
	self%absVort%N = self%mesh%particles%N
	do i = 1, self%mesh%particles%N
		zeta = relVortFn( self%mesh%particles%x0(i), self%mesh%particles%y0(i), self%mesh%particles%z0(i) )
		!call InsertScalarToField(self%relVort, zeta )
		!call InsertScalarToField(self%absVort, zeta + 2.0_kreal*self%rotationRate*self%mesh%particles%z0(i) / self%radius)
		self%relVort%scalar(i) = zeta
		self%absVort%scalar(i) = zeta + 2.0_kreal * self%rotationRate * self%mesh%particles%z0(i) / self%radius
	enddo
end subroutine

!> @brief Defines an initial velocity distribution on a BVE mesh.
!>
!> @param[inout] self BVE mesh
!> @param[in] velFn Velocity distribution function.  Must have same interface as numberkindsmodule::vectorFnOf3DSpace
subroutine setVelocityFromFunction(self, velFn )
	type(BVEMesh), intent(inout) :: self
	procedure(vectorFnOf3DSpace) :: velFn
	integer(kint) :: i

	do i = 1, self%mesh%particles%N
		call InsertVectorToField(self%velocity, &
			velFn( self%mesh%particles%x0(i), self%mesh%particles%y0(i), self%mesh%particles%z0(i)) )
	enddo
end subroutine

!> @brief Defines an initial tracer distribution on a BVE mesh.
!>
!> @param[inout] self BVE mesh
!> @param[in] tracerID index of tracer in `bveMesh%%tracers(:)`
!> @param[in] tracerFn Vorticity distribution function.  Must have same interface as numberkindsmodule::scalarFnOf3DSpace
subroutine SetScalarTracerOnMesh(self, tracerId, tracerFn )
	type(BVEMesh), intent(inout) :: self
	integer(kint), intent(in) :: tracerId
	procedure(scalarFnOf3DSpace) :: tracerFn
	integer(kint) :: i

	call SetFieldToZero(self%tracers(tracerID))
	self%tracers(tracerId)%N = self%mesh%particles%N
	do i = 1, self%mesh%particles%N
		self%tracers(tracerID)%scalar(i) = tracerFn( self%mesh%particles%x0(i), self%mesh%particles%y0(i), &
												     self%mesh%particles%z0(i) )
	enddo
end subroutine

!> @brief Defines an initial tracer distribution on a BVE mesh.
!>
!> @param[inout] self BVE mesh
!> @param[in] tracerID index of tracer in `bveMesh%%tracers(:)`
!> @param[in] tracerFn Vorticity distribution function.  Must have same interface as numberkindsmodule::vectorFnOf3DSpace
subroutine SetVectorTracerOnMesh( self, tracerID, tracerFn )
	type(BVEMesh), intent(inout) :: self
	integer(kint), intent(in) :: tracerId
	procedure(vectorFnOf3DSpace) :: tracerFn
	integer(kint) :: i
	real(kreal), dimension(3) :: vec

	call SetFieldToZero(self%tracers(tracerID))
	self%tracers(tracerID)%N = self%mesh%particles%N
	do i = 1, self%mesh%particles%N
		vec = tracerFn(self%mesh%particles%x0(i), self%mesh%particles%y0(i), self%mesh%particles%z0(i))
		self%tracers(tracerID)%xComp(i) = vec(1)
		self%tracers(tracerID)%yComp(i) = vec(2)
		self%tracers(tracerID)%zComp(i) = vec(3)
	enddo
end subroutine

!> @brief Computes the total kinetic energy (a conserved integral) on a BVE mesh.
!> @param[in] self BVE mesh
!> @return totalKE total kinetic energy
function TotalKE( self )
	real(kreal) :: TotaLKE
	type(BVEMesh), intent(in) :: self
	integer(kint) :: i
	real(kreal) :: magSq

	TotalKE = 0.0_kreal
	do i = 1, self%mesh%particles%N
		if ( self%mesh%particles%isActive(i) ) then
			magSq = self%velocity%xComp(i)**2 + self%velocity%yComp(i)**2 + self%velocity%zComp(i)**2
			TotalKE = TotalKE + magSq * self%mesh%particles%area(i)
		endif
	enddo
	TotalKE = 0.5_kreal * TotalKE
end function

!> @brief Computes the total enstrophy (a conserved integral) on a BVE mesh.
!> @param[in] self BVE mesh
!> @return totalKE total enstrophy
function TotalEnstrophy( self )
	real(kreal) :: TotalEnstrophy
	type(BVEMesh), intent(in) :: self
	integer(kint) :: i

	TotalEnstrophy = 0.0_kreal
	do i = 1, self%mesh%particles%N
		if ( self%mesh%particles%isActive(i) ) then
			TotalEnstrophy = TotalEnstrophy + self%relVort%scalar(i)**2 * self%mesh%particles%area(i)
		endif
	enddo
	TotalEnstrophy = 0.5_kreal * TotalEnstrophy
end function

!> @brief Defines the absolute and relative stream functions on a BVE mesh using the Green's function integral.
!> @param[inout] self BVE mesh
subroutine SetStreamFunctionsOnMesh( self )
	type(BVEMesh), intent(inout) :: self
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: greensKernel
	real(kreal), dimension(3) :: xi, xj

	self%relStream%n = self%mesh%particles%n
	self%absStream%n = self%mesh%particles%n
	do i = self%mpiParticles%indexStart(procRank), self%mpiParticles%indexEnd(procRank)
		self%relStream%scalar(i) = 0.0_kreal
		self%absStream%scalar(i) = 0.0_kreal
		xi = PhysCoord(self%mesh%particles, i)
		do j = 1, i - 1
			if ( self%mesh%particles%isActive(j) ) then
				xj = PhysCoord(self%mesh%particles, j)
				greensKernel = - dlog( self%radius * self%radius - sum(xi * xj)) / (4.0_kreal * PI )
				self%relStream%scalar(i) = self%relStream%scalar(i) + greensKernel * &
					self%relVort%scalar(j) * self%mesh%particles%area(j)
				self%absStream%scalar(i) = self%absStream%scalar(i) + greensKernel * &
					self%absVort%scalar(j) * self%mesh%particles%area(j)
			endif
		enddo
		do j = i + 1, self%mesh%particles%N
			if ( self%mesh%particles%isActive(j) ) then
				xj = PhysCoord(self%mesh%particles, j)
				greensKernel = - dlog( self%radius * self%radius - sum(xi * xj)) / (4.0_kreal * PI )
				self%relStream%scalar(i) = self%relStream%scalar(i) + greensKernel * &
					self%relVort%scalar(j) * self%mesh%particles%area(j)
				self%absStream%scalar(i) = self%absStream%scalar(i) + greensKernel * &
					self%absVort%scalar(j) * self%mesh%particles%area(j)
			endif
		enddo
	enddo

	do i = 0, numProcs - 1
		call MPI_BCAST(self%relStream%scalar(self%mpiParticles%indexStart(i):self%mpiParticles%indexEnd(i)), &
			self%mpiParticles%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
		call MPI_BCAST(self%absStream%scalar(self%mpiParticles%indexStart(i):self%mpiParticles%indexEnd(i)), &
			self%mpiParticles%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	enddo
end subroutine

!> @brief Defines the velocity distribution on a BVE mesh using the Biot-Savart integral.
!> @param[inout] self BVE mesh
subroutine setVelocityFromVorticity( self )
	type(BVEMesh), intent(inout) :: self
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: strength
	real(kreal), dimension(3) :: xi, xj

	self%velocity%n = self%mesh%particles%N
	do i = self%mpiParticles%indexStart(procRank), self%mpiParticles%indexEnd(procRank)
		self%velocity%xComp(i) = 0.0_kreal
		self%velocity%yComp(i) = 0.0_kreal
		self%velocity%zComp(i) = 0.0_kreal
		xi = PhysCoord(self%mesh%particles, i)
		do j = 1, i - 1
			if ( self%mesh%particles%isActive(j) ) then
				xj = PhysCoord(self%mesh%particles, j)
				strength = -self%relVort%scalar(j)*self%mesh%particles%area(j) / &
					(4.0_kreal * PI * self%radius * (self%radius * self%radius - sum( xi * xj )))
				self%velocity%xComp(i) = self%velocity%xComp(i) + (xi(2)*xj(3) - xi(3)*xj(2)) * strength
				self%velocity%yComp(i) = self%velocity%yComp(i) + (xi(3)*xj(1) - xi(1)*xj(3)) * strength
				self%velocity%zComp(i) = self%velocity%zComp(i) + (xi(1)*xj(2) - xi(2)*xj(1)) * strength
			endif
		enddo
		do j = i + 1, self%mesh%particles%N
			if ( self%mesh%particles%isActive(j) ) then
				xj = PhysCoord(self%mesh%particles, j)
				strength = -self%relVort%scalar(j)*self%mesh%particles%area(j) / &
					(4.0_kreal * PI * self%radius * (self%radius * self%radius - sum( xi * xj )))
				self%velocity%xComp(i) = self%velocity%xComp(i) + (xi(2)*xj(3) - xi(3)*xj(2)) * strength
				self%velocity%yComp(i) = self%velocity%yComp(i) + (xi(3)*xj(1) - xi(1)*xj(3)) * strength
				self%velocity%zComp(i) = self%velocity%zComp(i) + (xi(1)*xj(2) - xi(2)*xj(1)) * strength
			endif
		enddo
	enddo

	do i = 0, numProcs - 1
		call MPI_BCAST(self%velocity%xComp(self%mpiParticles%indexStart(i):self%mpiParticles%indexEnd(i)), &
					   self%mpiParticles%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
		call MPI_BCAST(self%velocity%yComp(self%mpiParticles%indexStart(i):self%mpiParticles%indexEnd(i)), &
					   self%mpiParticles%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
		call MPI_BCAST(self%velocity%zComp(self%mpiParticles%indexStart(i):self%mpiParticles%indexEnd(i)), &
					   self%mpiParticles%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	enddo
end subroutine

!> @brief Computes the maximum circulation magnitude about each face and returns the maximum value for the whole mesh.
!> @param[in] self BVE mesh
!> @return MaximumCirculation magnitude
function MaxCirculationMagnitudePerFace( self )
	real(kreal) :: MaxCirculationMagnitudePerFace
	type(BVEMesh), intent(in) :: self
	!
	integer(kint) :: i
	real(kreal) :: testCirc
	integer(kint) :: particleIndex

	MaxCirculationMagnitudePerFace = 0.0_kreal
	do i = 1, self%mesh%faces%N
		if ( .NOT. self%mesh%faces%hasChildren(i) ) then
			particleIndex = self%mesh%faces%centerParticle(i)
			testCirc = abs( self%relVort%scalar(particleIndex) ) * self%mesh%particles%area(particleIndex)
			if ( testCirc > MaxCirculationMagnitudePerFace ) MaxCirculationMagnitudePerFace = testCirc
		endif
	enddo
end function

!
!----------------
! private methods
!----------------
!

!> @brief Initializes a logger for the BVE module
!>
!> Output is controlled both by message priority and by MPI Rank
!> @param aLog Target Logger object
!> @param rank Rank of this processor
subroutine InitLogger(aLog,rank)
	type(Logger), intent(out) :: aLog
	integer(kint), intent(in) :: rank
	write(logKey,'(A,A,I0.2,A)') trim(logKey),'_',rank,' : '
	if ( rank == 0 ) then
		call New(aLog,logLevel)
	else
		call New(aLog,ERROR_LOGGING_LEVEL)
	endif
	logInit = .TRUE.
end subroutine

!> @}
end module


C  PCON61SUBD.F  25 February 1991
C
      INTEGER FUNCTION IDAMAX(N,DX,INCX)
C
C     FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(1),DMAX
      INTEGER I,INCX,IX,N
C
      IDAMAX = 0
      IF( N .LT. 1 ) RETURN
      IDAMAX = 1
      IF(N.EQ.1)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      IX = 1
      DMAX = DABS(DX(1))
      IX = IX + INCX
      DO 10 I = 2,N
         IF(DABS(DX(IX)).LE.DMAX) GO TO 5
         IDAMAX = I
         DMAX = DABS(DX(IX))
    5    IX = IX + INCX
   10 CONTINUE
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
   20 DMAX = DABS(DX(1))
      DO 30 I = 2,N
         IF(DABS(DX(I)).LE.DMAX) GO TO 30
         IDAMAX = I
         DMAX = DABS(DX(I))
   30 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
C
C     FORMS THE DOT PRODUCT OF TWO VECTORS.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(1),DY(1),DTEMP
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      DDOT = 0.0D0
      DTEMP = 0.0D0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DTEMP = DTEMP + DX(IX)*DY(IY)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      DDOT = DTEMP
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DTEMP = DTEMP + DX(I)*DY(I)
   30 CONTINUE
      IF( N .LT. 5 ) GO TO 60
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) +
     *   DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4)
   50 CONTINUE
   60 DDOT = DTEMP
      RETURN
      END
      SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO)
      INTEGER LDA,N,IPVT(1),INFO
      DOUBLE PRECISION A(LDA,1)
C
C     DGEFA FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION.
C
C     DGEFA IS USUALLY CALLED BY DGECO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C     (TIME FOR DGECO) = (1 + 9/N)*(TIME FOR DGEFA) .
C
C     ON ENTRY
C
C        A       DOUBLE PRECISION(LDA, N)
C                THE MATRIX TO BE FACTORED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C                WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                = 0  NORMAL VALUE.
C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C                     INDICATE THAT DGESL OR DGEDI WILL DIVIDE BY ZERO
C                     IF CALLED.  USE  RCOND  IN DGECO FOR A RELIABLE
C                     INDICATION OF SINGULARITY.
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DSCAL,IDAMAX
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION T
      INTEGER IDAMAX,J,K,KP1,L,NM1
C
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
      INFO = 0
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 K = 1, NM1
         KP1 = K + 1
C
C        FIND L = PIVOT INDEX
C
         L = IDAMAX(N-K+1,A(K,K),1) + K - 1
         IPVT(K) = L
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (A(L,K) .EQ. 0.0D0) GO TO 40
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. K) GO TO 10
               T = A(L,K)
               A(L,K) = A(K,K)
               A(K,K) = T
   10       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            T = -1.0D0/A(K,K)
            CALL DSCAL(N-K,T,A(K+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            DO 30 J = KP1, N
               T = A(L,J)
               IF (L .EQ. K) GO TO 20
                  A(L,J) = A(K,J)
                  A(K,J) = T
   20          CONTINUE
               CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
   30       CONTINUE
         GO TO 50
   40    CONTINUE
            INFO = K
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      IPVT(N) = N
      IF (A(N,N) .EQ. 0.0D0) INFO = N
      RETURN
      END
      SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB)
      INTEGER LDA,N,IPVT(1),JOB
      DOUBLE PRECISION A(LDA,1),B(1)
C
C     DGESL SOLVES THE DOUBLE PRECISION SYSTEM
C     A * X = B  OR  TRANS(A) * X = B
C     USING THE FACTORS COMPUTED BY DGECO OR DGEFA.
C
C     ON ENTRY
C
C        A       DOUBLE PRECISION(LDA, N)
C                THE OUTPUT FROM DGECO OR DGEFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM DGECO OR DGEFA.
C
C        B       DOUBLE PRECISION(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C        JOB     INTEGER
C                = 0         TO SOLVE  A*X = B ,
C                = NONZERO   TO SOLVE  TRANS(A)*X = B  WHERE
C                            TRANS(A)  IS THE TRANSPOSE.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE
C        CALLED CORRECTLY AND IF DGECO HAS SET RCOND .GT. 0.0
C        OR DGEFA HAS SET INFO .EQ. 0 .
C
C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
C     WITH  P  COLUMNS
C           CALL DGECO(A,LDA,N,IPVT,RCOND,Z)
C           IF (RCOND IS TOO SMALL) GO TO ...
C           DO 10 J = 1, P
C              CALL DGESL(A,LDA,N,IPVT,C(1,J),0)
C        10 CONTINUE
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DDOT
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION DDOT,T
      INTEGER K,KB,L,NM1
C
      NM1 = N - 1
      IF (JOB .NE. 0) GO TO 50
C
C        JOB = 0 , SOLVE  A * X = B
C        FIRST SOLVE  L*Y = B
C
         IF (NM1 .LT. 1) GO TO 30
         DO 20 K = 1, NM1
            L = IPVT(K)
            T = B(L)
            IF (L .EQ. K) GO TO 10
               B(L) = B(K)
               B(K) = T
   10       CONTINUE
            CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1)
   20    CONTINUE
   30    CONTINUE
C
C        NOW SOLVE  U*X = Y
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/A(K,K)
            T = -B(K)
            CALL DAXPY(K-1,T,A(1,K),1,B(1),1)
   40    CONTINUE
      GO TO 100
   50 CONTINUE
C
C        JOB = NONZERO, SOLVE  TRANS(A) * X = B
C        FIRST SOLVE  TRANS(U)*Y = B
C
         DO 60 K = 1, N
            T = DDOT(K-1,A(1,K),1,B(1),1)
            B(K) = (B(K) - T)/A(K,K)
   60    CONTINUE
C
C        NOW SOLVE TRANS(L)*X = Y
C
         IF (NM1 .LT. 1) GO TO 90
         DO 80 KB = 1, NM1
            K = N - KB
            B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1)
            L = IPVT(K)
            IF (L .EQ. K) GO TO 70
               T = B(L)
               B(L) = B(K)
               B(K) = T
   70       CONTINUE
   80    CONTINUE
   90    CONTINUE
  100 CONTINUE
      RETURN
      END
      SUBROUTINE DGEDI(A,LDA,N,IPVT,DET,WORK,JOB)
      INTEGER LDA,N,IPVT(1),JOB
      DOUBLE PRECISION A(LDA,1),DET(2),WORK(1)
C
C     DGEDI COMPUTES THE DETERMINANT AND INVERSE OF A MATRIX
C     USING THE FACTORS COMPUTED BY DGECO OR DGEFA.
C
C     ON ENTRY
C
C        A       DOUBLE PRECISION(LDA, N)
C                THE OUTPUT FROM DGECO OR DGEFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM DGECO OR DGEFA.
C
C        WORK    DOUBLE PRECISION(N)
C                WORK VECTOR.  CONTENTS DESTROYED.
C
C        JOB     INTEGER
C                = 11   BOTH DETERMINANT AND INVERSE.
C                = 01   INVERSE ONLY.
C                = 10   DETERMINANT ONLY.
C
C     ON RETURN
C
C        A       INVERSE OF ORIGINAL MATRIX IF REQUESTED.
C                OTHERWISE UNCHANGED.
C
C        DET     DOUBLE PRECISION(2)
C                DETERMINANT OF ORIGINAL MATRIX IF REQUESTED.
C                OTHERWISE NOT REFERENCED.
C                DETERMINANT = DET(1) * 10.0**DET(2)
C                WITH  1.0 .LE. DABS(DET(1)) .LT. 10.0
C                OR  DET(1) .EQ. 0.0 .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS
C        A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED.
C        IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY
C        AND IF DGECO HAS SET RCOND .GT. 0.0 OR DGEFA HAS SET
C        INFO .EQ. 0 .
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DSCAL,DSWAP
C     FORTRAN DABS,MOD
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION T
      DOUBLE PRECISION TEN
      INTEGER I,J,K,KB,KP1,L,NM1
C
C
C     COMPUTE DETERMINANT
C
      IF (JOB/10 .EQ. 0) GO TO 70
         DET(1) = 1.0D0
         DET(2) = 0.0D0
         TEN = 10.0D0
         DO 50 I = 1, N
            IF (IPVT(I) .NE. I) DET(1) = -DET(1)
            DET(1) = A(I,I)*DET(1)
C        ...EXIT
            IF (DET(1) .EQ. 0.0D0) GO TO 60
   10       IF (DABS(DET(1)) .GE. 1.0D0) GO TO 20
               DET(1) = TEN*DET(1)
               DET(2) = DET(2) - 1.0D0
            GO TO 10
   20       CONTINUE
   30       IF (DABS(DET(1)) .LT. TEN) GO TO 40
               DET(1) = DET(1)/TEN
               DET(2) = DET(2) + 1.0D0
            GO TO 30
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE
C
C     COMPUTE INVERSE(U)
C
      IF (MOD(JOB,10) .EQ. 0) GO TO 150
         DO 100 K = 1, N
            A(K,K) = 1.0D0/A(K,K)
            T = -A(K,K)
            CALL DSCAL(K-1,T,A(1,K),1)
            KP1 = K + 1
            IF (N .LT. KP1) GO TO 90
            DO 80 J = KP1, N
               T = A(K,J)
               A(K,J) = 0.0D0
               CALL DAXPY(K,T,A(1,K),1,A(1,J),1)
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE
C
C        FORM INVERSE(U)*INVERSE(L)
C
         NM1 = N - 1
         IF (NM1 .LT. 1) GO TO 140
         DO 130 KB = 1, NM1
            K = N - KB
            KP1 = K + 1
            DO 110 I = KP1, N
               WORK(I) = A(I,K)
               A(I,K) = 0.0D0
  110       CONTINUE
            DO 120 J = KP1, N
               T = WORK(J)
               CALL DAXPY(N,T,A(1,J),1,A(1,K),1)
  120       CONTINUE
            L = IPVT(K)
            IF (L .NE. K) CALL DSWAP(N,A(1,K),1,A(1,L),1)
  130    CONTINUE
  140    CONTINUE
  150 CONTINUE
      RETURN
      END
      SUBROUTINE DGBFA(ABD,LDA,N,ML,MU,IPVT,INFO)
      INTEGER LDA,N,ML,MU,IPVT(1),INFO
      DOUBLE PRECISION ABD(LDA,1)
C
C     DGBFA FACTORS A DOUBLE PRECISION BAND MATRIX BY ELIMINATION.
C
C     DGBFA IS USUALLY CALLED BY DGBCO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C
C     ON ENTRY
C
C        ABD     DOUBLE PRECISION(LDA, N)
C                CONTAINS THE MATRIX IN BAND STORAGE.  THE COLUMNS
C                OF THE MATRIX ARE STORED IN THE COLUMNS OF  ABD  AND
C                THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS
C                ML+1 THROUGH 2*ML+MU+1 OF  ABD .
C                SEE THE COMMENTS BELOW FOR DETAILS.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  ABD .
C                LDA MUST BE .GE. 2*ML + MU + 1 .
C
C        N       INTEGER
C                THE ORDER OF THE ORIGINAL MATRIX.
C
C        ML      INTEGER
C                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C                0 .LE. ML .LT. N .
C
C        MU      INTEGER
C                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C                0 .LE. MU .LT. N .
C                MORE EFFICIENT IF  ML .LE. MU .
C     ON RETURN
C
C        ABD     AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND
C                THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                = 0  NORMAL VALUE.
C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C                     INDICATE THAT DGBSL WILL DIVIDE BY ZERO IF
C                     CALLED.  USE  RCOND  IN DGBCO FOR A RELIABLE
C                     INDICATION OF SINGULARITY.
C
C     BAND STORAGE
C
C           IF  A  IS A BAND MATRIX, THE FOLLOWING PROGRAM SEGMENT
C           WILL SET UP THE INPUT.
C
C                   ML = (BAND WIDTH BELOW THE DIAGONAL)
C                   MU = (BAND WIDTH ABOVE THE DIAGONAL)
C                   M = ML + MU + 1
C                   DO 20 J = 1, N
C                      I1 = MAX0(1, J-MU)
C                      I2 = MIN0(N, J+ML)
C                      DO 10 I = I1, I2
C                         K = I - J + M
C                         ABD(K,J) = A(I,J)
C                10    CONTINUE
C                20 CONTINUE
C
C           THIS USES ROWS  ML+1  THROUGH  2*ML+MU+1  OF  ABD .
C           IN ADDITION, THE FIRST  ML  ROWS IN  ABD  ARE USED FOR
C           ELEMENTS GENERATED DURING THE TRIANGULARIZATION.
C           THE TOTAL NUMBER OF ROWS NEEDED IN  ABD  IS  2*ML+MU+1 .
C           THE  ML+MU BY ML+MU  UPPER LEFT TRIANGLE AND THE
C           ML BY ML  LOWER RIGHT TRIANGLE ARE NOT REFERENCED.
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DSCAL,IDAMAX
C     FORTRAN MAX0,MIN0
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION T
      INTEGER I,IDAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1
C
C
      M = ML + MU + 1
      INFO = 0
C
C     ZERO INITIAL FILL-IN COLUMNS
C
      J0 = MU + 2
      J1 = MIN0(N,M) - 1
      IF (J1 .LT. J0) GO TO 30
      DO 20 JZ = J0, J1
         I0 = M + 1 - JZ
         DO 10 I = I0, ML
            ABD(I,JZ) = 0.0D0
   10    CONTINUE
   20 CONTINUE
   30 CONTINUE
      JZ = J1
      JU = 0
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 130
      DO 120 K = 1, NM1
         KP1 = K + 1
C
C        ZERO NEXT FILL-IN COLUMN
C
         JZ = JZ + 1
         IF (JZ .GT. N) GO TO 50
         IF (ML .LT. 1) GO TO 50
            DO 40 I = 1, ML
               ABD(I,JZ) = 0.0D0
   40       CONTINUE
   50    CONTINUE
C
C        FIND L = PIVOT INDEX
C
         LM = MIN0(ML,N-K)
         L = IDAMAX(LM+1,ABD(M,K),1) + M - 1
         IPVT(K) = L + K - M
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (ABD(L,K) .EQ. 0.0D0) GO TO 100
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. M) GO TO 60
               T = ABD(L,K)
               ABD(L,K) = ABD(M,K)
               ABD(M,K) = T
   60       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            T = -1.0D0/ABD(M,K)
            CALL DSCAL(LM,T,ABD(M+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            JU = MIN0(MAX0(JU,MU+IPVT(K)),N)
            MM = M
            IF (JU .LT. KP1) GO TO 90
            DO 80 J = KP1, JU
               L = L - 1
               MM = MM - 1
               T = ABD(L,J)
               IF (L .EQ. MM) GO TO 70
                  ABD(L,J) = ABD(MM,J)
                  ABD(MM,J) = T
   70          CONTINUE
               CALL DAXPY(LM,T,ABD(M+1,K),1,ABD(MM+1,J),1)
   80       CONTINUE
   90       CONTINUE
         GO TO 110
  100    CONTINUE
            INFO = K
  110    CONTINUE
  120 CONTINUE
  130 CONTINUE
      IPVT(N) = N
      IF (ABD(M,N) .EQ. 0.0D0) INFO = N
      RETURN
      END
      SUBROUTINE DGBSL(ABD,LDA,N,ML,MU,IPVT,B,JOB)
      INTEGER LDA,N,ML,MU,IPVT(1),JOB
      DOUBLE PRECISION ABD(LDA,1),B(1)
C
C     DGBSL SOLVES THE DOUBLE PRECISION BAND SYSTEM
C     A * X = B  OR  TRANS(A) * X = B
C     USING THE FACTORS COMPUTED BY DGBCO OR DGBFA.
C
C     ON ENTRY
C
C        ABD     DOUBLE PRECISION(LDA, N)
C                THE OUTPUT FROM DGBCO OR DGBFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  ABD .
C
C        N       INTEGER
C                THE ORDER OF THE ORIGINAL MATRIX.
C
C        ML      INTEGER
C                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C
C        MU      INTEGER
C                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM DGBCO OR DGBFA.
C
C        B       DOUBLE PRECISION(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C        JOB     INTEGER
C                = 0         TO SOLVE  A*X = B ,
C                = NONZERO   TO SOLVE  TRANS(A)*X = B , WHERE
C                            TRANS(A)  IS THE TRANSPOSE.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE
C        CALLED CORRECTLY AND IF DGBCO HAS SET RCOND .GT. 0.0
C        OR DGBFA HAS SET INFO .EQ. 0 .
C
C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
C     WITH  P  COLUMNS
C           CALL DGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z)
C           IF (RCOND IS TOO SMALL) GO TO ...
C           DO 10 J = 1, P
C              CALL DGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0)
C        10 CONTINUE
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DDOT
C     FORTRAN MIN0
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION DDOT,T
      INTEGER K,KB,L,LA,LB,LM,M,NM1
C
      M = MU + ML + 1
      NM1 = N - 1
      IF (JOB .NE. 0) GO TO 50
C
C        JOB = 0 , SOLVE  A * X = B
C        FIRST SOLVE L*Y = B
C
         IF (ML .EQ. 0) GO TO 30
         IF (NM1 .LT. 1) GO TO 30
            DO 20 K = 1, NM1
               LM = MIN0(ML,N-K)
               L = IPVT(K)
               T = B(L)
               IF (L .EQ. K) GO TO 10
                  B(L) = B(K)
                  B(K) = T
   10          CONTINUE
               CALL DAXPY(LM,T,ABD(M+1,K),1,B(K+1),1)
   20       CONTINUE
   30    CONTINUE
C
C        NOW SOLVE  U*X = Y
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/ABD(M,K)
            LM = MIN0(K,M) - 1
            LA = M - LM
            LB = K - LM
            T = -B(K)
            CALL DAXPY(LM,T,ABD(LA,K),1,B(LB),1)
   40    CONTINUE
      GO TO 100
   50 CONTINUE
C
C        JOB = NONZERO, SOLVE  TRANS(A) * X = B
C        FIRST SOLVE  TRANS(U)*Y = B
C
         DO 60 K = 1, N
            LM = MIN0(K,M) - 1
            LA = M - LM
            LB = K - LM
            T = DDOT(LM,ABD(LA,K),1,B(LB),1)
            B(K) = (B(K) - T)/ABD(M,K)
   60    CONTINUE
C
C        NOW SOLVE TRANS(L)*X = Y
C
         IF (ML .EQ. 0) GO TO 90
         IF (NM1 .LT. 1) GO TO 90
            DO 80 KB = 1, NM1
               K = N - KB
               LM = MIN0(ML,N-K)
               B(K) = B(K) + DDOT(LM,ABD(M+1,K),1,B(K+1),1)
               L = IPVT(K)
               IF (L .EQ. K) GO TO 70
                  T = B(L)
                  B(L) = B(K)
                  B(K) = T
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
  100 CONTINUE
      RETURN
      END
      SUBROUTINE DGBDI(ABD,LDA,N,ML,MU,IPVT,DET)
      INTEGER LDA,N,ML,MU,IPVT(1)
      DOUBLE PRECISION ABD(LDA,1),DET(2)
C
C     DGBDI COMPUTES THE DETERMINANT OF A BAND MATRIX
C     USING THE FACTORS COMPUTED BY DGBCO OR DGBFA.
C     IF THE INVERSE IS NEEDED, USE DGBSL  N  TIMES.
C
C     ON ENTRY
C
C        ABD     DOUBLE PRECISION(LDA, N)
C                THE OUTPUT FROM DGBCO OR DGBFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  ABD .
C
C        N       INTEGER
C                THE ORDER OF THE ORIGINAL MATRIX.
C
C        ML      INTEGER
C                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C
C        MU      INTEGER
C                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM DGBCO OR DGBFA.
C
C     ON RETURN
C
C        DET     DOUBLE PRECISION(2)
C                DETERMINANT OF ORIGINAL MATRIX.
C                DETERMINANT = DET(1) * 10.0**DET(2)
C                WITH  1.0 .LE. DABS(DET(1)) .LT. 10.0
C                OR  DET(1) = 0.0 .
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     FORTRAN DABS
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION TEN
      INTEGER I,M
C
C
      M = ML + MU + 1
      DET(1) = 1.0D0
      DET(2) = 0.0D0
      TEN = 10.0D0
      DO 50 I = 1, N
         IF (IPVT(I) .NE. I) DET(1) = -DET(1)
         DET(1) = ABD(M,I)*DET(1)
C     ...EXIT
         IF (DET(1) .EQ. 0.0D0) GO TO 60
   10    IF (DABS(DET(1)) .GE. 1.0D0) GO TO 20
            DET(1) = TEN*DET(1)
            DET(2) = DET(2) - 1.0D0
         GO TO 10
   20    CONTINUE
   30    IF (DABS(DET(1)) .LT. TEN) GO TO 40
            DET(1) = DET(1)/TEN
            DET(2) = DET(2) + 1.0D0
         GO TO 30
   40    CONTINUE
   50 CONTINUE
   60 CONTINUE
      RETURN
      END
      SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
C
C     CONSTANT TIMES A VECTOR PLUS A VECTOR.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(1),DY(1),DA
      INTEGER I,INCX,INCY,M,MP1,N
C
      IF(N.LE.0)RETURN
      IF (DA .EQ. 0.0D0) RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DY(IY) = DY(IY) + DA*DX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,4)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DY(I) = DY(I) + DA*DX(I)
   30 CONTINUE
      IF( N .LT. 4 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,4
        DY(I) = DY(I) + DA*DX(I)
        DY(I + 1) = DY(I + 1) + DA*DX(I + 1)
        DY(I + 2) = DY(I + 2) + DA*DX(I + 2)
        DY(I + 3) = DY(I + 3) + DA*DX(I + 3)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE  DCOPY(N,DX,INCX,DY,INCY)
C
C     COPIES A VECTOR, X, TO A VECTOR, Y.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(1),DY(1)
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DY(IY) = DX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,7)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DY(I) = DX(I)
   30 CONTINUE
      IF( N .LT. 7 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,7
        DY(I) = DX(I)
        DY(I + 1) = DX(I + 1)
        DY(I + 2) = DX(I + 2)
        DY(I + 3) = DX(I + 3)
        DY(I + 4) = DX(I + 4)
        DY(I + 5) = DX(I + 5)
        DY(I + 6) = DX(I + 6)
   50 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX)
      INTEGER          NEXT
      DOUBLE PRECISION   DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE
      DATA   ZERO, ONE /0.0D0, 1.0D0/
C
C     EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE
C     INCREMENT INCX .
C     IF    N .LE. 0 RETURN WITH RESULT = 0.
C     IF N .GE. 1 THEN INCX MUST BE .GE. 1
C
C           C.L.LAWSON, 1978 JAN 08
C
C     FOUR PHASE METHOD     USING TWO BUILT-IN CONSTANTS THAT ARE
C     HOPEFULLY APPLICABLE TO ALL MACHINES.
C         CUTLO = MAXIMUM OF  DSQRT(U/EPS)  OVER ALL KNOWN MACHINES.
C         CUTHI = MINIMUM OF  DSQRT(V)      OVER ALL KNOWN MACHINES.
C     WHERE
C         EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1.
C         U   = SMALLEST POSITIVE NO.   (UNDERFLOW LIMIT)
C         V   = LARGEST  NO.            (OVERFLOW  LIMIT)
C
C     BRIEF OUTLINE OF ALGORITHM..
C
C     PHASE 1    SCANS ZERO COMPONENTS.
C     MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO
C     MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO
C     MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M
C     WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX.
C
C     VALUES FOR CUTLO AND CUTHI..
C     FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER
C     DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS..
C     CUTLO, S.P.   U/EPS = 2**(-102) FOR  HONEYWELL.  CLOSE SECONDS ARE
C                   UNIVAC AND DEC AT 2**(-103)
C                   THUS CUTLO = 2**(-51) = 4.44089E-16
C     CUTHI, S.P.   V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC.
C                   THUS CUTHI = 2**(63.5) = 1.30438E19
C     CUTLO, D.P.   U/EPS = 2**(-67) FOR HONEYWELL AND DEC.
C                   THUS CUTLO = 2**(-33.5) = 8.23181D-11
C     CUTHI, D.P.   SAME AS S.P.  CUTHI = 1.30438D19
C     DATA CUTLO, CUTHI / 8.232D-11,  1.304D19 /
C     DATA CUTLO, CUTHI / 4.441E-16,  1.304E19 /
      DATA CUTLO, CUTHI / 8.232D-11,  1.304D19 /
C
      IF(N .GT. 0) GO TO 10
         DNRM2  = ZERO
         GO TO 300
C
   10 ASSIGN 30 TO NEXT
      SUM = ZERO
      NN = N * INCX
C                                                 BEGIN MAIN LOOP
      I = 1
   20    GO TO NEXT,(30, 50, 70, 110)
   30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
      ASSIGN 50 TO NEXT
      XMAX = ZERO
C
C                        PHASE 1.  SUM IS ZERO
C
   50 IF( DX(I) .EQ. ZERO) GO TO 200
      IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
C
C                                PREPARE FOR PHASE 2.
      ASSIGN 70 TO NEXT
      GO TO 105
C
C                                PREPARE FOR PHASE 4.
C
  100 I = J
      ASSIGN 110 TO NEXT
      SUM = (SUM / DX(I)) / DX(I)
  105 XMAX = DABS(DX(I))
      GO TO 115
C
C                   PHASE 2.  SUM IS SMALL.
C                             SCALE TO AVOID DESTRUCTIVE UNDERFLOW.
C
   70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75
C
C                     COMMON CODE FOR PHASES 2 AND 4.
C                     IN PHASE 4 SUM IS LARGE.  SCALE TO AVOID OVERFLOW.
C
  110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115
         SUM = ONE + SUM * (XMAX / DX(I))**2
         XMAX = DABS(DX(I))
         GO TO 200
C
  115 SUM = SUM + (DX(I)/XMAX)**2
      GO TO 200
C
C
C                  PREPARE FOR PHASE 3.
C
   75 SUM = (SUM * XMAX) * XMAX
C
C
C     FOR REAL OR D.P. SET HITEST = CUTHI/N
C     FOR COMPLEX      SET HITEST = CUTHI/(2*N)
C
   85 HITEST = CUTHI/FLOAT( N )
C
C                   PHASE 3.  SUM IS MID-RANGE.  NO SCALING.
C
      DO 95 J =I,NN,INCX
      IF(DABS(DX(J)) .GE. HITEST) GO TO 100
   95    SUM = SUM + DX(J)**2
      DNRM2 = DSQRT( SUM )
      GO TO 300
C
  200 CONTINUE
      I = I + INCX
      IF ( I .LE. NN ) GO TO 20
C
C              END OF MAIN LOOP.
C
C              COMPUTE SQUARE ROOT AND ADJUST FOR SCALING.
C
      DNRM2 = XMAX * DSQRT(SUM)
  300 CONTINUE
      RETURN
      END
      SUBROUTINE  DSCAL(N,DA,DX,INCX)
C
C     SCALES A VECTOR BY A CONSTANT.
C     USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DA,DX(1)
      INTEGER I,INCX,M,MP1,N,NINCX
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      NINCX = N*INCX
      DO 10 I = 1,NINCX,INCX
        DX(I) = DA*DX(I)
   10 CONTINUE
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DX(I) = DA*DX(I)
   30 CONTINUE
      IF( N .LT. 5 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DX(I) = DA*DX(I)
        DX(I + 1) = DA*DX(I + 1)
        DX(I + 2) = DA*DX(I + 2)
        DX(I + 3) = DA*DX(I + 3)
        DX(I + 4) = DA*DX(I + 4)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE  DSWAP (N,DX,INCX,DY,INCY)
C
C     INTERCHANGES TWO VECTORS.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(1),DY(1),DTEMP
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C       CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL
C         TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DTEMP = DX(IX)
        DX(IX) = DY(IY)
        DY(IY) = DTEMP
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C       CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C       CLEAN-UP LOOP
C
   20 M = MOD(N,3)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DTEMP = DX(I)
        DX(I) = DY(I)
        DY(I) = DTEMP
   30 CONTINUE
      IF( N .LT. 3 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,3
        DTEMP = DX(I)
        DX(I) = DY(I)
        DY(I) = DTEMP
        DTEMP = DX(I + 1)
        DX(I + 1) = DY(I + 1)
        DY(I + 1) = DTEMP
        DTEMP = DX(I + 2)
        DX(I + 2) = DY(I + 2)
        DY(I + 2) = DTEMP
   50 CONTINUE
      RETURN
      END


*DECK SGBDI
      SUBROUTINE SGBDI (ABD, LDA, N, ML, MU, IPVT, DET)
C***BEGIN PROLOGUE  SGBDI
C***PURPOSE  Compute the determinant of a band matrix using the factors
C            computed by SGBCO or SGBFA.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D3A2
C***TYPE      SINGLE PRECISION (SGBDI-S, DGBDI-D, CGBDI-C)
C***KEYWORDS  BANDED, DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK,
C             MATRIX
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     SGBDI computes the determinant of a band matrix
C     using the factors computed by SBGCO or SGBFA.
C     If the inverse is needed, use SGBSL  N  times.
C
C     On Entry
C
C        ABD     REAL(LDA, N)
C                the output from SBGCO or SGBFA.
C
C        LDA     INTEGER
C                the leading dimension of the array  ABD .
C
C        N       INTEGER
C                the order of the original matrix.
C
C        ML      INTEGER
C                number of diagonals below the main diagonal.
C
C        MU      INTEGER
C                number of diagonals above the main diagonal.
C
C        IPVT    INTEGER(N)
C                the pivot vector from SBGCO or SGBFA.
C
C     On Return
C
C        DET     REAL(2)
C                determinant of original matrix.
C                Determinant = DET(1) * 10.0**DET(2)
C                with  1.0 .LE. ABS(DET(1)) .LT. 10.0
C                or  DET(1) = 0.0 .
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SGBDI
      INTEGER LDA,N,ML,MU,IPVT(*)
      REAL ABD(LDA,*),DET(2)
C
      REAL TEN
      INTEGER I,M
C***FIRST EXECUTABLE STATEMENT  SGBDI
      M = ML + MU + 1
      DET(1) = 1.0E0
      DET(2) = 0.0E0
      TEN = 10.0E0
      DO 50 I = 1, N
         IF (IPVT(I) .NE. I) DET(1) = -DET(1)
         DET(1) = ABD(M,I)*DET(1)
         IF (DET(1) .EQ. 0.0E0) GO TO 60
   10    IF (ABS(DET(1)) .GE. 1.0E0) GO TO 20
            DET(1) = TEN*DET(1)
            DET(2) = DET(2) - 1.0E0
         GO TO 10
   20    CONTINUE
   30    IF (ABS(DET(1)) .LT. TEN) GO TO 40
            DET(1) = DET(1)/TEN
            DET(2) = DET(2) + 1.0E0
         GO TO 30
   40    CONTINUE
   50 CONTINUE
   60 CONTINUE
      RETURN
      END