module BetaPlaneMeshModule
!> @file BetaPlane.f90
!> Data structure for  a planar incompressible flow with a background rotation
!> @author Peter Bosler, Sandia National Laboratories Center for Computing Research
!>
!>
!> @defgroup BetaPlane BetaPlane
!> Data structure for  a planar incompressible flow with a background rotation
!>
!> @{
use NumberKindsModule
use OutputWriterModule
use UtilitiesModule
use LoggerModule
use ParticlesModule
use EdgesModule
use FacesModule
use PolyMesh2dModule
use FieldModule
use MPISetupModule
use PlaneGeomModule

implicit none

include 'mpif.h'

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

type BetaPlaneMesh
	type(PolyMesh2D) :: mesh
	type(Field) :: absVort
	type(Field) :: relVort
	type(Field) :: relStream
	type(Field) :: absStream
	type(Field) :: velocity
	type(Field), dimension(:), allocatable :: tracers
	real(kreal) :: f0 = 0.0_kreal
	real(kreal) :: beta = 0.0_kreal
	type(MPISetup) :: mpiParticles
	logical(klog) :: useAMR = .FALSE.

	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 ResetPeriodicBounds
	module procedure resetPeriodicBoundsMesh
	module procedure resetPeriodicBoundsArray
end interface

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

contains
!
!----------------
! public methods
!----------------
!
subroutine newPrivate( self, initNest, maxNest, amrLimit, baseLat, rotRate )
	type(BetaPlaneMesh), intent(out) :: self
	integer(kint), intent(in) :: initNest
	integer(kint), intent(in) :: maxNest
	integer(kint), intent(in) :: amrLimit
	real(kreal), intent(in) :: baseLat
	real(kreal), intent(in), optional :: rotRate
	!
	integer(kint), parameter :: meshSeed = BETA_PLANE_SEED
	real(kreal), parameter :: ampFactor = 1.0_kreal

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

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

	if ( abs(baseLat) > PI/2.0_kreal) then
		call LogMessage(log, ERROR_LOGGING_LEVEL, trim(logKey)//" NewBetaPlaneMesh ERROR : ", "invalid baseLat")
	else
		if ( present(rotRate) ) then
			self%f0 = 2.0_kreal * rotRate * sin( baseLat )
			self%beta = 2.0_kreal * rotRate * cos( baseLat )
		else
			self%f0 = 2.0_kreal * (2.0_kreal * PI) * sin( baseLat )
			self%beta = 2.0_kreal * (2.0_kreal * PI) * cos( baseLat )
		endif
	endif

	call New(self%absVort, 1, self%mesh%particles%N_Max, "absVort", "1/time")
	call New(self%relVort, 1, self%mesh%particles%N_Max, "relVort", "1/time")
	call New(self%absStream, 1, self%mesh%particles%N_Max, "absStream", "area/time")
	call New(self%relStream, 1, self%mesh%particles%N_Max, "relStream", "area/time")
	call New(self%velocity, 2, self%mesh%particles%N_Max, "velocity", "distance/time")

	call New(self%mpiParticles, self%mesh%particles%N,  numProcs)
end subroutine

subroutine deletePrivate(self)
	type(BetaPlaneMesh), 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%relVort)
	call Delete(self%absVort)
	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

subroutine copyPrivate( self, other )
	type(BetaPlaneMesh), intent(inout) :: self
	type(BetaPlaneMesh), intent(in) :: other

	self%f0 = other%f0
	self%beta = other%beta
	call Copy(self%mesh, other%mesh)
	call Copy(self%absVort, other%absVort)
	call Copy(self%relVort, other%relVort)
	call Copy(self%absStream, other%absStream)
	call Copy(self%relStream, other%relStream)
	call Copy(self%velocity, other%velocity)
	call Copy(self%mpiParticles, other%mpiParticles)
end subroutine

subroutine AddTracers(self, nTracers, tracerDims)
	type(BetaPlaneMesh), 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

subroutine logStatsPrivate( self, aLog)
	type(BetaPlaneMesh), intent(in) :: self
	type(Logger), intent(inout) :: aLog
	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)
end subroutine

subroutine OutputToVTK(self, filename)
	type(BetaPlaneMesh), 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

subroutine SetInitialVorticityOnMesh( self, relVortFn )
	type(BetaPlaneMesh), intent(inout) :: self
	procedure(scalarFnof2DSpace) :: 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%relVort%scalar(i) = zeta
		self%absVort%scalar(i) = zeta + self%f0 + self%beta * self%mesh%particles%y0(i)
	enddo
end subroutine

subroutine setVelocityFromFunction(self, velFn )
	type(BetaPlaneMesh), intent(inout) :: self
	procedure(vectorFnOf2DSpace) :: velFn
	!
	integer(kint) :: i
	real(kreal), dimension(2) :: vel

	self%velocity%N = self%mesh%particles%N
	do i = 1, self%mesh%particles%N
		vel = velFn( self%mesh%particles%x(i), self%mesh%particles%y(i) )
		self%velocity%xComp(i) = vel(1)
		self%velocity%yComp(i) = vel(2)
	enddo
end subroutine

subroutine SetScalarTracerOnMesh( self, tracerID, tracerFn )
	type(BetaPlaneMesh), intent(inout) :: self
	integer(kint), intent(in) :: tracerID
	procedure(scalarFnof2DSpace) :: 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))
	enddo
end subroutine

subroutine SetVectorTracerOnMesh( self, tracerID, tracerFn)
	type(BetaPlaneMesh), intent(inout) :: self
	integer(kint), intent(in) :: tracerID
	procedure(vectorFnOf2DSpace) :: tracerFn
	!
	integer(kint) :: i
	real(kreal), dimension(2) :: 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%tracers(tracerID)%xComp(i) = vec(1)
		self%tracers(tracerID)%yComp(i) = vec(2)
	enddo
end subroutine

function TotalKE( self )
	real(kreal) :: TotalKE
	type(BetaPlaneMesh), 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
			TotalKE = TotalKE + magSq * self%mesh%particles%area(i)
		endif
	enddo
	TotalKE = 0.5_kreal * TotalKE
end function

function TotalEnstrophy(self)
	real(kreal) :: TotalEnstrophy
	type(BetaPlaneMesh), 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

function MaxCirculationMagnitudePerFace( self )
	real(kreal) :: MaxCirculationMagnitudePerFace
	type(BetaPlaneMesh), 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

subroutine setVelocityFromVorticity( self )
	type(BetaPlaneMesh), 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
		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 = 0.5_kreal * self%relVort%scalar(j) * self%mesh%particles%area(j) / &
					( cosh( 2.0_kreal * PI * (xi(2) - xj(2) )) - cos( 2.0_kreal * PI * ( xi(1) - xj(1) )) )
				self%velocity%xComp(i) = self%velocity%xComp(i) - sinh( 2.0_kreal * PI * ( xi(2) - xj(2) ) ) * strength
				self%velocity%yComp(i) = self%velocity%yComp(i) + sin( 2.0_kreal * PI * ( xi(1) - 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 = 0.5_kreal * self%relVort%scalar(j) * self%mesh%particles%area(j) / &
					( cosh( 2.0_kreal * PI * (xi(2) - xj(2) )) - cos( 2.0_kreal * PI * ( xi(1) - xj(1) )) )
				self%velocity%xComp(i) = self%velocity%xComp(i) - sinh( 2.0_kreal * PI * ( xi(2) - xj(2) ) ) * strength
				self%velocity%yComp(i) = self%velocity%yComp(i) + sin( 2.0_kreal * PI * ( xi(1) - 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)
	enddo
end subroutine

subroutine SetStreamFunctionsOnMesh( self )
	type(BetaPlaneMesh), intent(inout) :: self
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: greensKernel
	real(kreal), dimension(3) :: xi, xj

	self%absStream%N = self%mesh%particles%N
	self%relStream%N = self%mesh%particles%N
	do i = self%mpiParticles%indexStart(procRank), self%mpiParticles%indexEnd(procRank)
		self%absStream%scalar(i) = 0.0_kreal
		self%relStream%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( cosh(2.0_kreal * PI * ( xi(2) - xj(2) )) - cos( 2.0_kreal * PI * (xi(1) - xj(1)))) / &
					(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( cosh(2.0_kreal * PI * ( xi(2) - xj(2) )) - cos( 2.0_kreal * PI * (xi(1) - xj(1)))) / &
					(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

subroutine resetPeriodicBoundsArray( x )
	real(kreal), dimension(:), intent(inout) :: x
	!
	integer(kint) :: i

	do i = 1, size(x)
		if ( x(i) < 0.0_kreal ) then
			x(i) = x(i) + 1.0_kreal
		endif
		if ( x(i) > 1.0_kreal ) then
			x(i) = x(i) - 1.0_kreal
		endif
	enddo
end subroutine

subroutine resetPeriodicBoundsMesh( self )
	type(BetaPlaneMesh), intent(inout) :: self
	!
	integer(kint) :: i

	do i = 1, self%mesh%particles%N
		if ( self%mesh%particles%x(i) < 0.0_kreal ) then
			self%mesh%particles%x(i) = self%mesh%particles%x(i) + 1.0_kreal
		endif
		if ( self%mesh%particles%x(i) > 1.0_kreal ) then
			self%mesh%particles%x(i) = self%mesh%particles%x(i) - 1.0_kreal
		endif
	enddo
end subroutine

!
!----------------
! private methods
!----------------
!
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


      program main

c*********************************************************************72
c
cc MAIN is the main program for BLAS2_C_PRB.
c
c  Discussion:
c
c    BLAS2_C_PRB tests the BLAS library.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 January 2014
c
c  Author:
c
c    Sourangshu Ghosh
c
c  License:
c
c  Released under MIT License by Sourangshu Ghosh
c
      implicit none

      call timestamp ( )
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BLAS2_C_PRB'
      write ( *, '(a)' ) '  FORTRAN77 version'
      write ( *, '(a)' ) '  Test the BLAS library.'

      call test01 ( )
c
c  Terminate.
c
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BLAS2_C_PRB'
      write ( *, '(a)' ) '  Normal end of execution.'
      write ( *, '(a)' ) ' '
      call timestamp ( )

      stop
      end
      subroutine test01 ( )

c*********************************************************************72
c
cc TEST01 tests CGEMV.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 January 2014
c
c  Author:
c
c    Sourangshu Ghosh
c
c  License:
c
c  Released under MIT License by Sourangshu Ghosh
c
      implicit none

      integer m
      parameter ( m = 5 )
      integer n
      parameter ( n = 5 )

      complex a(m,n)
      complex alpha
      complex beta
      integer i
      integer incx
      integer incy
      integer j
      integer lda
      character trans
      complex x(n)
      real x1
      real x2
      complex y(m)

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST01'
      write ( *, '(a)' ) '  For a general matrix A,'
      write ( *, '(a)' )
     &  '  CGEMV computes y := alpha * A * x + beta * y'

      trans = 'N'
      alpha = ( 10.0E+00, 1.0E+00 )
      lda = m
      incx = 1
      beta = 3.0E+00
      incy = 1

      do i = 1, m
        do j = 1, n
          if ( i .eq. j ) then
            a(i,j) = ( 2.0E+00, 0.0E+00 )
          else if ( i .eq. j - 1 .or. i .eq. j + 1 ) then
            a(i,j) = ( -1.0E+00, 0.0E+00 )
          else
            a(i,j) = ( 0.0E+00, 0.0E+00 )
          end if
        end do
      end do

      x1 = 0.0E+00
      x2 = real ( n )
      do i = 1, n
        x(i) = cmplx ( x1, x2 )
        x1 = x1 + 1.0E+00
        x2 = x2 - 2.0E+00
      end do

      do i = 1, m
        y(i) = ( 100.0E+00, 1.0E+00 )
      end do

      call cgemv ( trans, m, n, alpha, a, lda, x, incx, beta, y, incy )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Result vector Y = '
      write ( *, '(a)' ) ' '

      do i = 1, m
        write ( *, '(2x,2g14.6)' ) y(i)
      end do

      return
      end


!*==dgegv.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief  DGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DGEGV + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI,
!                         BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBVL, JOBVR
!       INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, N
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
!      $                   B( LDB, * ), BETA( * ), VL( LDVL, * ),
!      $                   VR( LDVR, * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> This routine is deprecated and has been replaced by routine DGGEV.
!>
!> DGEGV computes the eigenvalues and, optionally, the left and/or right
!> eigenvectors of a real matrix pair (A,B).
!> Given two square matrices A and B,
!> the generalized nonsymmetric eigenvalue problem (GNEP) is to find the
!> eigenvalues lambda and corresponding (non-zero) eigenvectors x such
!> that
!>
!>    A*x = lambda*B*x.
!>
!> An alternate form is to find the eigenvalues mu and corresponding
!> eigenvectors y such that
!>
!>    mu*A*y = B*y.
!>
!> These two forms are equivalent with mu = 1/lambda and x = y if
!> neither lambda nor mu is zero.  In order to deal with the case that
!> lambda or mu is zero or small, two values alpha and beta are returned
!> for each eigenvalue, such that lambda = alpha/beta and
!> mu = beta/alpha.
!>
!> The vectors x and y in the above equations are right eigenvectors of
!> the matrix pair (A,B).  Vectors u and v satisfying
!>
!>    u**H*A = lambda*u**H*B  or  mu*v**H*A = v**H*B
!>
!> are left eigenvectors of (A,B).
!>
!> Note: this routine performs "full balancing" on A and B
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBVL
!> \verbatim
!>          JOBVL is CHARACTER*1
!>          = 'N':  do not compute the left generalized eigenvectors;
!>          = 'V':  compute the left generalized eigenvectors (returned
!>                  in VL).
!> \endverbatim
!>
!> \param[in] JOBVR
!> \verbatim
!>          JOBVR is CHARACTER*1
!>          = 'N':  do not compute the right generalized eigenvectors;
!>          = 'V':  compute the right generalized eigenvectors (returned
!>                  in VR).
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrices A, B, VL, and VR.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is DOUBLE PRECISION array, dimension (LDA, N)
!>          On entry, the matrix A.
!>          If JOBVL = 'V' or JOBVR = 'V', then on exit A
!>          contains the real Schur form of A from the generalized Schur
!>          factorization of the pair (A,B) after balancing.
!>          If no eigenvectors were computed, then only the diagonal
!>          blocks from the Schur form will be correct.  See DGGHRD and
!>          DHGEQZ for details.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is DOUBLE PRECISION array, dimension (LDB, N)
!>          On entry, the matrix B.
!>          If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the
!>          upper triangular matrix obtained from B in the generalized
!>          Schur factorization of the pair (A,B) after balancing.
!>          If no eigenvectors were computed, then only those elements of
!>          B corresponding to the diagonal blocks from the Schur form of
!>          A will be correct.  See DGGHRD and DHGEQZ for details.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of B.  LDB >= max(1,N).
!> \endverbatim
!>
!> \param[out] ALPHAR
!> \verbatim
!>          ALPHAR is DOUBLE PRECISION array, dimension (N)
!>          The real parts of each scalar alpha defining an eigenvalue of
!>          GNEP.
!> \endverbatim
!>
!> \param[out] ALPHAI
!> \verbatim
!>          ALPHAI is DOUBLE PRECISION array, dimension (N)
!>          The imaginary parts of each scalar alpha defining an
!>          eigenvalue of GNEP.  If ALPHAI(j) is zero, then the j-th
!>          eigenvalue is real; if positive, then the j-th and
!>          (j+1)-st eigenvalues are a complex conjugate pair, with
!>          ALPHAI(j+1) = -ALPHAI(j).
!> \endverbatim
!>
!> \param[out] BETA
!> \verbatim
!>          BETA is DOUBLE PRECISION array, dimension (N)
!>          The scalars beta that define the eigenvalues of GNEP.
!>
!>          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
!>          beta = BETA(j) represent the j-th eigenvalue of the matrix
!>          pair (A,B), in one of the forms lambda = alpha/beta or
!>          mu = beta/alpha.  Since either lambda or mu may overflow,
!>          they should not, in general, be computed.
!> \endverbatim
!>
!> \param[out] VL
!> \verbatim
!>          VL is DOUBLE PRECISION array, dimension (LDVL,N)
!>          If JOBVL = 'V', the left eigenvectors u(j) are stored
!>          in the columns of VL, in the same order as their eigenvalues.
!>          If the j-th eigenvalue is real, then u(j) = VL(:,j).
!>          If the j-th and (j+1)-st eigenvalues form a complex conjugate
!>          pair, then
!>             u(j) = VL(:,j) + i*VL(:,j+1)
!>          and
!>            u(j+1) = VL(:,j) - i*VL(:,j+1).
!>
!>          Each eigenvector is scaled so that its largest component has
!>          abs(real part) + abs(imag. part) = 1, except for eigenvectors
!>          corresponding to an eigenvalue with alpha = beta = 0, which
!>          are set to zero.
!>          Not referenced if JOBVL = 'N'.
!> \endverbatim
!>
!> \param[in] LDVL
!> \verbatim
!>          LDVL is INTEGER
!>          The leading dimension of the matrix VL. LDVL >= 1, and
!>          if JOBVL = 'V', LDVL >= N.
!> \endverbatim
!>
!> \param[out] VR
!> \verbatim
!>          VR is DOUBLE PRECISION array, dimension (LDVR,N)
!>          If JOBVR = 'V', the right eigenvectors x(j) are stored
!>          in the columns of VR, in the same order as their eigenvalues.
!>          If the j-th eigenvalue is real, then x(j) = VR(:,j).
!>          If the j-th and (j+1)-st eigenvalues form a complex conjugate
!>          pair, then
!>            x(j) = VR(:,j) + i*VR(:,j+1)
!>          and
!>            x(j+1) = VR(:,j) - i*VR(:,j+1).
!>
!>          Each eigenvector is scaled so that its largest component has
!>          abs(real part) + abs(imag. part) = 1, except for eigenvalues
!>          corresponding to an eigenvalue with alpha = beta = 0, which
!>          are set to zero.
!>          Not referenced if JOBVR = 'N'.
!> \endverbatim
!>
!> \param[in] LDVR
!> \verbatim
!>          LDVR is INTEGER
!>          The leading dimension of the matrix VR. LDVR >= 1, and
!>          if JOBVR = 'V', LDVR >= N.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,8*N).
!>          For good performance, LWORK must generally be larger.
!>          To compute the optimal value of LWORK, call ILAENV to get
!>          blocksizes (for DGEQRF, DORMQR, and DORGQR.)  Then compute:
!>          NB  -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR;
!>          The optimal LWORK is:
!>              2*N + MAX( 6*N, N*(NB+1) ).
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          = 1,...,N:
!>                The QZ iteration failed.  No eigenvectors have been
!>                calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
!>                should be correct for j=INFO+1,...,N.
!>          > N:  errors that usually indicate LAPACK problems:
!>                =N+1: error return from DGGBAL
!>                =N+2: error return from DGEQRF
!>                =N+3: error return from DORMQR
!>                =N+4: error return from DORGQR
!>                =N+5: error return from DGGHRD
!>                =N+6: error return from DHGEQZ (other than failed
!>                                                iteration)
!>                =N+7: error return from DTGEVC
!>                =N+8: error return from DGGBAK (computing VL)
!>                =N+9: error return from DGGBAK (computing VR)
!>                =N+10: error return from DLASCL (various calls)
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup doubleGEeigen
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Balancing
!>  ---------
!>
!>  This driver calls DGGBAL to both permute and scale rows and columns
!>  of A and B.  The permutations PL and PR are chosen so that PL*A*PR
!>  and PL*B*R will be upper triangular except for the diagonal blocks
!>  A(i:j,i:j) and B(i:j,i:j), with i and j as close together as
!>  possible.  The diagonal scaling matrices DL and DR are chosen so
!>  that the pair  DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to
!>  one (except for the elements that start out zero.)
!>
!>  After the eigenvalues and eigenvectors of the balanced matrices
!>  have been computed, DGGBAK transforms the eigenvectors back to what
!>  they would have been (in perfect arithmetic) if they had not been
!>  balanced.
!>
!>  Contents of A and B on Exit
!>  -------- -- - --- - -- ----
!>
!>  If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or
!>  both), then on exit the arrays A and B will contain the real Schur
!>  form[*] of the "balanced" versions of A and B.  If no eigenvectors
!>  are computed, then only the diagonal blocks will be correct.
!>
!>  [*] See DHGEQZ, DGEGS, or read the book "Matrix Computations",
!>      by Golub & van Loan, pub. by Johns Hopkins U. Press.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE DGEGV(Jobvl,Jobvr,N,A,Lda,B,Ldb,Alphar,Alphai,Beta,Vl, &
     &                 Ldvl,Vr,Ldvr,Work,Lwork,Info)
      IMPLICIT NONE
!*--DGEGV310
!
!  -- LAPACK driver routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Jobvl , Jobvr
      INTEGER Info , Lda , Ldb , Ldvl , Ldvr , Lwork , N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION A(Lda,*) , Alphai(*) , Alphar(*) , B(Ldb,*) ,    &
     &                 Beta(*) , Vl(Ldvl,*) , Vr(Ldvr,*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE
      PARAMETER (ZERO=0.0D0,ONE=1.0D0)
!     ..
!     .. Local Scalars ..
      LOGICAL ilimit , ilv , ilvl , ilvr , lquery
      CHARACTER chtemp
      INTEGER icols , ihi , iinfo , ijobvl , ijobvr , ileft , ilo , in ,&
     &        iright , irows , itau , iwork , jc , jr , lopt , lwkmin , &
     &        lwkopt , nb , nb1 , nb2 , nb3
      DOUBLE PRECISION absai , absar , absb , anrm , anrm1 , anrm2 ,    &
     &                 bnrm , bnrm1 , bnrm2 , eps , onepls , safmax ,   &
     &                 safmin , salfai , salfar , sbeta , scale , temp
!     ..
!     .. Local Arrays ..
      LOGICAL ldumma(1)
!     ..
!     .. External Subroutines ..
      EXTERNAL DGEQRF , DGGBAK , DGGBAL , DGGHRD , DHGEQZ , DLACPY ,    &
     &         DLASCL , DLASET , DORGQR , DORMQR , DTGEVC , XERBLA
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV
      DOUBLE PRECISION DLAMCH , DLANGE
      EXTERNAL LSAME , ILAENV , DLAMCH , DLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , INT , MAX
!     ..
!     .. Executable Statements ..
!
!     Decode the input arguments
!
      IF ( LSAME(Jobvl,'N') ) THEN
         ijobvl = 1
         ilvl = .FALSE.
      ELSEIF ( LSAME(Jobvl,'V') ) THEN
         ijobvl = 2
         ilvl = .TRUE.
      ELSE
         ijobvl = -1
         ilvl = .FALSE.
      ENDIF
!
      IF ( LSAME(Jobvr,'N') ) THEN
         ijobvr = 1
         ilvr = .FALSE.
      ELSEIF ( LSAME(Jobvr,'V') ) THEN
         ijobvr = 2
         ilvr = .TRUE.
      ELSE
         ijobvr = -1
         ilvr = .FALSE.
      ENDIF
      ilv = ilvl .OR. ilvr
!
!     Test the input arguments
!
      lwkmin = MAX(8*N,1)
      lwkopt = lwkmin
      Work(1) = lwkopt
      lquery = (Lwork==-1)
      Info = 0
      IF ( ijobvl<=0 ) THEN
         Info = -1
      ELSEIF ( ijobvr<=0 ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -5
      ELSEIF ( Ldb<MAX(1,N) ) THEN
         Info = -7
      ELSEIF ( Ldvl<1 .OR. (ilvl .AND. Ldvl<N) ) THEN
         Info = -12
      ELSEIF ( Ldvr<1 .OR. (ilvr .AND. Ldvr<N) ) THEN
         Info = -14
      ELSEIF ( Lwork<lwkmin .AND. .NOT.lquery ) THEN
         Info = -16
      ENDIF
!
      IF ( Info==0 ) THEN
         nb1 = ILAENV(1,'DGEQRF',' ',N,N,-1,-1)
         nb2 = ILAENV(1,'DORMQR',' ',N,N,N,-1)
         nb3 = ILAENV(1,'DORGQR',' ',N,N,N,-1)
         nb = MAX(nb1,nb2,nb3)
         lopt = 2*N + MAX(6*N,N*(nb+1))
         Work(1) = lopt
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('DGEGV ',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) RETURN
!
!     Get machine constants
!
      eps = DLAMCH('E')*DLAMCH('B')
      safmin = DLAMCH('S')
      safmin = safmin + safmin
      safmax = ONE/safmin
      onepls = ONE + (4*eps)
!
!     Scale A
!
      anrm = DLANGE('M',N,N,A,Lda,Work)
      anrm1 = anrm
      anrm2 = ONE
      IF ( anrm<ONE ) THEN
         IF ( safmax*anrm<ONE ) THEN
            anrm1 = safmin
            anrm2 = safmax*anrm
         ENDIF
      ENDIF
!
      IF ( anrm>ZERO ) THEN
         CALL DLASCL('G',-1,-1,anrm,ONE,N,N,A,Lda,iinfo)
         IF ( iinfo/=0 ) THEN
            Info = N + 10
            RETURN
         ENDIF
      ENDIF
!
!     Scale B
!
      bnrm = DLANGE('M',N,N,B,Ldb,Work)
      bnrm1 = bnrm
      bnrm2 = ONE
      IF ( bnrm<ONE ) THEN
         IF ( safmax*bnrm<ONE ) THEN
            bnrm1 = safmin
            bnrm2 = safmax*bnrm
         ENDIF
      ENDIF
!
      IF ( bnrm>ZERO ) THEN
         CALL DLASCL('G',-1,-1,bnrm,ONE,N,N,B,Ldb,iinfo)
         IF ( iinfo/=0 ) THEN
            Info = N + 10
            RETURN
         ENDIF
      ENDIF
!
!     Permute the matrix to make it more nearly triangular
!     Workspace layout:  (8*N words -- "work" requires 6*N words)
!        left_permutation, right_permutation, work...
!
      ileft = 1
      iright = N + 1
      iwork = iright + N
      CALL DGGBAL('P',N,A,Lda,B,Ldb,ilo,ihi,Work(ileft),Work(iright),   &
     &            Work(iwork),iinfo)
      IF ( iinfo/=0 ) THEN
         Info = N + 1
         GOTO 100
      ENDIF
!
!     Reduce B to triangular form, and initialize VL and/or VR
!     Workspace layout:  ("work..." must have at least N words)
!        left_permutation, right_permutation, tau, work...
!
      irows = ihi + 1 - ilo
      IF ( ilv ) THEN
         icols = N + 1 - ilo
      ELSE
         icols = irows
      ENDIF
      itau = iwork
      iwork = itau + irows
      CALL DGEQRF(irows,icols,B(ilo,ilo),Ldb,Work(itau),Work(iwork),    &
     &            Lwork+1-iwork,iinfo)
      IF ( iinfo>=0 ) lwkopt = MAX(lwkopt,INT(Work(iwork))+iwork-1)
      IF ( iinfo/=0 ) THEN
         Info = N + 2
         GOTO 100
      ENDIF
!
      CALL DORMQR('L','T',irows,icols,irows,B(ilo,ilo),Ldb,Work(itau),  &
     &            A(ilo,ilo),Lda,Work(iwork),Lwork+1-iwork,iinfo)
      IF ( iinfo>=0 ) lwkopt = MAX(lwkopt,INT(Work(iwork))+iwork-1)
      IF ( iinfo/=0 ) THEN
         Info = N + 3
         GOTO 100
      ENDIF
!
      IF ( ilvl ) THEN
         CALL DLASET('Full',N,N,ZERO,ONE,Vl,Ldvl)
         CALL DLACPY('L',irows-1,irows-1,B(ilo+1,ilo),Ldb,Vl(ilo+1,ilo),&
     &               Ldvl)
         CALL DORGQR(irows,irows,irows,Vl(ilo,ilo),Ldvl,Work(itau),     &
     &               Work(iwork),Lwork+1-iwork,iinfo)
         IF ( iinfo>=0 ) lwkopt = MAX(lwkopt,INT(Work(iwork))+iwork-1)
         IF ( iinfo/=0 ) THEN
            Info = N + 4
            GOTO 100
         ENDIF
      ENDIF
!
      IF ( ilvr ) CALL DLASET('Full',N,N,ZERO,ONE,Vr,Ldvr)
!
!     Reduce to generalized Hessenberg form
!
      IF ( ilv ) THEN
!
!        Eigenvectors requested -- work on whole matrix.
!
         CALL DGGHRD(Jobvl,Jobvr,N,ilo,ihi,A,Lda,B,Ldb,Vl,Ldvl,Vr,Ldvr, &
     &               iinfo)
      ELSE
         CALL DGGHRD('N','N',irows,1,irows,A(ilo,ilo),Lda,B(ilo,ilo),   &
     &               Ldb,Vl,Ldvl,Vr,Ldvr,iinfo)
      ENDIF
      IF ( iinfo/=0 ) THEN
         Info = N + 5
         GOTO 100
      ENDIF
!
!     Perform QZ algorithm
!     Workspace layout:  ("work..." must have at least 1 word)
!        left_permutation, right_permutation, work...
!
      iwork = itau
      IF ( ilv ) THEN
         chtemp = 'S'
      ELSE
         chtemp = 'E'
      ENDIF
      CALL DHGEQZ(chtemp,Jobvl,Jobvr,N,ilo,ihi,A,Lda,B,Ldb,Alphar,      &
     &            Alphai,Beta,Vl,Ldvl,Vr,Ldvr,Work(iwork),Lwork+1-iwork,&
     &            iinfo)
      IF ( iinfo>=0 ) lwkopt = MAX(lwkopt,INT(Work(iwork))+iwork-1)
      IF ( iinfo/=0 ) THEN
         IF ( iinfo>0 .AND. iinfo<=N ) THEN
            Info = iinfo
         ELSEIF ( iinfo>N .AND. iinfo<=2*N ) THEN
            Info = iinfo - N
         ELSE
            Info = N + 6
         ENDIF
         GOTO 100
      ENDIF
!
      IF ( ilv ) THEN
!
!        Compute Eigenvectors  (DTGEVC requires 6*N words of workspace)
!
         IF ( .NOT.(ilvl) ) THEN
            chtemp = 'R'
         ELSEIF ( ilvr ) THEN
            chtemp = 'B'
         ELSE
            chtemp = 'L'
         ENDIF
!
         CALL DTGEVC(chtemp,'B',ldumma,N,A,Lda,B,Ldb,Vl,Ldvl,Vr,Ldvr,N, &
     &               in,Work(iwork),iinfo)
         IF ( iinfo/=0 ) THEN
            Info = N + 7
            GOTO 100
         ENDIF
!
!        Undo balancing on VL and VR, rescale
!
         IF ( ilvl ) THEN
            CALL DGGBAK('P','L',N,ilo,ihi,Work(ileft),Work(iright),N,Vl,&
     &                  Ldvl,iinfo)
            IF ( iinfo/=0 ) THEN
               Info = N + 8
               GOTO 100
            ENDIF
            DO jc = 1 , N
               IF ( Alphai(jc)>=ZERO ) THEN
                  temp = ZERO
                  IF ( Alphai(jc)==ZERO ) THEN
                     DO jr = 1 , N
                        temp = MAX(temp,ABS(Vl(jr,jc)))
                     ENDDO
                  ELSE
                     DO jr = 1 , N
                        temp = MAX(temp,ABS(Vl(jr,jc))+ABS(Vl(jr,jc+1)))
                     ENDDO
                  ENDIF
                  IF ( temp>=safmin ) THEN
                     temp = ONE/temp
                     IF ( Alphai(jc)==ZERO ) THEN
                        DO jr = 1 , N
                           Vl(jr,jc) = Vl(jr,jc)*temp
                        ENDDO
                     ELSE
                        DO jr = 1 , N
                           Vl(jr,jc) = Vl(jr,jc)*temp
                           Vl(jr,jc+1) = Vl(jr,jc+1)*temp
                        ENDDO
                     ENDIF
                  ENDIF
               ENDIF
            ENDDO
         ENDIF
         IF ( ilvr ) THEN
            CALL DGGBAK('P','R',N,ilo,ihi,Work(ileft),Work(iright),N,Vr,&
     &                  Ldvr,iinfo)
            IF ( iinfo/=0 ) THEN
               Info = N + 9
               GOTO 100
            ENDIF
            DO jc = 1 , N
               IF ( Alphai(jc)>=ZERO ) THEN
                  temp = ZERO
                  IF ( Alphai(jc)==ZERO ) THEN
                     DO jr = 1 , N
                        temp = MAX(temp,ABS(Vr(jr,jc)))
                     ENDDO
                  ELSE
                     DO jr = 1 , N
                        temp = MAX(temp,ABS(Vr(jr,jc))+ABS(Vr(jr,jc+1)))
                     ENDDO
                  ENDIF
                  IF ( temp>=safmin ) THEN
                     temp = ONE/temp
                     IF ( Alphai(jc)==ZERO ) THEN
                        DO jr = 1 , N
                           Vr(jr,jc) = Vr(jr,jc)*temp
                        ENDDO
                     ELSE
                        DO jr = 1 , N
                           Vr(jr,jc) = Vr(jr,jc)*temp
                           Vr(jr,jc+1) = Vr(jr,jc+1)*temp
                        ENDDO
                     ENDIF
                  ENDIF
               ENDIF
            ENDDO
         ENDIF
!
!        End of eigenvector calculation
!
      ENDIF
!
!     Undo scaling in alpha, beta
!
!     Note: this does not give the alpha and beta for the unscaled
!     problem.
!
!     Un-scaling is limited to avoid underflow in alpha and beta
!     if they are significant.
!
      DO jc = 1 , N
         absar = ABS(Alphar(jc))
         absai = ABS(Alphai(jc))
         absb = ABS(Beta(jc))
         salfar = anrm*Alphar(jc)
         salfai = anrm*Alphai(jc)
         sbeta = bnrm*Beta(jc)
         ilimit = .FALSE.
         scale = ONE
!
!        Check for significant underflow in ALPHAI
!
         IF ( ABS(salfai)<safmin .AND.                                  &
     &        absai>=MAX(safmin,eps*absar,eps*absb) ) THEN
            ilimit = .TRUE.
            scale = (onepls*safmin/anrm1)/MAX(onepls*safmin,anrm2*absai)
!
         ELSEIF ( salfai==ZERO ) THEN
!
!           If insignificant underflow in ALPHAI, then make the
!           conjugate eigenvalue real.
!
            IF ( Alphai(jc)<ZERO .AND. jc>1 ) THEN
               Alphai(jc-1) = ZERO
            ELSEIF ( Alphai(jc)>ZERO .AND. jc<N ) THEN
               Alphai(jc+1) = ZERO
            ENDIF
         ENDIF
!
!        Check for significant underflow in ALPHAR
!
         IF ( ABS(salfar)<safmin .AND.                                  &
     &        absar>=MAX(safmin,eps*absai,eps*absb) ) THEN
            ilimit = .TRUE.
            scale = MAX(scale,(onepls*safmin/anrm1)                     &
     &              /MAX(onepls*safmin,anrm2*absar))
         ENDIF
!
!        Check for significant underflow in BETA
!
         IF ( ABS(sbeta)<safmin .AND.                                   &
     &        absb>=MAX(safmin,eps*absar,eps*absai) ) THEN
            ilimit = .TRUE.
            scale = MAX(scale,(onepls*safmin/bnrm1)                     &
     &              /MAX(onepls*safmin,bnrm2*absb))
         ENDIF
!
!        Check for possible overflow when limiting scaling
!
         IF ( ilimit ) THEN
            temp = (scale*safmin)                                       &
     &             *MAX(ABS(salfar),ABS(salfai),ABS(sbeta))
            IF ( temp>ONE ) scale = scale/temp
            IF ( scale<ONE ) ilimit = .FALSE.
         ENDIF
!
!        Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary.
!
         IF ( ilimit ) THEN
            salfar = (scale*Alphar(jc))*anrm
            salfai = (scale*Alphai(jc))*anrm
            sbeta = (scale*Beta(jc))*bnrm
         ENDIF
         Alphar(jc) = salfar
         Alphai(jc) = salfai
         Beta(jc) = sbeta
      ENDDO
!
 100  Work(1) = lwkopt
!
!
!     End of DGEGV
!
      END SUBROUTINE DGEGV


      SUBROUTINE DTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
     $                   LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK,
     $                   INFO )
*
*  -- LAPACK routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
*
*     .. Scalar Arguments ..
      CHARACTER          HOWMNY, JOB
      INTEGER            INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N
*     ..
*     .. Array Arguments ..
      LOGICAL            SELECT( * )
      INTEGER            IWORK( * )
      DOUBLE PRECISION   S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ),
     $                   VR( LDVR, * ), WORK( LDWORK, * )
*     ..
*
*  Purpose
*  =======
*
*  DTRSNA estimates reciprocal condition numbers for specified
*  eigenvalues and/or right eigenvectors of a real upper
*  quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q
*  orthogonal).
*
*  T must be in Schur canonical form (as returned by DHSEQR), that is,
*  block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
*  2-by-2 diagonal block has its diagonal elements equal and its
*  off-diagonal elements of opposite sign.
*
*  Arguments
*  =========
*
*  JOB     (input) CHARACTER*1
*          Specifies whether condition numbers are required for
*          eigenvalues (S) or eigenvectors (SEP):
*          = 'E': for eigenvalues only (S);
*          = 'V': for eigenvectors only (SEP);
*          = 'B': for both eigenvalues and eigenvectors (S and SEP).
*
*  HOWMNY  (input) CHARACTER*1
*          = 'A': compute condition numbers for all eigenpairs;
*          = 'S': compute condition numbers for selected eigenpairs
*                 specified by the array SELECT.
*
*  SELECT  (input) LOGICAL array, dimension (N)
*          If HOWMNY = 'S', SELECT specifies the eigenpairs for which
*          condition numbers are required. To select condition numbers
*          for the eigenpair corresponding to a real eigenvalue w(j),
*          SELECT(j) must be set to .TRUE.. To select condition numbers
*          corresponding to a complex conjugate pair of eigenvalues w(j)
*          and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
*          set to .TRUE..
*          If HOWMNY = 'A', SELECT is not referenced.
*
*  N       (input) INTEGER
*          The order of the matrix T. N >= 0.
*
*  T       (input) DOUBLE PRECISION array, dimension (LDT,N)
*          The upper quasi-triangular matrix T, in Schur canonical form.
*
*  LDT     (input) INTEGER
*          The leading dimension of the array T. LDT >= max(1,N).
*
*  VL      (input) DOUBLE PRECISION array, dimension (LDVL,M)
*          If JOB = 'E' or 'B', VL must contain left eigenvectors of T
*          (or of any Q*T*Q**T with Q orthogonal), corresponding to the
*          eigenpairs specified by HOWMNY and SELECT. The eigenvectors
*          must be stored in consecutive columns of VL, as returned by
*          DHSEIN or DTREVC.
*          If JOB = 'V', VL is not referenced.
*
*  LDVL    (input) INTEGER
*          The leading dimension of the array VL.
*          LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
*
*  VR      (input) DOUBLE PRECISION array, dimension (LDVR,M)
*          If JOB = 'E' or 'B', VR must contain right eigenvectors of T
*          (or of any Q*T*Q**T with Q orthogonal), corresponding to the
*          eigenpairs specified by HOWMNY and SELECT. The eigenvectors
*          must be stored in consecutive columns of VR, as returned by
*          DHSEIN or DTREVC.
*          If JOB = 'V', VR is not referenced.
*
*  LDVR    (input) INTEGER
*          The leading dimension of the array VR.
*          LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
*
*  S       (output) DOUBLE PRECISION array, dimension (MM)
*          If JOB = 'E' or 'B', the reciprocal condition numbers of the
*          selected eigenvalues, stored in consecutive elements of the
*          array. For a complex conjugate pair of eigenvalues two
*          consecutive elements of S are set to the same value. Thus
*          S(j), SEP(j), and the j-th columns of VL and VR all
*          correspond to the same eigenpair (but not in general the
*          j-th eigenpair, unless all eigenpairs are selected).
*          If JOB = 'V', S is not referenced.
*
*  SEP     (output) DOUBLE PRECISION array, dimension (MM)
*          If JOB = 'V' or 'B', the estimated reciprocal condition
*          numbers of the selected eigenvectors, stored in consecutive
*          elements of the array. For a complex eigenvector two
*          consecutive elements of SEP are set to the same value. If
*          the eigenvalues cannot be reordered to compute SEP(j), SEP(j)
*          is set to 0; this can only occur when the true value would be
*          very small anyway.
*          If JOB = 'E', SEP is not referenced.
*
*  MM      (input) INTEGER
*          The number of elements in the arrays S (if JOB = 'E' or 'B')
*           and/or SEP (if JOB = 'V' or 'B'). MM >= M.
*
*  M       (output) INTEGER
*          The number of elements of the arrays S and/or SEP actually
*          used to store the estimated condition numbers.
*          If HOWMNY = 'A', M is set to N.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+6)
*          If JOB = 'E', WORK is not referenced.
*
*  LDWORK  (input) INTEGER
*          The leading dimension of the array WORK.
*          LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
*
*  IWORK   (workspace) INTEGER array, dimension (2*(N-1))
*          If JOB = 'E', IWORK is not referenced.
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value
*
*  Further Details
*  ===============
*
*  The reciprocal of the condition number of an eigenvalue lambda is
*  defined as
*
*          S(lambda) = |v'*u| / (norm(u)*norm(v))
*
*  where u and v are the right and left eigenvectors of T corresponding
*  to lambda; v' denotes the conjugate-transpose of v, and norm(u)
*  denotes the Euclidean norm. These reciprocal condition numbers always
*  lie between zero (very badly conditioned) and one (very well
*  conditioned). If n = 1, S(lambda) is defined to be 1.
*
*  An approximate error bound for a computed eigenvalue W(i) is given by
*
*                      EPS * norm(T) / S(i)
*
*  where EPS is the machine precision.
*
*  The reciprocal of the condition number of the right eigenvector u
*  corresponding to lambda is defined as follows. Suppose
*
*              T = ( lambda  c  )
*                  (   0    T22 )
*
*  Then the reciprocal condition number is
*
*          SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
*
*  where sigma-min denotes the smallest singular value. We approximate
*  the smallest singular value by the reciprocal of an estimate of the
*  one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
*  defined to be abs(T(1,1)).
*
*  An approximate error bound for a computed right eigenvector VR(i)
*  is given by
*
*                      EPS * norm(T) / SEP(i)
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            PAIR, SOMCON, WANTBH, WANTS, WANTSP
      INTEGER            I, IERR, IFST, ILST, J, K, KASE, KS, N2, NN
      DOUBLE PRECISION   BIGNUM, COND, CS, DELTA, DUMM, EPS, EST, LNRM,
     $                   MU, PROD, PROD1, PROD2, RNRM, SCALE, SMLNUM, SN
*     ..
*     .. Local Arrays ..
      INTEGER            ISAVE( 3 )
      DOUBLE PRECISION   DUMMY( 1 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT, DLAMCH, DLAPY2, DNRM2
      EXTERNAL           LSAME, DDOT, DLAMCH, DLAPY2, DNRM2
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLACN2, DLACPY, DLAQTR, DTREXC, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
*     ..
*     .. Executable Statements ..
*
*     Decode and test the input parameters
*
      WANTBH = LSAME( JOB, 'B' )
      WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
      WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
*
      SOMCON = LSAME( HOWMNY, 'S' )
*
      INFO = 0
      IF( .NOT.WANTS .AND. .NOT.WANTSP ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDVL.LT.1 .OR. ( WANTS .AND. LDVL.LT.N ) ) THEN
         INFO = -8
      ELSE IF( LDVR.LT.1 .OR. ( WANTS .AND. LDVR.LT.N ) ) THEN
         INFO = -10
      ELSE
*
*        Set M to the number of eigenpairs for which condition numbers
*        are required, and test MM.
*
         IF( SOMCON ) THEN
            M = 0
            PAIR = .FALSE.
            DO 10 K = 1, N
               IF( PAIR ) THEN
                  PAIR = .FALSE.
               ELSE
                  IF( K.LT.N ) THEN
                     IF( T( K+1, K ).EQ.ZERO ) THEN
                        IF( SELECT( K ) )
     $                     M = M + 1
                     ELSE
                        PAIR = .TRUE.
                        IF( SELECT( K ) .OR. SELECT( K+1 ) )
     $                     M = M + 2
                     END IF
                  ELSE
                     IF( SELECT( N ) )
     $                  M = M + 1
                  END IF
               END IF
   10       CONTINUE
         ELSE
            M = N
         END IF
*
         IF( MM.LT.M ) THEN
            INFO = -13
         ELSE IF( LDWORK.LT.1 .OR. ( WANTSP .AND. LDWORK.LT.N ) ) THEN
            INFO = -16
         END IF
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRSNA', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
      IF( N.EQ.1 ) THEN
         IF( SOMCON ) THEN
            IF( .NOT.SELECT( 1 ) )
     $         RETURN
         END IF
         IF( WANTS )
     $      S( 1 ) = ONE
         IF( WANTSP )
     $      SEP( 1 ) = ABS( T( 1, 1 ) )
         RETURN
      END IF
*
*     Get machine constants
*
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' ) / EPS
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
*
      KS = 0
      PAIR = .FALSE.
      DO 60 K = 1, N
*
*        Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block.
*
         IF( PAIR ) THEN
            PAIR = .FALSE.
            GO TO 60
         ELSE
            IF( K.LT.N )
     $         PAIR = T( K+1, K ).NE.ZERO
         END IF
*
*        Determine whether condition numbers are required for the k-th
*        eigenpair.
*
         IF( SOMCON ) THEN
            IF( PAIR ) THEN
               IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) )
     $            GO TO 60
            ELSE
               IF( .NOT.SELECT( K ) )
     $            GO TO 60
            END IF
         END IF
*
         KS = KS + 1
*
         IF( WANTS ) THEN
*
*           Compute the reciprocal condition number of the k-th
*           eigenvalue.
*
            IF( .NOT.PAIR ) THEN
*
*              Real eigenvalue.
*
               PROD = DDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 )
               RNRM = DNRM2( N, VR( 1, KS ), 1 )
               LNRM = DNRM2( N, VL( 1, KS ), 1 )
               S( KS ) = ABS( PROD ) / ( RNRM*LNRM )
            ELSE
*
*              Complex eigenvalue.
*
               PROD1 = DDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 )
               PROD1 = PROD1 + DDOT( N, VR( 1, KS+1 ), 1, VL( 1, KS+1 ),
     $                 1 )
               PROD2 = DDOT( N, VL( 1, KS ), 1, VR( 1, KS+1 ), 1 )
               PROD2 = PROD2 - DDOT( N, VL( 1, KS+1 ), 1, VR( 1, KS ),
     $                 1 )
               RNRM = DLAPY2( DNRM2( N, VR( 1, KS ), 1 ),
     $                DNRM2( N, VR( 1, KS+1 ), 1 ) )
               LNRM = DLAPY2( DNRM2( N, VL( 1, KS ), 1 ),
     $                DNRM2( N, VL( 1, KS+1 ), 1 ) )
               COND = DLAPY2( PROD1, PROD2 ) / ( RNRM*LNRM )
               S( KS ) = COND
               S( KS+1 ) = COND
            END IF
         END IF
*
         IF( WANTSP ) THEN
*
*           Estimate the reciprocal condition number of the k-th
*           eigenvector.
*
*           Copy the matrix T to the array WORK and swap the diagonal
*           block beginning at T(k,k) to the (1,1) position.
*
            CALL DLACPY( 'Full', N, N, T, LDT, WORK, LDWORK )
            IFST = K
            ILST = 1
            CALL DTREXC( 'No Q', N, WORK, LDWORK, DUMMY, 1, IFST, ILST,
     $                   WORK( 1, N+1 ), IERR )
*
            IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN
*
*              Could not swap because blocks not well separated
*
               SCALE = ONE
               EST = BIGNUM
            ELSE
*
*              Reordering successful
*
               IF( WORK( 2, 1 ).EQ.ZERO ) THEN
*
*                 Form C = T22 - lambda*I in WORK(2:N,2:N).
*
                  DO 20 I = 2, N
                     WORK( I, I ) = WORK( I, I ) - WORK( 1, 1 )
   20             CONTINUE
                  N2 = 1
                  NN = N - 1
               ELSE
*
*                 Triangularize the 2 by 2 block by unitary
*                 transformation U = [  cs   i*ss ]
*                                    [ i*ss   cs  ].
*                 such that the (1,1) position of WORK is complex
*                 eigenvalue lambda with positive imaginary part. (2,2)
*                 position of WORK is the complex eigenvalue lambda
*                 with negative imaginary  part.
*
                  MU = SQRT( ABS( WORK( 1, 2 ) ) )*
     $                 SQRT( ABS( WORK( 2, 1 ) ) )
                  DELTA = DLAPY2( MU, WORK( 2, 1 ) )
                  CS = MU / DELTA
                  SN = -WORK( 2, 1 ) / DELTA
*
*                 Form
*
*                 C' = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ]
*                                        [   mu                     ]
*                                        [         ..               ]
*                                        [             ..           ]
*                                        [                  mu      ]
*                 where C' is conjugate transpose of complex matrix C,
*                 and RWORK is stored starting in the N+1-st column of
*                 WORK.
*
                  DO 30 J = 3, N
                     WORK( 2, J ) = CS*WORK( 2, J )
                     WORK( J, J ) = WORK( J, J ) - WORK( 1, 1 )
   30             CONTINUE
                  WORK( 2, 2 ) = ZERO
*
                  WORK( 1, N+1 ) = TWO*MU
                  DO 40 I = 2, N - 1
                     WORK( I, N+1 ) = SN*WORK( 1, I+1 )
   40             CONTINUE
                  N2 = 2
                  NN = 2*( N-1 )
               END IF
*
*              Estimate norm(inv(C'))
*
               EST = ZERO
               KASE = 0
   50          CONTINUE
               CALL DLACN2( NN, WORK( 1, N+2 ), WORK( 1, N+4 ), IWORK,
     $                      EST, KASE, ISAVE )
               IF( KASE.NE.0 ) THEN
                  IF( KASE.EQ.1 ) THEN
                     IF( N2.EQ.1 ) THEN
*
*                       Real eigenvalue: solve C'*x = scale*c.
*
                        CALL DLAQTR( .TRUE., .TRUE., N-1, WORK( 2, 2 ),
     $                               LDWORK, DUMMY, DUMM, SCALE,
     $                               WORK( 1, N+4 ), WORK( 1, N+6 ),
     $                               IERR )
                     ELSE
*
*                       Complex eigenvalue: solve
*                       C'*(p+iq) = scale*(c+id) in real arithmetic.
*
                        CALL DLAQTR( .TRUE., .FALSE., N-1, WORK( 2, 2 ),
     $                               LDWORK, WORK( 1, N+1 ), MU, SCALE,
     $                               WORK( 1, N+4 ), WORK( 1, N+6 ),
     $                               IERR )
                     END IF
                  ELSE
                     IF( N2.EQ.1 ) THEN
*
*                       Real eigenvalue: solve C*x = scale*c.
*
                        CALL DLAQTR( .FALSE., .TRUE., N-1, WORK( 2, 2 ),
     $                               LDWORK, DUMMY, DUMM, SCALE,
     $                               WORK( 1, N+4 ), WORK( 1, N+6 ),
     $                               IERR )
                     ELSE
*
*                       Complex eigenvalue: solve
*                       C*(p+iq) = scale*(c+id) in real arithmetic.
*
                        CALL DLAQTR( .FALSE., .FALSE., N-1,
     $                               WORK( 2, 2 ), LDWORK,
     $                               WORK( 1, N+1 ), MU, SCALE,
     $                               WORK( 1, N+4 ), WORK( 1, N+6 ),
     $                               IERR )
*
                     END IF
                  END IF
*
                  GO TO 50
               END IF
            END IF
*
            SEP( KS ) = SCALE / MAX( EST, SMLNUM )
            IF( PAIR )
     $         SEP( KS+1 ) = SEP( KS )
         END IF
*
         IF( PAIR )
     $      KS = KS + 1
*
   60 CONTINUE
      RETURN
*
*     End of DTRSNA
*
      END


C> @file intpdiff.f interpolation and differentiation routines not already provided
C> by nek5000
!--------------------------------------------------------------------
! JH061914 propose name change to intpdiff since that is what is in
!          here.
! JH081816 went to local_grad. redimensioned gradu. wish I could use
!          gradm11, but stride
!--------------------------------------------------------------------

      subroutine compute_gradients(e)
      include 'SIZE'
      include 'INPUT'
      include 'DXYZ'
      include 'GEOM'
      include 'SOLN'
      include 'CMTDATA'
      parameter (ldd=lxd*lyd*lzd)
      common /ctmp1/ ur(ldd),us(ldd),ut(ldd),ud(ldd),tu(ldd)

      integer eq,e

!     !  Compute d/dx, d/dy and d/dz of all the cons vars

      nxy1  = lx1*ly1
      nyz1  = ly1*lz1
      nxyz1 = lx1*ly1*lz1
      m0 = lx1-1

      do eq=1,toteq
         call invcol3(ud,u(1,1,1,eq,e),phig(1,1,1,e),nxyz1)

         if (if3d) then
            call local_grad3(ur,us,ut,ud,m0,1,dxm1,dxtm1)
            do i=1,nxyz1
               gradu(i,eq,1) = jacmi(i,e)*(rxm1(i,1,1,e)*ur(i)+
     >                                     sxm1(i,1,1,e)*us(i)+
     >                                     txm1(i,1,1,e)*ut(i))
            enddo
            do i=1,nxyz1
               gradu(i,eq,2) = jacmi(i,e)*(rym1(i,1,1,e)*ur(i)+
     >                                     sym1(i,1,1,e)*us(i)+
     >                                     tym1(i,1,1,e)*ut(i))
            enddo
            do i=1,nxyz1
               gradu(i,eq,3) = jacmi(i,e)*(rzm1(i,1,1,e)*ur(i)+
     >                                     szm1(i,1,1,e)*us(i)+
     >                                     tzm1(i,1,1,e)*ut(i))
            enddo

         else

            call local_grad2(ur,us   ,ud,m0,1,dxm1,dxtm1)
            do i=1,nxyz1
               gradu(i,eq,1) = jacmi(i,e)*(rxm1(i,1,1,e)*ur(i)+
     >                                     sxm1(i,1,1,e)*us(i))
            enddo
            do i=1,nxyz1
               gradu(i,eq,2) = jacmi(i,e)*(rym1(i,1,1,e)*ur(i)+
     >                                     sym1(i,1,1,e)*us(i))
            enddo

         endif

      enddo ! equation loop

      return
      end

!-----------------------------------------------------------------------

      subroutine set_dealias_face

!-----------------------------------------------------------------------
! JH111815 needed for face Jacobian and surface integrals
!-----------------------------------------------------------------------

      include 'SIZE'
      include 'INPUT' ! for if3d
      include 'GEOM'  ! for ifgeom
      include 'TSTEP' ! for istep
      include 'WZ'    ! for wxm1
      include 'DG'    ! for facewz

      integer ilstep
      save    ilstep
      data    ilstep /-1/

      if (.not.ifgeom.and.ilstep.gt.1) return  ! already computed
      if (ifgeom.and.ilstep.eq.istep)  return  ! already computed
      ilstep = istep

      call zwgl(zptf,wgtf,lxd)

      if (if3d) then
         k=0
         do j=1,ly1
         do i=1,lx1
            k=k+1
            wghtc(k)=wxm1(i)*wzm1(j)
         enddo
         enddo
         k=0
         do j=1,lyd
         do i=1,lxd
            k=k+1
            wghtf(k)=wgtf(i)*wgtf(j)
         enddo
         enddo
      else
         call copy(wghtc,wxm1,lx1)
         call copy(wghtf,wgtf,lxd)
      endif

      return
      end
!-----------------------------------------------------------------------

      subroutine set_alias_rx(istp)
! note that set_alias_rx will be called only when lxd = lx1
      include 'SIZE'
      include 'INPUT'
      include 'GEOM'
c     include 'TSTEP' ! for istep

      common /dealias1/ zd(lx1),wd(lx1)
      integer e

      integer ilsp
      save    ilsp
      data    ilsp /-1/

      if (.not.ifgeom.and.ilsp.gt.1) return  ! already computed
      if (ifgeom.and.ilsp.eq.istp)  return  ! already computed
      ilsp = istp
      nxyz = lx1*ly1*lz1
      call zwgll (zd,wd,lx1)

      if (if3d)then
         do e=1,nelv

            call copy(rx(1,1,e),rxm1(1,1,1,e),nxyz)
            call copy(rx(1,2,e),rym1(1,1,1,e),nxyz)
            call copy(rx(1,3,e),rzm1(1,1,1,e),nxyz)
            call copy(rx(1,4,e),sxm1(1,1,1,e),nxyz)
            call copy(rx(1,5,e),sym1(1,1,1,e),nxyz)
            call copy(rx(1,6,e),szm1(1,1,1,e),nxyz)
            call copy(rx(1,7,e),txm1(1,1,1,e),nxyz)
            call copy(rx(1,8,e),tym1(1,1,1,e),nxyz)
            call copy(rx(1,9,e),tzm1(1,1,1,e),nxyz)

            l = 0
            do k=1,lz1
            do j=1,ly1
            do i=1,lx1
               l = l+1
               w = wd(i)*wd(j)*wd(k)
               do ii=1,9
                  rx(l,ii,e) = w*rx(l,ii,e)
               enddo
            enddo
            enddo
            enddo
            enddo
      else

         do e=1,nelv

c           Interpolate z+ and z- into fine mesh, translate to r-s-t coords

            call copy(rx(1,1,e),rxm1(1,1,1,e),nxyz)
            call copy(rx(1,2,e),rym1(1,1,1,e),nxyz)
            call copy(rx(1,3,e),sxm1(1,1,1,e),nxyz)
            call copy(rx(1,4,e),sym1(1,1,1,e),nxyz)

            l = 0
            do j=1,ly1
            do i=1,lx1
               l = l+1
               w = wd(i)*wd(j)
               do ii=1,4
                  rx(l,ii,e) = w*rx(l,ii,e)
               enddo
            enddo
            enddo
         enddo

      endif

      return
      end

!-----------------------------------------------------------------------

      subroutine gradm11_t(grad,uxyz,csgn,e) ! grad is incremented, not overwritten
c     source: . gradm1, from navier5.f
c             . gradm1, from navier5.f
c     Compute divergence^T of ux,uy,uz -- mesh 1 to mesh 1 (vel. to vel.)
!     single element, but references jacmi and the metrics

      include 'SIZE'
      include 'DXYZ'
      include 'GEOM'
      include 'INPUT'

      parameter (lxyz=lx1*ly1*lz1)
      real grad(lxyz),uxyz(lxyz,ldim)

      common /ctmp1/ ur(lxyz),us(lxyz),ut(lxyz),ud(lxyz),tmp(lxyz)
      real ur,us,ut,tmp

      integer e

      nxyz = lx1*ly1*lz1
      call rzero(ud,nxyz)

      N = lx1-1
      if (if3d) then

         do i=1,lxyz
            ur(i) = jacmi(i,e)*(uxyz(i,1)*rxm1(i,1,1,e)
     >                        + uxyz(i,2)*rym1(i,1,1,e)
     >                        + uxyz(i,3)*rzm1(i,1,1,e) )
            us(i) = jacmi(i,e)*(uxyz(i,1)*sxm1(i,1,1,e)
     >                        + uxyz(i,2)*sym1(i,1,1,e)
     >                        + uxyz(i,3)*szm1(i,1,1,e) )
            ut(i) = jacmi(i,e)*(uxyz(i,1)*txm1(i,1,1,e)
     >                        + uxyz(i,2)*tym1(i,1,1,e)
     >                        + uxyz(i,3)*tzm1(i,1,1,e) )
         enddo
         call local_grad3_t(ud,ur,us,ut,N,1,dxm1,dxtm1,tmp)
      else
         do i=1,lxyz
            ur(i) =jacmi(i,e)*(uxyz(i,1)*rxm1(i,1,1,e)
     >                       + uxyz(i,2)*rym1(i,1,1,e) )
            us(i) =jacmi(i,e)*(uxyz(i,1)*sxm1(i,1,1,e)
     >                       + uxyz(i,2)*sym1(i,1,1,e) )
         enddo
         call local_grad2_t(ud,ur,us,N,1,dxm1,dxtm1,tmp)
      endif
      call cmult(ud,csgn,nxyz)
      call add2(grad,ud,nxyz)

      return
      end

!-----------------------------------------------------------------------

      subroutine gradm1_t(u,ux,uy,uz)
! JH082516 torn bleeding from Lu's dgf3.f. someday you are going to have
!          to vectorize cmt-nek properly.
c     source: . gradm1, from navier5.f
c             . gradm1, from navier5.f
c
c     Compute divergence of ux,uy,uz -- mesh 1 to mesh 1 (vel. to vel.)
c
      include 'SIZE'
      include 'DXYZ'
      include 'GEOM'
      include 'INPUT'
c
      parameter (lxyz=lx1*ly1*lz1)
      real ux(lxyz,*),uy(lxyz,*),uz(lxyz,*),u(lxyz,*)

      common /ctmp1/ ur(lxyz),us(lxyz),ut(lxyz),tmp(lxyz)
      real ur,us,ut,tmp

      integer e

      nxyz = lx1*ly1*lz1
      ntot = nxyz*nelt

      N = lx1-1
      do e=1,nelt
         if (if3d) then

            do i=1,lxyz
               ur(i) = jacmi(i,e)*(ux(i,e)*rxm1(i,1,1,e)
     $                           + uy(i,e)*rym1(i,1,1,e)
     $                           + uz(i,e)*rzm1(i,1,1,e) )
               us(i) = jacmi(i,e)*(ux(i,e)*sxm1(i,1,1,e)
     $                           + uy(i,e)*sym1(i,1,1,e)
     $                           + uz(i,e)*szm1(i,1,1,e) )
               ut(i) = jacmi(i,e)*(ux(i,e)*txm1(i,1,1,e)
     $                           + uy(i,e)*tym1(i,1,1,e)
     $                           + uz(i,e)*tzm1(i,1,1,e) )
            enddo
            call local_grad3_t(u,ur,us,ut,N,e,dxm1,dxtm1,tmp)
         else
            do i=1,lxyz
               ur(i) =jacmi(i,e)*(ux(i,e)*rxm1(i,1,1,e)
     $                          + uy(i,e)*rym1(i,1,1,e) )
               us(i) =jacmi(i,e)*(ux(i,e)*sxm1(i,1,1,e)
     $                          + uy(i,e)*sym1(i,1,1,e) )
            enddo
            call local_grad2_t(u,ur,us,N,e,dxm1,dxtm1,tmp)
         endif
      enddo
c
      return
      end


      PROGRAM CSEX02
C
C  Show the effects of changing the weighting array.
C
C  The number of input data points.
C
      PARAMETER (NDATA=6)
C
C  The number of output data points.
C
      PARAMETER (NX=101)
C
C  The maximum number of knots used in any call.
C
      PARAMETER (NCF=5)
C
C  The size of the workspace.
C
      PARAMETER (NWRK=NCF*(NCF+3))
C
C  Array dimensions.
C
      DIMENSION XDATA(1,NDATA),YDATA(NDATA),XDATAT(NDATA)
      DIMENSION WTS(NDATA),WORK(NWRK)
      DIMENSION XO(NX),Y1(NX),Y2(NX),Y3(NX)
C
C  Initialize the weight array so that all input points are
C  weighted equally.
C
      DATA WTS/1.0, 1.0, 1.0, 1.0, 1.0, 1.0/
C
C  Specify the input data.
C
      DATA XDATA(1,1),XDATA(1,2),XDATA(1,3)/0.0, 0.2, 0.4/
      DATA XDATA(1,4),XDATA(1,5),XDATA(1,6)/0.6, 0.8, 1.0/
      DATA YDATA/0.0, 1.0, -0.7, -0.2, -0.1, 0.0/
C
C  Define the output coordinates.
C
      XINC = 1./REAL(NX-1)
      DO 10 I=1,NX
        XO(I) = (I-1)*XINC
   10 CONTINUE
C
C  Calculate the approximating curve with all weights equal.
C
      SSMTH = 0.
      NDERIV = 0
      CALL CSA1XS (NDATA,XDATA,YDATA,WTS,NCF,
     +             SSMTH,NDERIV,NX,XO,Y1,NWRK,WORK,IER)
      IF (IER .NE. 0) THEN
        WRITE(6,520) IER
  520   FORMAT(' Error ',I3,' returned from CSA1XS')
        STOP
      ENDIF
C
C  Calculate the approximating curve with the second input coordinate
C  weighted as half the other weights.
C
      WTS(2) = 0.5
      CALL CSA1XS (NDATA,XDATA,YDATA,WTS,NCF,
     +             SSMTH,NDERIV,NX,XO,Y2,NWRK,WORK,IER)
      IF (IER .NE. 0) THEN
        WRITE(6,520) IER
        STOP
      ENDIF
C
C  Calculate the approximating curve with the second input coordinate
C  ignored (i.e. with a weight of zero).
C
      WTS(2) = 0.0
      CALL CSA1XS (NDATA,XDATA,YDATA,WTS,NCF,
     +             SSMTH,NDERIV,NX,XO,Y3,NWRK,WORK,IER)
      IF (IER .NE. 0) THEN
        WRITE(6,520) IER
        STOP
      ENDIF
C
C  Draw a plot of the approximation curves and mark the original points.
C
      DO 30 I=1,NDATA
        XDATAT(I) = XDATA(1,I)
   30 CONTINUE
      CALL DRWFT1(NDATA,XDATAT,YDATA,NX,XO,Y1,Y2,Y3)
C
      STOP
      END
      SUBROUTINE DRWFT1(NUMIN,X,Y,NUMOUT,XO,Y1,Y2,Y3)
C
C  This subroutine uses NCAR Graphics to plot curves.
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
C
C  Vertical position for initial curve.
C
      DATA YPOS_TOP/0.88/
C
C  Open GKS, open and activate a workstation.
C
      CALL GOPKS (IERRF, ISZDM)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)
C
C  Define a color table.
C
      CALL GSCR(IWKID, 0, 1.0, 1.0, 1.0)
      CALL GSCR(IWKID, 1, 0.0, 0.0, 0.0)
      CALL GSCR(IWKID, 2, 1.0, 0.0, 0.0)
      CALL GSCR(IWKID, 3, 0.0, 1.0, 0.0)
      CALL GSCR(IWKID, 4, 0.0, 0.0, 1.0)
      CALL GSCLIP(0)
C
C  Plot the main title.
C
      CALL PLCHHQ(0.50,0.95,':F25:Effect of data weights',
     +            0.030,0.,0.)
C
C  Draw a background grid for the first curve.
C
      YB = -1.0
      YT =  1.0
      CALL BKGFT1(YPOS_TOP,'Weights = (1., 1., 1., 1., 1., 1.)',YB,YT)
      CALL GRIDAL(5,5,4,1,1,1,10,0.0,YB)
C
C  Graph the approximation curve where all input coordinates were
C  wieghted equally.
C
      CALL GPL(NUMOUT,XO,Y1)
C
C  Mark the original data points.
C
      CALL GSMKSC(2.)
      CALL GSPMCI(4)
      CALL GPM(NUMIN,X,Y)
C
C  Graph the approximation curve where the second input coordinate was
C  given a weight of 0.5.
C
      CALL BKGFT1(YPOS_TOP-0.3,
     +            'Weights = (1., .5, 1., 1., 1., 1.)',YB,YT)
      CALL GRIDAL(5,5,4,1,1,1,10,0.0,YB)
      CALL GPL(NUMOUT,XO,Y2)
      CALL GPM(NUMIN,X,Y)
C
C  Graph the approximation curve where the second input coordinate was
C  given a weight of 0.0 .
C
      CALL BKGFT1(YPOS_TOP-0.6,
     +            'Weights = (1., 0., 1., 1., 1., 1.)',YB,YT)
      CALL GRIDAL(5,5,4,1,1,1,10,0.0,YB)
      CALL GPL(NUMOUT,XO,Y3)
      CALL GPM(NUMIN,X,Y)
      CALL FRAME
C
      CALL GDAWK(IWKID)
      CALL GCLWK(IWKID)
      CALL GCLKS
C
      RETURN
      END
      SUBROUTINE BKGFT1(YPOS,LABEL,YB,YT)
C
C  This subroutine draws a background grid.
C
      DIMENSION XX(2),YY(2)
      CHARACTER*(*) LABEL
C
      CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
C
C  Plot the curve label using font 21 (Helvetica).
C
      CALL PCSETI('FN',21)
      CALL PLCHHQ(0.65,YPOS - 0.03,LABEL,0.023,0.,0.)
      CALL SET(0.13,0.93,YPOS-0.2,YPOS,0.0,1., YB, YT, 1)
C
C  Draw a horizontal line at Y=0. using color index 2.
C
      XX(1) = 0.
      XX(2) = 1.
      YY(1) = 0.
      YY(2) = 0.
      CALL GSPLCI(2)
      CALL GPL(2,XX,YY)
      CALL GSPLCI(1)
C
C  Set Gridal parameters.
C
C
C   Set LTY to indicate that the Plotchar routine PLCHHQ should be used.
C
      CALL GASETI('LTY',1)
C
C   Size and format for X axis labels.
C
      CALL GASETR('XLS',0.02)
      CALL GASETC('XLF','(F3.1)')
C
C   Size and format for Y axis labels.
C
      CALL GASETR('YLS',0.02)
      CALL GASETC('YLF','(F5.1)')
C
C   Length of major tick marks for the X and Y axes.
C
      CALL GASETR('XMJ',0.02)
      CALL GASETR('YMJ',0.02)
C
      RETURN
      END


      SUBROUTINE slALAZ (HA, DEC, PHI,
     :                      AZ, AZD, AZDD, EL, ELD, ELDD, PA, PAD, PADD)
*+
*     - - - - - -
*      A L A Z
*     - - - - - -
*
*  Positions, velocities and accelerations for an altazimuth
*  telescope mount.
*
*  (double precision)
*
*  Given:
*     HA      d     hour angle
*     DEC     d     declination
*     PHI     d     observatory latitude
*
*  Returned:
*     AZ      d     azimuth
*     AZD     d        "    velocity
*     AZDD    d        "    acceleration
*     EL      d     elevation
*     ELD     d         "     velocity
*     ELDD    d         "     acceleration
*     PA      d     parallactic angle
*     PAD     d         "      "   velocity
*     PADD    d         "      "   acceleration
*
*  Notes:
*
*  1)  Natural units are used throughout.  HA, DEC, PHI, AZ, EL
*      and ZD are in radians.  The velocities and accelerations
*      assume constant declination and constant rate of change of
*      hour angle (as for tracking a star);  the units of AZD, ELD
*      and PAD are radians per radian of HA, while the units of AZDD,
*      ELDD and PADD are radians per radian of HA squared.  To
*      convert into practical degree- and second-based units:
*
*        angles * 360/2pi -> degrees
*        velocities * (2pi/86400)*(360/2pi) -> degree/sec
*        accelerations * ((2pi/86400)**2)*(360/2pi) -> degree/sec/sec
*
*      Note that the seconds here are sidereal rather than SI.  One
*      sidereal second is about 0.99727 SI seconds.
*
*      The velocity and acceleration factors assume the sidereal
*      tracking case.  Their respective numerical values are (exactly)
*      1/240 and (approximately) 1/3300236.9.
*
*  2)  Azimuth is returned in the range 0-2pi;  north is zero,
*      and east is +pi/2.  Elevation and parallactic angle are
*      returned in the range +/-pi.  Parallactic angle is +ve for
*      a star west of the meridian and is the angle NP-star-zenith.
*
*  3)  The latitude is geodetic as opposed to geocentric.  The
*      hour angle and declination are topocentric.  Refraction and
*      deficiencies in the telescope mounting are ignored.  The
*      purpose of the routine is to give the general form of the
*      quantities.  The details of a real telescope could profoundly
*      change the results, especially close to the zenith.
*
*  4)  No range checking of arguments is carried out.
*
*  5)  In applications which involve many such calculations, rather
*      than calling the present routine it will be more efficient to
*      use inline code, having previously computed fixed terms such
*      as sine and cosine of latitude, and (for tracking a star)
*      sine and cosine of declination.
*
*  This revision:  29 October 2004
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION HA,DEC,PHI,AZ,AZD,AZDD,EL,ELD,ELDD,PA,PAD,PADD

      DOUBLE PRECISION DPI,D2PI,TINY
      PARAMETER (DPI=3.1415926535897932384626433832795D0,
     :           D2PI=6.283185307179586476925286766559D0,
     :           TINY=1D-30)

      DOUBLE PRECISION SH,CH,SD,CD,SP,CP,CHCD,SDCP,X,Y,Z,RSQ,R,A,E,C,S,
     :                 Q,QD,AD,ED,EDR,ADD,EDD,QDD

*  Useful functions
      SH=SIN(HA)
      CH=COS(HA)
      SD=SIN(DEC)
      CD=COS(DEC)
      SP=SIN(PHI)
      CP=COS(PHI)
      CHCD=CH*CD
      SDCP=SD*CP
      X=-CHCD*SP+SDCP
      Y=-SH*CD
      Z=CHCD*CP+SD*SP
      RSQ=X*X+Y*Y
      R=SQRT(RSQ)

*  Azimuth and elevation
      IF (RSQ.EQ.0D0) THEN
         A=0D0
      ELSE
         A=ATAN2(Y,X)
      END IF
      IF (A.LT.0D0) A=A+D2PI
      E=ATAN2(Z,R)

*  Parallactic angle
      C=CD*SP-CH*SDCP
      S=SH*CP
      IF (C*C+S*S.GT.0) THEN
         Q=ATAN2(S,C)
      ELSE
         Q=DPI-HA
      END IF

*  Velocities and accelerations (clamped at zenith/nadir)
      IF (RSQ.LT.TINY) THEN
         RSQ=TINY
         R=SQRT(RSQ)
      END IF
      QD=-X*CP/RSQ
      AD=SP+Z*QD
      ED=CP*Y/R
      EDR=ED/R
      ADD=EDR*(Z*SP+(2D0-RSQ)*QD)
      EDD=-R*QD*AD
      QDD=EDR*(SP+2D0*Z*QD)

*  Results
      AZ=A
      AZD=AD
      AZDD=ADD
      EL=E
      ELD=ED
      ELDD=EDD
      PA=Q
      PAD=QD
      PADD=QDD

      END


!==========================================================================
pure subroutine gsw_nsquared (sa, ct, p, lat, n2, p_mid)
!==========================================================================
!
!  Calculates the buoyancy frequency squared (N^2)(i.e. the Brunt-Vaisala
!  frequency squared) at the mid pressure from the equation,
!
!
!           2      2             beta.d(SA) - alpha.d(CT)
!         N   =  g  .rho_local. -------------------------
!                                          dP
!
!  The pressure increment, dP, in the above formula is in Pa, so that it is
!  10^4 times the pressure increment dp in dbar.
!
!  sa     : Absolute Salinity         (a profile (length nz))     [g/kg]
!  ct     : Conservative Temperature  (a profile (length nz))     [deg C]
!  p      : sea pressure              (a profile (length nz))     [dbar]
!  lat    : latitude                  (a profile (length nz))     [deg N]
!  n2     : Brunt-Vaisala Frequency squared  (length nz-1)        [s^-2]
!  p_mid  : Mid pressure between p grid      (length nz-1)        [dbar]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_grav, gsw_rho_alpha_beta

use gsw_mod_teos10_constants, only : db2pa

use gsw_mod_error_functions, only : gsw_error_code

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa(:), ct(:), p(:), lat(:)
real (r8), intent(out) :: n2(:), p_mid(:)

integer :: nz, k
real (r8), dimension(:), allocatable :: dsa, sa_mid, dct, ct_mid, dp, rho_mid
real (r8), dimension(:), allocatable :: alpha_mid, beta_mid, grav_local, grav

character (*), parameter :: func_name = "gsw_nsquared"

nz = size(sa)
if (size(n2).lt.nz-1 .or. size(p_mid).lt.nz-1) then
    n2 = gsw_error_code(1,func_name)
    p_mid = n2(1)
    return
end if

allocate (grav(nz), dsa(nz-1), sa_mid(nz-1), dct(nz-1), ct_mid(nz-1), dp(nz-1))
allocate (rho_mid(nz-1), alpha_mid(nz-1), beta_mid(nz-1), grav_local(nz-1))

grav = gsw_grav(lat(1:nz),p(1:nz))

forall (k = 1: nz-1)
    grav_local(k) = 0.5_r8*(grav(k) + grav(k+1))
    dsa(k) = (sa(k+1) - sa(k))
    sa_mid(k) = 0.5_r8*(sa(k) + sa(k+1))
    dct(k) = (ct(k+1) - ct(k))
    ct_mid(k) = 0.5_r8*(ct(k) + ct(k+1))
    dp(k) = (p(k+1) - p(k))
    p_mid(k) = 0.5_r8*(p(k) + p(k+1))
end forall

call gsw_rho_alpha_beta(sa_mid,ct_mid,p_mid(1:nz-1),rho_mid,alpha_mid,beta_mid)

n2(1:nz-1) = (grav_local**2) * (rho_mid/(db2pa*dp)) * &
             (beta_mid*dsa - alpha_mid*dct)

deallocate (grav, dsa, sa_mid, dct, ct_mid, dp)
deallocate (rho_mid, alpha_mid, beta_mid, grav_local)

return
end subroutine

!--------------------------------------------------------------------------