! =================================================================================================
! =================================================================================================
! ========================                                               ==========================
! ========================   SYMMETRIC INVERTIBLE BILINEAR QUADRATURE    ==========================
! ========================                                               ==========================
! =================================================================================================
! =================================================================================================
!
!
! Author: Christopher A. Wong
! Date: 7 March 2016
! Source: Fortran 2008
!
! Dependencies: LAPACK, NLopt
!
! This module contains the necessary routines to compute a stable and accurate symmetric bilinear
! quadrature rule that is exact for a continuous inner product on a prescribed finite-dimensional
! subspace of continuous functions.
!
! Externally called procedures:
!   bquad_buildpars
!   bquad_construct
!
! Internal procedures:
!   sigmamax
!	ptperturb
!

! =================================================================================================
!                                       INTERFACE MODULE
! =================================================================================================
!
! This module specifies the interface for the subroutine that computes the matrix function
!                               A(x) = inv(F(x)) * G(x)
! where F(x), G(x) are the collocation matrices for the function space to be integrated exactly and
! the orthogonal function space to be minimized, respectively.

module bquad_interface

    implicit none
    private
    integer,    parameter                       :: dp = kind(1.0d0)

    abstract interface
        subroutine eval(x,numpt,output)
            import dp
            real(dp),   dimension(:),   intent(in)  :: x
            integer,                    intent(in)  :: numpt
            real(dp),   dimension(:,:), intent(out) :: output
        end subroutine eval

    end interface

    public  :: eval

end module bquad_interface

module bquad

    use bquad_interface
    implicit none
    private
    save
    integer,    parameter                       :: dp = kind(1.0d0)
    integer                                     :: numpt, dm, numg, mink, LWORK

    public  :: bquad_buildpars, bquad_construct

    contains

! =================================================================================================

! Sets the following module-global parameters
!   numpt   --- number of points = dimension of function space on which quadrature is exact
!   dm      --- dimension of ambient space
!   numg    --- Dimension of orthogonal function space on which bilinear quadrature is minimal
!	mink	--- Minimum between numpt and numg
!	LWORK	--- Optimal amount of memory required for SVD calculation.

subroutine bquad_buildpars(numpt_in, dm_in, numg_in)

    implicit none
    integer,    intent(in)  :: numpt_in, dm_in, numg_in

    numpt = numpt_in
    dm = dm_in
    numg = numg_in
    mink = min(numpt,numg)
    LWORK = max(1, 3*mink + max(numpt,numg), 5*mink)

end subroutine bquad_buildpars

! =================================================================================================

subroutine bquad_construct(n, A_in, x, W, sigma_out, time)

	implicit none
	integer,					intent(in)		:: n
	procedure(eval)								:: A_in
	real(dp),	dimension(:),	intent(inout)	:: x
	real(dp),	dimension(:,:),	intent(out)		:: W
	real(dp),					intent(out)		:: sigma_out
	real(dp),	optional,		intent(out)		:: time

	real(dp)									:: eps
	integer										:: AlgIter, OptIter, MaxOptIter
	integer,	dimension(1:4)					:: alg_list
	logical										:: time_flag

	! 12 - Praxis, 25 - BOBYQA, 28 - Nelder Mead, 29 - SBPLX
	alg_list = (/ 28, 29, 25, 12 /)

	! Set parameters
	MaxOptIter = 10
	eps = 5.0d-3
	if (present(time)) then
		time_flag = .TRUE.
	else
		time_flag = .FALSE.
	end if

	! Iterate over different algorithms
	do OptIter = 1,MaxOptIter

		call ptperturb(x,eps)

		do AlgIter = 1,4
			call optimize(n, x, A_in, time_flag, sigma_out, alg_list(AlgIter))
		end do

	end do

	! Construct weight matrix
	W = 1	! Temporary

	print *, 'Final min. sigma: ', sigma_out

end subroutine bquad_construct

! =================================================================================================

! Calls an external optimization library to minimize the bilinear quadrature objective function
!
!   Inputs:
!       n           --- number of variables; equals numpt * dm
!       x           --- initial guess value, DIM(1:n)
!       A_in        --- subroutine that computes A(x) = inv(F(x) * G(x))
!		time 		--- logical, if TRUE indicates that runtime should be output
!       alg         --- optional, integer identifier for NLopt optimization algorithm
!   Outputs:
!       x           --- bilinear quadrature evaluation points, DIM(1:n)
!		sigma		--- Minimized singular value

subroutine optimize(n, x, A_in, time_flag, sigma, alg)

    implicit none

    integer,                    intent(in)      :: n
    procedure(eval)                             :: A_in
    real(dp),   dimension(:),   intent(inout)   :: x
    integer,    optional,       intent(in)      :: alg
    logical,					intent(in)		:: time_flag
	real(dp),					intent(out)		:: sigma

    real(dp),   parameter                       :: tol_rel = 1.0d-6
    real(dp),   parameter                       :: tol_abs = 1.0d-6
    integer                                     :: ires, NL_alg
    integer*8                                   :: opt

    real(dp)									:: time
    integer 									:: clock0, clock1, clockrate, ticks

	! Initialize clock
	if (time_flag) then
    	call system_clock(clock0, count_rate = clockrate)
	end if

    ! Set algorithm
    if ( time_flag ) then
        NL_alg = alg
    else
        NL_alg = 12
    end if

    ! Build NLopt library optimization options
    ! 12 - Praxis, 25 - BOBYQA, 28 - Nelder Mead, 29 - SBPLX
    opt = 0
    call nlo_create(opt, NL_alg, n)  ! Creates option object with desired algorithm
    call nlo_set_min_objective(ires,opt,sigmamax,A_in) ! Sets objective function to sigmamax
    call nlo_set_ftol_rel(ires, opt, tol_rel)   ! Specifies relative tolerance
    call nlo_set_ftol_abs(ires, opt, tol_abs)   ! Specifies absolute tolerance
    call nlo_set_maxeval(ires,opt,0)
!     call nlo_set_maxtime(ires,opt,0.0d0)

    ! Invoke NLopt
    call nlo_optimize(ires, opt, x, sigma)
    call nlo_destroy(opt)

    print *, 'Min. sigma: ', sigma

    ! Compute run time
	if (time_flag) then
    	call system_clock(clock1)
    	time = real(clock1-clock0,dp) / real(clockrate,dp)
    	print *, "Algorithm ", NL_alg, " runtime: ", time
	end if

end subroutine optimize

! =================================================================================================

! Computes || inv(F(x)) * G(x) ||_2, the objective function in the bilinear quadrature formulation
! Input variables "grad" and "need_grad" are only present to conform to NLopt subroutine format

subroutine sigmamax(output, n, x, grad, need_grad, A_in)

    implicit none

    real(dp),                   intent(out) :: output
    integer,                    intent(in)  :: n
    real(dp),   dimension(1:n), intent(in)  :: x, grad
    integer,                    intent(in)  :: need_grad
    procedure(eval)                         :: A_in

    real(dp),   dimension(1:numpt,1:numg)   :: eval_out
    real(dp),   dimension(1:mink)           :: sigma
    real(dp),   dimension(1:LWORK)          :: WORK
    integer                                 :: INFO

    call A_in(x,numpt,eval_out)

    ! Compute singular values with LAPACK
    call dgesvd('N','N',numpt,numg,eval_out,numpt,sigma,0.0d0,1,0.0d0,1,WORK,LWORK,INFO)

    output = sigma(1)

end subroutine sigmamax

! =================================================================================================

! Slightly perturbs an input point by a small random value. Used to force optimization procedure to
! escape from local but nonglobal minima.

subroutine ptperturb(x,eps)

	implicit none

	real(dp),	dimension(:),	intent(inout)	:: x
	real(dp),					intent(in)		:: eps

	integer										:: loop, seed

	call system_clock(count = seed)
    call srand(seed)

    do loop = 1, size(x,1)
    	x(loop) = x(loop) + eps * (2*rand() - 1)
    end do

end subroutine ptperturb

! =================================================================================================

end module bquad


PROGRAM mcjylv

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:10

!       ========================================================
!       Purpose: This program computes Bessel functions Jv(z)
!                and Yv(z) and their derivatives with a large
!                order and complex argument using subroutine
!                CJYLV
!       Input:   v --- Order of Jv(z) and Yv(z)
!                z --- Complex argument
!       Output:  CBJV --- Jv(z)
!                CDJV --- Jv'(z)
!                CBYV --- Yv(z)
!                CDYV --- Yv'(z)
!       Examples:
!                v = 100.00,    z = 4.00 + 2.00 i

!                Jv(z) = -.6444792518-123 + .6619157435-123 i
!                Jv'(z)= -.6251103777-122 + .1967638668-121 i
!                Yv(z) =  .2403065353+121 + .2472039414+121 i
!                Yv'(z)= -.7275814786+122 - .2533588851+122 i

!                v =100.5,     z = 4.00 + 2.00 i

!                Jv(z) = -.1161315754-123 + .7390127781-124 i
!                Jv'(z)= -.1588519437-122 + .2652227059-122 i
!                Yv(z) =  .1941381412+122 + .1237578195+122 i
!                Yv'(z)= -.5143285247+123 - .5320026773+122 i
!       ========================================================

IMPLICIT DOUBLE PRECISION (v,x,y)
IMPLICIT COMPLEX*16 (c,z)
WRITE(*,*)'Please enter v,x and y ( z = x+iy )'
!        READ(*,*)V,X,Y
v=100.0
x=4.0
y=2.0
WRITE(*,10)v,x,y
z=CMPLX(x,y)
CALL cjylv(v,z,cbjv,cdjv,cbyv,cdyv)
WRITE(*,*)
WRITE(*,20)cbjv
WRITE(*,30)cdjv
WRITE(*,*)
WRITE(*,40)cbyv
WRITE(*,50)cdyv
10      FORMAT(8X,'v = ',f6.2,',    ','z =',f7.2,' + i ',f7.2)
20      FORMAT(8X,'Jv(z) =',d17.10,' + i',d17.10)
30      FORMAT(8X,'Jv''(Z)=',d17.10,' + I',d17.10)
40      FORMAT(8X,'Yv(z) =',d17.10,' + i',d17.10)
50      FORMAT(8X,'Yv''(Z)=',d17.10,' + I',d17.10)
END PROGRAM mcjylv

SUBROUTINE cjylv(v,z,cbjv,cdjv,cbyv,cdyv)

!       ===================================================
!       Purpose: Compute Bessel functions Jv(z) and Yv(z)
!                and their derivatives with a complex
!                argument and a large order
!       Input:   v --- Order of Jv(z) and Yv(z)
!                z --- Complex argument
!       Output:  CBJV --- Jv(z)
!                CDJV --- Jv'(z)
!                CBYV --- Yv(z)
!                CDYV --- Yv'(z)
!       Routine called:
!                CJK to compute the expansion coefficients
!       ===================================================

DOUBLE PRECISION, INTENT(IN)             :: v
COMPLEX, INTENT(IN)                      :: z
COMPLEX, INTENT(OUT)                     :: cbjv
COMPLEX, INTENT(OUT)                     :: cdjv
COMPLEX, INTENT(OUT)                     :: cbyv
COMPLEX, INTENT(OUT)                     :: cdyv
IMPLICIT DOUBLE PRECISION (a,b,d-h,o-y)
IMPLICIT COMPLEX*16 (c,z)
DIMENSION cf(12),a(91)

km=12
CALL cjk(km,a)
pi=3.141592653589793D0
DO  l=1,0,-1
  v0=v-l
  cws=CDSQRT(1.0D0-(z/v0)*(z/v0))
  ceta=cws+CDLOG(z/v0/(1.0D0+cws))
  ct=1.0D0/cws
  ct2=ct*ct
  DO  k=1,km
    l0=k*(k+1)/2+1
    lf=l0+k
    cf(k)=a(lf)
    DO  i=lf-1,l0,-1
      cf(k)=cf(k)*ct2+a(i)
    END DO
    cf(k)=cf(k)*ct**k
  END DO
  vr=1.0D0/v0
  csj=(1.0D0,0.0D0)
  DO  k=1,km
    csj=csj+cf(k)*vr**k
  END DO
  cbjv=CDSQRT(ct/(2.0D0*pi*v0))*CDEXP(v0*ceta)*csj
  IF (l == 1) cfj=cbjv
  csy=(1.0D0,0.0D0)
  DO  k=1,km
    csy=csy+(-1)**k*cf(k)*vr**k
  END DO
  cbyv=-CDSQRT(2.0D0*ct/(pi*v0))*CDEXP(-v0*ceta)*csy
  IF (l == 1) cfy=cbyv
END DO
cdjv=-v/z*cbjv+cfj
cdyv=-v/z*cbyv+cfy
RETURN
END SUBROUTINE cjylv

SUBROUTINE cjk(km,a)

!       ========================================================
!       Purpose: Compute the expansion coefficients for the
!                asymptotic expansion of Bessel functions
!                with large orders
!       Input :  Km   --- Maximum k
!       Output:  A(L) --- Cj(k) where j and k are related to L
!                         by L=j+1+[k*(k+1)]/2; j,k=0,1,...,Km
!       ========================================================

INTEGER, INTENT(IN)                      :: km
DOUBLE PRECISION, INTENT(OUT)            :: a(*)
IMPLICIT DOUBLE PRECISION (a-h,o-z)

a(1)=1.0D0
f0=1.0D0
g0=1.0D0
DO  k=0,km-1
  l1=(k+1)*(k+2)/2+1
  l2=(k+1)*(k+2)/2+k+2
  f=(0.5D0*k+0.125D0/(k+1))*f0
  g=-(1.5D0*k+0.625D0/(3.0*(k+1.0D0)))*g0
  a(l1)=f
  a(l2)=g
  f0=f
  g0=g
END DO
DO  k=1,km-1
  DO  j=1,k
    l3=k*(k+1)/2+j+1
    l4=(k+1)*(k+2)/2+j+1
    a(l4)=(j+0.5D0*k+0.125D0/(2.0*j+k+1.0))*a(l3)  &
        -(j+0.5D0*k-1.0+0.625D0/(2.0*j+k+1.0))*a(l3-1)
  END DO
END DO
RETURN
END SUBROUTINE cjk


module data_tools
    implicit none

    real(8), parameter :: PI = 4d0 * atan(1d0)

contains
    ! Saves points and fields into a textfile
    subroutine save_data(xyz_list, E_list, filename)
        real(8), intent(in) :: xyz_list(:, :)  ! list of points = [x1, y1, z1; x2, y2, z2; ...]
        real(8), intent(in) :: E_list(:, :) ! real part of electric field in V/m
        character(len=*), intent(in) :: filename

        integer :: n
        integer :: n_points
        integer, parameter :: file_id = 1

        n_points = size(xyz_list, 2)
        open(unit=file_id, file=filename, status="REPLACE", action="WRITE")

        ! print to file
        ! format: x y z Ex Ey Ez
        do n = 1, n_points
            write(file_id, *) xyz_list(1, n), xyz_list(2, n), xyz_list(3, n), E_list(1, n), E_list(2, n), E_list(3, n)
        end do

        close(file_id)
    end subroutine

    subroutine load_matlab_mesh(filename, mesh)
        character(len=*), intent(in) :: filename
        real(8), allocatable, intent(out) :: mesh(:, :)

        integer :: n_points, n
        integer, parameter :: file_id = 1

        open(unit=file_id, file=filename, status="OLD", action="READ")

        read(file_id, *) n_points
        allocate(mesh(n_points, 3))

        ! Format:
        ! npoints
        ! x1 y1 z1
        ! x2 y2 z2
        do n = 1, n_points
            read(file_id,*) mesh(n, 1), mesh(n, 2), mesh(n, 3)
        end do

        close(file_id)
    end subroutine

    subroutine save_data_to_matlab_cmplx(filename, mesh, E_array)
        character(len=*), intent(in) :: filename
        real(8), intent(in) :: mesh(:, :)          ! mesh(n_points,3)
        complex(8), intent(in) :: E_array(:, :)    ! E_array(n_points,3)

        integer :: n_points, n
        integer, parameter :: file_id = 1

        n_points = size(mesh, 1)
        open(unit=file_id, file=filename, status="REPLACE", action="WRITE")

        ! Format:
        ! npoints
        ! x1 y1 z1 real(Ex1) real(Ey1) real(Ez1) imag(Ex1) imag(Ey1) imag(Ez1)
        ! x2 y2 z2 real(Ex2) real(Ey2) real(Ez2) imag(Ex2) imag(Ey2) imag(Ez2)
        write(file_id, *) n_points  ! write number of points
        do n = 1, n_points
            write(file_id, *) mesh(n, 1), mesh(n, 2), mesh(n, 3),  &
                              dreal(E_array(n, 1)), dreal(E_array(n, 2)), dreal(E_array(n, 3)),  &
                              dimag(E_array(n, 1)), dimag(E_array(n, 2)), dimag(E_array(n, 3))
        end do
        close(file_id)
    end subroutine

    ! Creates a mesh of a spherical surface
    subroutine spherical_mesh(sphere_radius, n_points, xyz_list)
        real(8), intent(in) :: sphere_radius
        integer, intent(in) :: n_points             ! number of points per dimension
        real(8), allocatable, intent(out) :: xyz_list(:, :)  ! list of points = [x1, y1, z1; x2, y2, z2; ...]

        integer :: i
        real(8) :: theta(n_points), phi(n_points)
        real(8) :: theta_2d(n_points, n_points), phi_2d(n_points, n_points)
        real(8) :: X(n_points, n_points), Y(n_points, n_points), Z(n_points, n_points)

        theta = [( PI / n_points * i, i=0, n_points-1)]
        phi = [( 2 * PI / n_points * i, i=0, n_points-1)]

        theta_2d = spread(theta, 1, n_points)
        phi_2d = spread(phi, 2, n_points)

        X = sphere_radius * sin(theta_2d) * cos(phi_2d)
        Y = sphere_radius * sin(theta_2d) * sin(phi_2d)
        Z = sphere_radius * cos(theta_2d)

        allocate(xyz_list(3, n_points ** 2))
        xyz_list(1, :) = pack(X, .true.)
        xyz_list(2, :) = pack(Y, .true.)
        xyz_list(3, :) = pack(Z, .true.)
    end subroutine

    ! Creates a rectangular mesh, not including a sphere
    subroutine rectangular_mesh(a, xi, xf, yi, yf, zi, zf, n_points, xyz_list)
        real(8), intent(in) :: a              ! sphere radius
        real(8), intent(in) :: xi, yi, zi     ! initial point in each dimension
        real(8), intent(in) :: xf, yf, zf     ! ending point in each dimension
        integer, intent(in) :: n_points       ! number of points per dimension
        real(8), allocatable, intent(out) :: xyz_list(:, :)  ! list of points = [x1, y1, z1; x2, y2, z2; ...]

        integer :: i
        integer :: points_outside_sphere
        real(8) :: grid_x(n_points), grid_y(n_points), grid_z(n_points)
        real(8) :: X(n_points, n_points, n_points)
        real(8) :: Y(n_points, n_points, n_points)
        real(8) :: Z(n_points, n_points, n_points)
        logical :: mask(n_points, n_points, n_points)

        grid_x = xi + [( (xf - xi) / n_points * i, i=0, n_points-1)]
        grid_y = yi + [( (yf - yi) / n_points * i, i=0, n_points-1)]
        grid_z = zi + [( (zf - zi) / n_points * i, i=0, n_points-1)]

        do i = 1,n_points
            X(:,:,i) = spread(grid_x, 1, n_points)
            Y(:,:,i) = spread(grid_y, 2, n_points)
        end do

        do i = 1,n_points
            Z(i,:,:) = spread(grid_z, 1, n_points)
        end do

        mask = X**2 + Y**2 + Z**2 > a**2
        points_outside_sphere = count(mask)

        allocate(xyz_list(3, points_outside_sphere))
        xyz_list(1, :) = pack(X, mask)
        xyz_list(2, :) = pack(Y, mask)
        xyz_list(3, :) = pack(Z, mask)
    end subroutine

end module


    Module blas_interfaces

!     NAG COPYRIGHT 2017.

!     .. Implicit None Statement ..
      Implicit None
!     .. Interface Blocks ..
      Interface
        Function dasum(n, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Function Return Value ..
          Real (Kind=dp) :: dasum
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, n
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: x(*)
        End Function
        Subroutine daxpy(n, alpha, x, incx, y, incy)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: incx, incy, n
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: x(*)
          Real (Kind=dp), Intent (Inout) :: y(*)
        End Subroutine
        Subroutine daxpyi(nz, a, x, indx, y)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: a
          Integer, Intent (In) :: nz
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: x(*)
          Real (Kind=dp), Intent (Inout) :: y(*)
          Integer, Intent (In) :: indx(*)
        End Subroutine
        Subroutine dcopy(n, x, incx, y, incy)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, incy, n
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: x(*)
          Real (Kind=dp), Intent (Inout) :: y(*)
        End Subroutine
        Function ddot(n, x, incx, y, incy)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Function Return Value ..
          Real (Kind=dp) :: ddot
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, incy, n
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: x(*), y(*)
        End Function
        Function ddoti(nz, x, indx, y)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Function Return Value ..
          Real (Kind=dp) :: ddoti
!         .. Scalar Arguments ..
          Integer, Intent (In) :: nz
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: x(*), y(*)
          Integer, Intent (In) :: indx(*)
        End Function
        Subroutine dgbmv(trans, m, n, kl, ku, alpha, a, lda, x, incx, beta, y, &
          incy)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: incx, incy, kl, ku, lda, m, n
          Character (1), Intent (In) :: trans
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: a(lda, *), x(*)
          Real (Kind=dp), Intent (Inout) :: y(*)
        End Subroutine
        Subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, &
          c, ldc)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: k, lda, ldb, ldc, m, n
          Character (1), Intent (In) :: transa, transb
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: a(lda, *), b(ldb, *)
          Real (Kind=dp), Intent (Inout) :: c(ldc, *)
        End Subroutine
        Subroutine dgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: incx, incy, lda, m, n
          Character (1), Intent (In) :: trans
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: a(lda, *), x(*)
          Real (Kind=dp), Intent (Inout) :: y(*)
        End Subroutine
        Subroutine dger(m, n, alpha, x, incx, y, incy, a, lda)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: incx, incy, lda, m, n
!         .. Array Arguments ..
          Real (Kind=dp), Intent (Inout) :: a(lda, *)
          Real (Kind=dp), Intent (In) :: x(*), y(*)
        End Subroutine
        Subroutine dgthr(nz, y, x, indx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: nz
!         .. Array Arguments ..
          Real (Kind=dp), Intent (Inout) :: x(*)
          Real (Kind=dp), Intent (In) :: y(*)
          Integer, Intent (In) :: indx(*)
        End Subroutine
        Subroutine dgthrz(nz, y, x, indx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: nz
!         .. Array Arguments ..
          Real (Kind=dp), Intent (Inout) :: x(*), y(*)
          Integer, Intent (In) :: indx(*)
        End Subroutine
        Function dnrm2(n, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Function Return Value ..
          Real (Kind=dp) :: dnrm2
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, n
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: x(*)
        End Function
        Subroutine drot(n, x, incx, y, incy, c, s)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: c, s
          Integer, Intent (In) :: incx, incy, n
!         .. Array Arguments ..
          Real (Kind=dp), Intent (Inout) :: x(*), y(*)
        End Subroutine
        Subroutine drotg(a, b, c, s)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (Inout) :: a, b
          Real (Kind=dp), Intent (Out) :: c, s
        End Subroutine
        Subroutine droti(nz, x, indx, y, c, s)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: c, s
          Integer, Intent (In) :: nz
!         .. Array Arguments ..
          Real (Kind=dp), Intent (Inout) :: x(*), y(*)
          Integer, Intent (In) :: indx(*)
        End Subroutine
        Subroutine dsbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: incx, incy, k, lda, n
          Character (1), Intent (In) :: uplo
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: a(lda, *), x(*)
          Real (Kind=dp), Intent (Inout) :: y(*)
        End Subroutine
        Subroutine dscal(n, alpha, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: incx, n
!         .. Array Arguments ..
          Real (Kind=dp), Intent (Inout) :: x(*)
        End Subroutine
        Subroutine dsctr(nz, x, indx, y)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: nz
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: x(*)
          Real (Kind=dp), Intent (Inout) :: y(*)
          Integer, Intent (In) :: indx(*)
        End Subroutine
        Subroutine dspmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: incx, incy, n
          Character (1), Intent (In) :: uplo
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: ap(*), x(*)
          Real (Kind=dp), Intent (Inout) :: y(*)
        End Subroutine
        Subroutine dspr(uplo, n, alpha, x, incx, ap)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: incx, n
          Character (1), Intent (In) :: uplo
!         .. Array Arguments ..
          Real (Kind=dp), Intent (Inout) :: ap(*)
          Real (Kind=dp), Intent (In) :: x(*)
        End Subroutine
        Subroutine dspr2(uplo, n, alpha, x, incx, y, incy, ap)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: incx, incy, n
          Character (1), Intent (In) :: uplo
!         .. Array Arguments ..
          Real (Kind=dp), Intent (Inout) :: ap(*)
          Real (Kind=dp), Intent (In) :: x(*), y(*)
        End Subroutine
        Subroutine dswap(n, x, incx, y, incy)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, incy, n
!         .. Array Arguments ..
          Real (Kind=dp), Intent (Inout) :: x(*), y(*)
        End Subroutine
        Subroutine dsymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, &
          ldc)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: lda, ldb, ldc, m, n
          Character (1), Intent (In) :: side, uplo
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: a(lda, *), b(ldb, *)
          Real (Kind=dp), Intent (Inout) :: c(ldc, *)
        End Subroutine
        Subroutine dsymv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: incx, incy, lda, n
          Character (1), Intent (In) :: uplo
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: a(lda, *), x(*)
          Real (Kind=dp), Intent (Inout) :: y(*)
        End Subroutine
        Subroutine dsyr(uplo, n, alpha, x, incx, a, lda)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: incx, lda, n
          Character (1), Intent (In) :: uplo
!         .. Array Arguments ..
          Real (Kind=dp), Intent (Inout) :: a(lda, *)
          Real (Kind=dp), Intent (In) :: x(*)
        End Subroutine
        Subroutine dsyr2(uplo, n, alpha, x, incx, y, incy, a, lda)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: incx, incy, lda, n
          Character (1), Intent (In) :: uplo
!         .. Array Arguments ..
          Real (Kind=dp), Intent (Inout) :: a(lda, *)
          Real (Kind=dp), Intent (In) :: x(*), y(*)
        End Subroutine
        Subroutine dsyr2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, &
          ldc)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: k, lda, ldb, ldc, n
          Character (1), Intent (In) :: trans, uplo
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: a(lda, *), b(ldb, *)
          Real (Kind=dp), Intent (Inout) :: c(ldc, *)
        End Subroutine
        Subroutine dsyrk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: k, lda, ldc, n
          Character (1), Intent (In) :: trans, uplo
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: a(lda, *)
          Real (Kind=dp), Intent (Inout) :: c(ldc, *)
        End Subroutine
        Subroutine dtbmv(uplo, trans, diag, n, k, a, lda, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, k, lda, n
          Character (1), Intent (In) :: diag, trans, uplo
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: a(lda, *)
          Real (Kind=dp), Intent (Inout) :: x(*)
        End Subroutine
        Subroutine dtbsv(uplo, trans, diag, n, k, a, lda, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, k, lda, n
          Character (1), Intent (In) :: diag, trans, uplo
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: a(lda, *)
          Real (Kind=dp), Intent (Inout) :: x(*)
        End Subroutine
        Subroutine dtpmv(uplo, trans, diag, n, ap, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, n
          Character (1), Intent (In) :: diag, trans, uplo
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: ap(*)
          Real (Kind=dp), Intent (Inout) :: x(*)
        End Subroutine
        Subroutine dtpsv(uplo, trans, diag, n, ap, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, n
          Character (1), Intent (In) :: diag, trans, uplo
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: ap(*)
          Real (Kind=dp), Intent (Inout) :: x(*)
        End Subroutine
        Subroutine dtrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, &
          ldb)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: lda, ldb, m, n
          Character (1), Intent (In) :: diag, side, transa, uplo
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: a(lda, *)
          Real (Kind=dp), Intent (Inout) :: b(ldb, *)
        End Subroutine
        Subroutine dtrmv(uplo, trans, diag, n, a, lda, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, lda, n
          Character (1), Intent (In) :: diag, trans, uplo
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: a(lda, *)
          Real (Kind=dp), Intent (Inout) :: x(*)
        End Subroutine
        Subroutine dtrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, &
          ldb)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: lda, ldb, m, n
          Character (1), Intent (In) :: diag, side, transa, uplo
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: a(lda, *)
          Real (Kind=dp), Intent (Inout) :: b(ldb, *)
        End Subroutine
        Subroutine dtrsv(uplo, trans, diag, n, a, lda, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, lda, n
          Character (1), Intent (In) :: diag, trans, uplo
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: a(lda, *)
          Real (Kind=dp), Intent (Inout) :: x(*)
        End Subroutine
        Function dzasum(n, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Function Return Value ..
          Real (Kind=dp) :: dzasum
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, n
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: x(*)
        End Function
        Function dznrm2(n, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Function Return Value ..
          Real (Kind=dp) :: dznrm2
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, n
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: x(*)
        End Function
        Function idamax(n, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Function Return Value ..
          Integer :: idamax
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, n
!         .. Array Arguments ..
          Real (Kind=dp), Intent (In) :: x(*)
        End Function
        Function izamax(n, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Function Return Value ..
          Integer :: izamax
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, n
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: x(*)
        End Function
        Subroutine zaxpy(n, alpha, x, incx, y, incy)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: incx, incy, n
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: x(*)
          Complex (Kind=dp), Intent (Inout) :: y(*)
        End Subroutine
        Subroutine zaxpyi(nz, a, x, indx, y)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: a
          Integer, Intent (In) :: nz
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: x(*)
          Complex (Kind=dp), Intent (Inout) :: y(*)
          Integer, Intent (In) :: indx(*)
        End Subroutine
        Subroutine zcopy(n, x, incx, y, incy)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, incy, n
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: x(*)
          Complex (Kind=dp), Intent (Inout) :: y(*)
        End Subroutine
        Function zdotc(n, x, incx, y, incy)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Function Return Value ..
          Complex (Kind=dp) :: zdotc
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, incy, n
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: x(*), y(*)
        End Function
        Function zdotci(nz, x, indx, y)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Function Return Value ..
          Complex (Kind=dp) :: zdotci
!         .. Scalar Arguments ..
          Integer, Intent (In) :: nz
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: x(*), y(*)
          Integer, Intent (In) :: indx(*)
        End Function
        Function zdotu(n, x, incx, y, incy)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Function Return Value ..
          Complex (Kind=dp) :: zdotu
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, incy, n
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: x(*), y(*)
        End Function
        Function zdotui(nz, x, indx, y)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Function Return Value ..
          Complex (Kind=dp) :: zdotui
!         .. Scalar Arguments ..
          Integer, Intent (In) :: nz
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: x(*), y(*)
          Integer, Intent (In) :: indx(*)
        End Function
        Subroutine zdrot(n, x, incx, y, incy, c, s)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: c, s
          Integer, Intent (In) :: incx, incy, n
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (Inout) :: x(*), y(*)
        End Subroutine
        Subroutine zdscal(n, alpha, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: incx, n
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (Inout) :: x(*)
        End Subroutine
        Subroutine zgbmv(trans, m, n, kl, ku, alpha, a, lda, x, incx, beta, y, &
          incy)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: incx, incy, kl, ku, lda, m, n
          Character (1), Intent (In) :: trans
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: a(lda, *), x(*)
          Complex (Kind=dp), Intent (Inout) :: y(*)
        End Subroutine
        Subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, &
          c, ldc)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: k, lda, ldb, ldc, m, n
          Character (1), Intent (In) :: transa, transb
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: a(lda, *), b(ldb, *)
          Complex (Kind=dp), Intent (Inout) :: c(ldc, *)
        End Subroutine
        Subroutine zgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: incx, incy, lda, m, n
          Character (1), Intent (In) :: trans
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: a(lda, *), x(*)
          Complex (Kind=dp), Intent (Inout) :: y(*)
        End Subroutine
        Subroutine zgerc(m, n, alpha, x, incx, y, incy, a, lda)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: incx, incy, lda, m, n
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (Inout) :: a(lda, *)
          Complex (Kind=dp), Intent (In) :: x(*), y(*)
        End Subroutine
        Subroutine zgeru(m, n, alpha, x, incx, y, incy, a, lda)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: incx, incy, lda, m, n
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (Inout) :: a(lda, *)
          Complex (Kind=dp), Intent (In) :: x(*), y(*)
        End Subroutine
        Subroutine zgthr(nz, y, x, indx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: nz
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (Inout) :: x(*)
          Complex (Kind=dp), Intent (In) :: y(*)
          Integer, Intent (In) :: indx(*)
        End Subroutine
        Subroutine zgthrz(nz, y, x, indx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: nz
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (Inout) :: x(*), y(*)
          Integer, Intent (In) :: indx(*)
        End Subroutine
        Subroutine zhbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: incx, incy, k, lda, n
          Character (1), Intent (In) :: uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: a(lda, *), x(*)
          Complex (Kind=dp), Intent (Inout) :: y(*)
        End Subroutine
        Subroutine zhemm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, &
          ldc)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: lda, ldb, ldc, m, n
          Character (1), Intent (In) :: side, uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: a(lda, *), b(ldb, *)
          Complex (Kind=dp), Intent (Inout) :: c(ldc, *)
        End Subroutine
        Subroutine zhemv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: incx, incy, lda, n
          Character (1), Intent (In) :: uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: a(lda, *), x(*)
          Complex (Kind=dp), Intent (Inout) :: y(*)
        End Subroutine
        Subroutine zher(uplo, n, alpha, x, incx, a, lda)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: incx, lda, n
          Character (1), Intent (In) :: uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (Inout) :: a(lda, *)
          Complex (Kind=dp), Intent (In) :: x(*)
        End Subroutine
        Subroutine zher2(uplo, n, alpha, x, incx, y, incy, a, lda)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: incx, incy, lda, n
          Character (1), Intent (In) :: uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (Inout) :: a(lda, *)
          Complex (Kind=dp), Intent (In) :: x(*), y(*)
        End Subroutine
        Subroutine zher2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, &
          ldc)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: alpha
          Real (Kind=dp), Intent (In) :: beta
          Integer, Intent (In) :: k, lda, ldb, ldc, n
          Character (1), Intent (In) :: trans, uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: a(lda, *), b(ldb, *)
          Complex (Kind=dp), Intent (Inout) :: c(ldc, *)
        End Subroutine
        Subroutine zherk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: k, lda, ldc, n
          Character (1), Intent (In) :: trans, uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: a(lda, *)
          Complex (Kind=dp), Intent (Inout) :: c(ldc, *)
        End Subroutine
        Subroutine zhpmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: incx, incy, n
          Character (1), Intent (In) :: uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: ap(*), x(*)
          Complex (Kind=dp), Intent (Inout) :: y(*)
        End Subroutine
        Subroutine zhpr(uplo, n, alpha, x, incx, ap)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Real (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: incx, n
          Character (1), Intent (In) :: uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (Inout) :: ap(*)
          Complex (Kind=dp), Intent (In) :: x(*)
        End Subroutine
        Subroutine zhpr2(uplo, n, alpha, x, incx, y, incy, ap)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: incx, incy, n
          Character (1), Intent (In) :: uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (Inout) :: ap(*)
          Complex (Kind=dp), Intent (In) :: x(*), y(*)
        End Subroutine
        Subroutine zscal(n, alpha, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: incx, n
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (Inout) :: x(*)
        End Subroutine
        Subroutine zsctr(nz, x, indx, y)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: nz
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: x(*)
          Complex (Kind=dp), Intent (Inout) :: y(*)
          Integer, Intent (In) :: indx(*)
        End Subroutine
        Subroutine zswap(n, x, incx, y, incy)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, incy, n
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (Inout) :: x(*), y(*)
        End Subroutine
        Subroutine zsymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, &
          ldc)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: lda, ldb, ldc, m, n
          Character (1), Intent (In) :: side, uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: a(lda, *), b(ldb, *)
          Complex (Kind=dp), Intent (Inout) :: c(ldc, *)
        End Subroutine
        Subroutine zsyr2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, &
          ldc)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: k, lda, ldb, ldc, n
          Character (1), Intent (In) :: trans, uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: a(lda, *), b(ldb, *)
          Complex (Kind=dp), Intent (Inout) :: c(ldc, *)
        End Subroutine
        Subroutine zsyrk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: alpha, beta
          Integer, Intent (In) :: k, lda, ldc, n
          Character (1), Intent (In) :: trans, uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: a(lda, *)
          Complex (Kind=dp), Intent (Inout) :: c(ldc, *)
        End Subroutine
        Subroutine ztbmv(uplo, trans, diag, n, k, a, lda, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, k, lda, n
          Character (1), Intent (In) :: diag, trans, uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: a(lda, *)
          Complex (Kind=dp), Intent (Inout) :: x(*)
        End Subroutine
        Subroutine ztbsv(uplo, trans, diag, n, k, a, lda, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, k, lda, n
          Character (1), Intent (In) :: diag, trans, uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: a(lda, *)
          Complex (Kind=dp), Intent (Inout) :: x(*)
        End Subroutine
        Subroutine ztpmv(uplo, trans, diag, n, ap, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, n
          Character (1), Intent (In) :: diag, trans, uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: ap(*)
          Complex (Kind=dp), Intent (Inout) :: x(*)
        End Subroutine
        Subroutine ztpsv(uplo, trans, diag, n, ap, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, n
          Character (1), Intent (In) :: diag, trans, uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: ap(*)
          Complex (Kind=dp), Intent (Inout) :: x(*)
        End Subroutine
        Subroutine ztrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, &
          ldb)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: lda, ldb, m, n
          Character (1), Intent (In) :: diag, side, transa, uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: a(lda, *)
          Complex (Kind=dp), Intent (Inout) :: b(ldb, *)
        End Subroutine
        Subroutine ztrmv(uplo, trans, diag, n, a, lda, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, lda, n
          Character (1), Intent (In) :: diag, trans, uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: a(lda, *)
          Complex (Kind=dp), Intent (Inout) :: x(*)
        End Subroutine
        Subroutine ztrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, &
          ldb)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Complex (Kind=dp), Intent (In) :: alpha
          Integer, Intent (In) :: lda, ldb, m, n
          Character (1), Intent (In) :: diag, side, transa, uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: a(lda, *)
          Complex (Kind=dp), Intent (Inout) :: b(ldb, *)
        End Subroutine
        Subroutine ztrsv(uplo, trans, diag, n, a, lda, x, incx)
!         .. Use Statements ..
          Use lapack_precision, Only: dp
!         .. Implicit None Statement ..
          Implicit None
!         .. Scalar Arguments ..
          Integer, Intent (In) :: incx, lda, n
          Character (1), Intent (In) :: diag, trans, uplo
!         .. Array Arguments ..
          Complex (Kind=dp), Intent (In) :: a(lda, *)
          Complex (Kind=dp), Intent (Inout) :: x(*)
        End Subroutine
      End Interface
    End Module


program test_spectral_interpolation_ipol_1

use kind_values, only:  wp => kind_swd_internal
use spectral_interpolation_def, only: spectral_interpolation

implicit none

! This program tests the ipol=1 temporal scheme

! Dummy polynomial: f(t) = a0 + a1*t + a2*t**2 + a3*t**3
complex(wp), parameter :: a0 = cmplx(0.156_wp, 0.17_wp, wp)
complex(wp), parameter :: a1 = cmplx(1.234_wp, -0.54_wp, wp)
complex(wp), parameter :: a2 = cmplx(-2.34_wp, 0.154_wp, wp)
complex(wp), parameter :: a3 = cmplx(-0.18_wp, -0.25_wp, wp)

real(wp), parameter :: delta_t = 0.34_wp
real(wp), parameter :: t_im1 = 0.15_wp
real(wp), parameter :: t_i = t_im1 + delta_t
real(wp), parameter :: t_ip1 = t_i + delta_t
real(wp), parameter :: t_ip2 = t_ip1 + delta_t

type(spectral_interpolation) :: si
real(wp) :: t, delta
complex(wp) :: c1, dc1, c2, dc2
complex(wp) :: f_im1, f_i, f_ip1, f_ip2
complex(wp) :: df_im1, df_i, df_ip1, df_ip2

integer :: ipol, i, ierr, n_error = 0
real(wp), parameter :: deltas(5) = [0.0_wp, 0.29_wp, 0.64_wp, 0.84_wp, 1.0_wp]

print*, " Test of ipol=1..."
ipol = 1
call si % construct(ipol, delta_t, ierr)
if (ierr /= 0) then
    print *, "Unknown interpolation scheme: ", ipol
    stop
end if
f_im1 = 1.0e12  ! Not used
f_i = f3(t_i)
f_ip1 = f3(t_ip1)
f_ip2 = 1.0e12  ! Not used
df_im1 = 1.0e12  ! Not used
df_i = df3(t_i)
df_ip1 = df3(t_ip1)
df_ip2 = 1.0e12  ! Not used

do i = 1, size(deltas)
    delta = deltas(i)
    t = t_i + delta * delta_t
    c1 = f3(t)
    dc1 = df3(t)
    call si % scheme(delta, &
                     f_im1, f_i, f_ip1, f_ip2, &
                     df_im1, df_i, df_ip1, df_ip2, &
                     c2, dc2)
    print*, "Delta = ", delta
    print*, "Compare function values: ", c1, c2, compare(c1, c2)
    print*, "Compare function derivatives: ", dc1, dc2, compare(dc1, dc2)
    if (i==1) then
        print*, "f_i, df_i: ", f_i, df_i
        print*, compare(c2, f_i)
        print*, compare(dc2, df_i)
    else if (i==size(deltas)) then
        print*, "f_ip1, df_ip1: ", f_ip1, df_ip1
        print*, compare(c2, f_ip1)
        print*, compare(dc2, df_ip1)
    end if
end do

print*, "Number of detected ERRORs = ", n_error

contains

function f3(t) result(res)
real(wp), intent(in) :: t
complex(wp) res
res = a0 + a1 * t + a2 * t**2 + a3 * t**3
end function f3

function df3(t) result(res)
real(wp), intent(in) :: t
complex(wp) res
res = a1 + 2.0_wp * a2 * t + 3.0_wp * a3 * t**2
end function df3

function compare(c1, c2) result(res)
complex(wp), intent(in) :: c1, c2
character(len=10) res
real(wp), parameter :: eps = 100*epsilon(eps)
if (abs(c1 % re - c2 % re) > eps * max(abs(c1 % re), abs(c2 % re)) .or. &
    abs(c1 % im - c2 % im) > eps * max(abs(c1 % im), abs(c2 % im))) then
    res = "ERROR!"
    n_error = n_error + 1
else
    res = "OK"
end if
end function compare

end program test_spectral_interpolation_ipol_1


*DECK CEXPRL
      COMPLEX FUNCTION CEXPRL (Z)
C***BEGIN PROLOGUE  CEXPRL
C***PURPOSE  Calculate the relative error exponential (EXP(X)-1)/X.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4B
C***TYPE      COMPLEX (EXPREL-S, DEXPRL-D, CEXPRL-C)
C***KEYWORDS  ELEMENTARY FUNCTIONS, EXPONENTIAL, FIRST ORDER, FNLIB
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate  (EXP(Z)-1)/Z .  For small ABS(Z), we use the Taylor
C series.  We could instead use the expression
C        CEXPRL(Z) = (EXP(X)*EXP(I*Y)-1)/Z
C                  = (X*EXPREL(X) * (1 - 2*SIN(Y/2)**2) - 2*SIN(Y/2)**2
C                                    + I*SIN(Y)*(1+X*EXPREL(X))) / Z
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R1MACH
C***REVISION HISTORY  (YYMMDD)
C   770801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  CEXPRL
      COMPLEX Z
      LOGICAL FIRST
      SAVE NTERMS, RBND, FIRST
      DATA FIRST / .TRUE. /
C***FIRST EXECUTABLE STATEMENT  CEXPRL
      IF (FIRST) THEN
         ALNEPS = LOG(R1MACH(3))
         XN = 3.72 - 0.3*ALNEPS
         XLN = LOG((XN+1.0)/1.36)
         NTERMS = XN - (XN*XLN+ALNEPS)/(XLN+1.36) + 1.5
         RBND = R1MACH(3)
      ENDIF
      FIRST = .FALSE.
C
      R = ABS(Z)
      IF (R.GT.0.5) CEXPRL = (EXP(Z) - 1.0) / Z
      IF (R.GT.0.5) RETURN
C
      CEXPRL = (1.0, 0.0)
      IF (R.LT.RBND) RETURN
C
      CEXPRL = (0.0, 0.0)
      DO 20 I=1,NTERMS
        CEXPRL = 1.0 + CEXPRL*Z/(NTERMS+2-I)
 20   CONTINUE
C
      RETURN
      END


*> \brief \b DBDSVDX
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DBDSVDX + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*     SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
*    $                    NS, S, Z, LDZ, WORK, IWORK, INFO )
*
*     .. Scalar Arguments ..
*      CHARACTER          JOBZ, RANGE, UPLO
*      INTEGER            IL, INFO, IU, LDZ, N, NS
*      DOUBLE PRECISION   VL, VU
*     ..
*     .. Array Arguments ..
*      INTEGER            IWORK( * )
*      DOUBLE PRECISION   D( * ), E( * ), S( * ), WORK( * ),
*                         Z( LDZ, * )
*       ..
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>  DBDSVDX computes the singular value decomposition (SVD) of a real
*>  N-by-N (upper or lower) bidiagonal matrix B, B = U * S * VT,
*>  where S is a diagonal matrix with non-negative diagonal elements
*>  (the singular values of B), and U and VT are orthogonal matrices
*>  of left and right singular vectors, respectively.
*>
*>  Given an upper bidiagonal B with diagonal D = [ d_1 d_2 ... d_N ]
*>  and superdiagonal E = [ e_1 e_2 ... e_N-1 ], DBDSVDX computes the
*>  singular value decompositon of B through the eigenvalues and
*>  eigenvectors of the N*2-by-N*2 tridiagonal matrix
*>
*>        |  0  d_1                |
*>        | d_1  0  e_1            |
*>  TGK = |     e_1  0  d_2        |
*>        |         d_2  .   .     |
*>        |              .   .   . |
*>
*>  If (s,u,v) is a singular triplet of B with ||u|| = ||v|| = 1, then
*>  (+/-s,q), ||q|| = 1, are eigenpairs of TGK, with q = P * ( u' +/-v' ) /
*>  sqrt(2) = ( v_1 u_1 v_2 u_2 ... v_n u_n ) / sqrt(2), and
*>  P = [ e_{n+1} e_{1} e_{n+2} e_{2} ... ].
*>
*>  Given a TGK matrix, one can either a) compute -s,-v and change signs
*>  so that the singular values (and corresponding vectors) are already in
*>  descending order (as in DGESVD/DGESDD) or b) compute s,v and reorder
*>  the values (and corresponding vectors). DBDSVDX implements a) by
*>  calling DSTEVX (bisection plus inverse iteration, to be replaced
*>  with a version of the Multiple Relative Robust Representation
*>  algorithm. (See P. Willems and B. Lang, A framework for the MR^3
*>  algorithm: theory and implementation, SIAM J. Sci. Comput.,
*>  35:740-766, 2013.)
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          = 'U':  B is upper bidiagonal;
*>          = 'L':  B is lower bidiagonal.
*> \endverbatim
*>
*> \param[in] JOBZ
*> \verbatim
*>          JOBZ is CHARACTER*1
*>          = 'N':  Compute singular values only;
*>          = 'V':  Compute singular values and singular vectors.
*> \endverbatim
*>
*> \param[in] RANGE
*> \verbatim
*>          RANGE is CHARACTER*1
*>          = 'A': all singular values will be found.
*>          = 'V': all singular values in the half-open interval [VL,VU)
*>                 will be found.
*>          = 'I': the IL-th through IU-th singular values will be found.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the bidiagonal matrix.  N >= 0.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is DOUBLE PRECISION array, dimension (N)
*>          The n diagonal elements of the bidiagonal matrix B.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*>          E is DOUBLE PRECISION array, dimension (max(1,N-1))
*>          The (n-1) superdiagonal elements of the bidiagonal matrix
*>          B in elements 1 to N-1.
*> \endverbatim
*>
*> \param[in] VL
*> \verbatim
*>         VL is DOUBLE PRECISION
*>          If RANGE='V', the lower bound of the interval to
*>          be searched for singular values. VU > VL.
*>          Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] VU
*> \verbatim
*>         VU is DOUBLE PRECISION
*>          If RANGE='V', the upper bound of the interval to
*>          be searched for singular values. VU > VL.
*>          Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] IL
*> \verbatim
*>          IL is INTEGER
*>          If RANGE='I', the index of the
*>          smallest singular value to be returned.
*>          1 <= IL <= IU <= min(M,N), if min(M,N) > 0.
*>          Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] IU
*> \verbatim
*>          IU is INTEGER
*>          If RANGE='I', the index of the
*>          largest singular value to be returned.
*>          1 <= IL <= IU <= min(M,N), if min(M,N) > 0.
*>          Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[out] NS
*> \verbatim
*>          NS is INTEGER
*>          The total number of singular values found.  0 <= NS <= N.
*>          If RANGE = 'A', NS = N, and if RANGE = 'I', NS = IU-IL+1.
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*>          S is DOUBLE PRECISION array, dimension (N)
*>          The first NS elements contain the selected singular values in
*>          ascending order.
*> \endverbatim
*>
*> \param[out] Z
*> \verbatim
*>          Z is DOUBLE PRECISION array, dimension (2*N,K) )
*>          If JOBZ = 'V', then if INFO = 0 the first NS columns of Z
*>          contain the singular vectors of the matrix B corresponding to
*>          the selected singular values, with U in rows 1 to N and V
*>          in rows N+1 to N*2, i.e.
*>          Z = [ U ]
*>              [ V ]
*>          If JOBZ = 'N', then Z is not referenced.
*>          Note: The user must ensure that at least K = NS+1 columns are
*>          supplied in the array Z; if RANGE = 'V', the exact value of
*>          NS is not known in advance and an upper bound must be used.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*>          LDZ is INTEGER
*>          The leading dimension of the array Z. LDZ >= 1, and if
*>          JOBZ = 'V', LDZ >= max(2,N*2).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (14*N)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (12*N)
*>          If JOBZ = 'V', then if INFO = 0, the first NS elements of
*>          IWORK are zero. If INFO > 0, then IWORK contains the indices
*>          of the eigenvectors that failed to converge in DSTEVX.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*>          > 0:  if INFO = i, then i eigenvectors failed to converge
*>                   in DSTEVX. The indices of the eigenvectors
*>                   (as returned by DSTEVX) are stored in the
*>                   array IWORK.
*>                if INFO = N*2 + 1, an internal error occurred.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup doubleOTHEReigen
*
*  =====================================================================
      SUBROUTINE DBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
     $                    NS, S, Z, LDZ, WORK, IWORK, INFO)
*
*  -- LAPACK driver routine (version 3.8.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2017
*
*     .. Scalar Arguments ..
      CHARACTER          JOBZ, RANGE, UPLO
      INTEGER            IL, INFO, IU, LDZ, N, NS
      DOUBLE PRECISION   VL, VU
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   D( * ), E( * ), S( * ), WORK( * ),
     $                   Z( LDZ, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TEN, HNDRD, MEIGTH
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0,
     $                     HNDRD = 100.0D0, MEIGTH = -0.1250D0 )
      DOUBLE PRECISION   FUDGE
      PARAMETER          ( FUDGE = 2.0D0 )
*     ..
*     .. Local Scalars ..
      CHARACTER          RNGVX
      LOGICAL            ALLSV, INDSV, LOWER, SPLIT, SVEQ0, VALSV, WANTZ
      INTEGER            I, ICOLZ, IDBEG, IDEND, IDTGK, IDPTR, IEPTR,
     $                   IETGK, IIFAIL, IIWORK, ILTGK, IROWU, IROWV,
     $                   IROWZ, ISBEG, ISPLT, ITEMP, IUTGK, J, K,
     $                   NTGK, NRU, NRV, NSL
      DOUBLE PRECISION   ABSTOL, EPS, EMIN, MU, NRMU, NRMV, ORTOL, SMAX,
     $                   SMIN, SQRT2, THRESH, TOL, ULP,
     $                   VLTGK, VUTGK, ZJTJI
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DDOT, DLAMCH, DNRM2
      EXTERNAL           IDAMAX, LSAME, DAXPY, DDOT, DLAMCH, DNRM2
*     ..
*     .. External Subroutines ..
      EXTERNAL           DSTEVX, DCOPY, DLASET, DSCAL, DSWAP, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, SIGN, SQRT
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      ALLSV = LSAME( RANGE, 'A' )
      VALSV = LSAME( RANGE, 'V' )
      INDSV = LSAME( RANGE, 'I' )
      WANTZ = LSAME( JOBZ, 'V' )
      LOWER = LSAME( UPLO, 'L' )
*
      INFO = 0
      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN
         INFO = -1
      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( ALLSV .OR. VALSV .OR. INDSV ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( N.GT.0 ) THEN
         IF( VALSV ) THEN
            IF( VL.LT.ZERO ) THEN
               INFO = -7
            ELSE IF( VU.LE.VL ) THEN
               INFO = -8
            END IF
         ELSE IF( INDSV ) THEN
            IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
               INFO = -9
            ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
               INFO = -10
            END IF
         END IF
      END IF
      IF( INFO.EQ.0 ) THEN
         IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N*2 ) ) INFO = -14
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DBDSVDX', -INFO )
         RETURN
      END IF
*
*     Quick return if possible (N.LE.1)
*
      NS = 0
      IF( N.EQ.0 ) RETURN
*
      IF( N.EQ.1 ) THEN
         IF( ALLSV .OR. INDSV ) THEN
            NS = 1
            S( 1 ) = ABS( D( 1 ) )
         ELSE
            IF( VL.LT.ABS( D( 1 ) ) .AND. VU.GE.ABS( D( 1 ) ) ) THEN
               NS = 1
               S( 1 ) = ABS( D( 1 ) )
            END IF
         END IF
         IF( WANTZ ) THEN
            Z( 1, 1 ) = SIGN( ONE, D( 1 ) )
            Z( 2, 1 ) = ONE
         END IF
         RETURN
      END IF
*
      ABSTOL = 2*DLAMCH( 'Safe Minimum' )
      ULP = DLAMCH( 'Precision' )
      EPS = DLAMCH( 'Epsilon' )
      SQRT2 = SQRT( 2.0D0 )
      ORTOL = SQRT( ULP )
*
*     Criterion for splitting is taken from DBDSQR when singular
*     values are computed to relative accuracy TOL. (See J. Demmel and
*     W. Kahan, Accurate singular values of bidiagonal matrices, SIAM
*     J. Sci. and Stat. Comput., 11:873–912, 1990.)
*
      TOL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )*EPS
*
*     Compute approximate maximum, minimum singular values.
*
      I = IDAMAX( N, D, 1 )
      SMAX = ABS( D( I ) )
      I = IDAMAX( N-1, E, 1 )
      SMAX = MAX( SMAX, ABS( E( I ) ) )
*
*     Compute threshold for neglecting D's and E's.
*
      SMIN = ABS( D( 1 ) )
      IF( SMIN.NE.ZERO ) THEN
         MU = SMIN
         DO I = 2, N
            MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) )
            SMIN = MIN( SMIN, MU )
            IF( SMIN.EQ.ZERO ) EXIT
         END DO
      END IF
      SMIN = SMIN / SQRT( DBLE( N ) )
      THRESH = TOL*SMIN
*
*     Check for zeros in D and E (splits), i.e. submatrices.
*
      DO I = 1, N-1
         IF( ABS( D( I ) ).LE.THRESH ) D( I ) = ZERO
         IF( ABS( E( I ) ).LE.THRESH ) E( I ) = ZERO
      END DO
      IF( ABS( D( N ) ).LE.THRESH ) D( N ) = ZERO
*
*     Pointers for arrays used by DSTEVX.
*
      IDTGK = 1
      IETGK = IDTGK + N*2
      ITEMP = IETGK + N*2
      IIFAIL = 1
      IIWORK = IIFAIL + N*2
*
*     Set RNGVX, which corresponds to RANGE for DSTEVX in TGK mode.
*     VL,VU or IL,IU are redefined to conform to implementation a)
*     described in the leading comments.
*
      ILTGK = 0
      IUTGK = 0
      VLTGK = ZERO
      VUTGK = ZERO
*
      IF( ALLSV ) THEN
*
*        All singular values will be found. We aim at -s (see
*        leading comments) with RNGVX = 'I'. IL and IU are set
*        later (as ILTGK and IUTGK) according to the dimension
*        of the active submatrix.
*
         RNGVX = 'I'
         IF( WANTZ ) CALL DLASET( 'F', N*2, N+1, ZERO, ZERO, Z, LDZ )
      ELSE IF( VALSV ) THEN
*
*        Find singular values in a half-open interval. We aim
*        at -s (see leading comments) and we swap VL and VU
*        (as VUTGK and VLTGK), changing their signs.
*
         RNGVX = 'V'
         VLTGK = -VU
         VUTGK = -VL
         WORK( IDTGK:IDTGK+2*N-1 ) = ZERO
         CALL DCOPY( N, D, 1, WORK( IETGK ), 2 )
         CALL DCOPY( N-1, E, 1, WORK( IETGK+1 ), 2 )
         CALL DSTEVX( 'N', 'V', N*2, WORK( IDTGK ), WORK( IETGK ),
     $                VLTGK, VUTGK, ILTGK, ILTGK, ABSTOL, NS, S,
     $                Z, LDZ, WORK( ITEMP ), IWORK( IIWORK ),
     $                IWORK( IIFAIL ), INFO )
         IF( NS.EQ.0 ) THEN
            RETURN
         ELSE
            IF( WANTZ ) CALL DLASET( 'F', N*2, NS, ZERO, ZERO, Z, LDZ )
         END IF
      ELSE IF( INDSV ) THEN
*
*        Find the IL-th through the IU-th singular values. We aim
*        at -s (see leading comments) and indices are mapped into
*        values, therefore mimicking DSTEBZ, where
*
*        GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN
*        GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN
*
         ILTGK = IL
         IUTGK = IU
         RNGVX = 'V'
         WORK( IDTGK:IDTGK+2*N-1 ) = ZERO
         CALL DCOPY( N, D, 1, WORK( IETGK ), 2 )
         CALL DCOPY( N-1, E, 1, WORK( IETGK+1 ), 2 )
         CALL DSTEVX( 'N', 'I', N*2, WORK( IDTGK ), WORK( IETGK ),
     $                VLTGK, VLTGK, ILTGK, ILTGK, ABSTOL, NS, S,
     $                Z, LDZ, WORK( ITEMP ), IWORK( IIWORK ),
     $                IWORK( IIFAIL ), INFO )
         VLTGK = S( 1 ) - FUDGE*SMAX*ULP*N
         WORK( IDTGK:IDTGK+2*N-1 ) = ZERO
         CALL DCOPY( N, D, 1, WORK( IETGK ), 2 )
         CALL DCOPY( N-1, E, 1, WORK( IETGK+1 ), 2 )
         CALL DSTEVX( 'N', 'I', N*2, WORK( IDTGK ), WORK( IETGK ),
     $                VUTGK, VUTGK, IUTGK, IUTGK, ABSTOL, NS, S,
     $                Z, LDZ, WORK( ITEMP ), IWORK( IIWORK ),
     $                IWORK( IIFAIL ), INFO )
         VUTGK = S( 1 ) + FUDGE*SMAX*ULP*N
         VUTGK = MIN( VUTGK, ZERO )
*
*        If VLTGK=VUTGK, DSTEVX returns an error message,
*        so if needed we change VUTGK slightly.
*
         IF( VLTGK.EQ.VUTGK ) VLTGK = VLTGK - TOL
*
         IF( WANTZ ) CALL DLASET( 'F', N*2, IU-IL+1, ZERO, ZERO, Z, LDZ)
      END IF
*
*     Initialize variables and pointers for S, Z, and WORK.
*
*     NRU, NRV: number of rows in U and V for the active submatrix
*     IDBEG, ISBEG: offsets for the entries of D and S
*     IROWZ, ICOLZ: offsets for the rows and columns of Z
*     IROWU, IROWV: offsets for the rows of U and V
*
      NS = 0
      NRU = 0
      NRV = 0
      IDBEG = 1
      ISBEG = 1
      IROWZ = 1
      ICOLZ = 1
      IROWU = 2
      IROWV = 1
      SPLIT = .FALSE.
      SVEQ0 = .FALSE.
*
*     Form the tridiagonal TGK matrix.
*
      S( 1:N ) = ZERO
      WORK( IETGK+2*N-1 ) = ZERO
      WORK( IDTGK:IDTGK+2*N-1 ) = ZERO
      CALL DCOPY( N, D, 1, WORK( IETGK ), 2 )
      CALL DCOPY( N-1, E, 1, WORK( IETGK+1 ), 2 )
*
*
*     Check for splits in two levels, outer level
*     in E and inner level in D.
*
      DO IEPTR = 2, N*2, 2
         IF( WORK( IETGK+IEPTR-1 ).EQ.ZERO ) THEN
*
*           Split in E (this piece of B is square) or bottom
*           of the (input bidiagonal) matrix.
*
            ISPLT = IDBEG
            IDEND = IEPTR - 1
            DO IDPTR = IDBEG, IDEND, 2
               IF( WORK( IETGK+IDPTR-1 ).EQ.ZERO ) THEN
*
*                 Split in D (rectangular submatrix). Set the number
*                 of rows in U and V (NRU and NRV) accordingly.
*
                  IF( IDPTR.EQ.IDBEG ) THEN
*
*                    D=0 at the top.
*
                     SVEQ0 = .TRUE.
                     IF( IDBEG.EQ.IDEND) THEN
                        NRU = 1
                        NRV = 1
                     END IF
                  ELSE IF( IDPTR.EQ.IDEND ) THEN
*
*                    D=0 at the bottom.
*
                     SVEQ0 = .TRUE.
                     NRU = (IDEND-ISPLT)/2 + 1
                     NRV = NRU
                     IF( ISPLT.NE.IDBEG ) THEN
                        NRU = NRU + 1
                     END IF
                  ELSE
                     IF( ISPLT.EQ.IDBEG ) THEN
*
*                       Split: top rectangular submatrix.
*
                        NRU = (IDPTR-IDBEG)/2
                        NRV = NRU + 1
                     ELSE
*
*                       Split: middle square submatrix.
*
                        NRU = (IDPTR-ISPLT)/2 + 1
                        NRV = NRU
                     END IF
                  END IF
               ELSE IF( IDPTR.EQ.IDEND ) THEN
*
*                 Last entry of D in the active submatrix.
*
                  IF( ISPLT.EQ.IDBEG ) THEN
*
*                    No split (trivial case).
*
                     NRU = (IDEND-IDBEG)/2 + 1
                     NRV = NRU
                  ELSE
*
*                    Split: bottom rectangular submatrix.
*
                     NRV = (IDEND-ISPLT)/2 + 1
                     NRU = NRV + 1
                  END IF
               END IF
*
               NTGK = NRU + NRV
*
               IF( NTGK.GT.0 ) THEN
*
*                 Compute eigenvalues/vectors of the active
*                 submatrix according to RANGE:
*                 if RANGE='A' (ALLSV) then RNGVX = 'I'
*                 if RANGE='V' (VALSV) then RNGVX = 'V'
*                 if RANGE='I' (INDSV) then RNGVX = 'V'
*
                  ILTGK = 1
                  IUTGK = NTGK / 2
                  IF( ALLSV .OR. VUTGK.EQ.ZERO ) THEN
                     IF( SVEQ0 .OR.
     $                   SMIN.LT.EPS .OR.
     $                   MOD(NTGK,2).GT.0 ) THEN
*                        Special case: eigenvalue equal to zero or very
*                        small, additional eigenvector is needed.
                         IUTGK = IUTGK + 1
                     END IF
                  END IF
*
*                 Workspace needed by DSTEVX:
*                 WORK( ITEMP: ): 2*5*NTGK
*                 IWORK( 1: ): 2*6*NTGK
*
                  CALL DSTEVX( JOBZ, RNGVX, NTGK, WORK( IDTGK+ISPLT-1 ),
     $                         WORK( IETGK+ISPLT-1 ), VLTGK, VUTGK,
     $                         ILTGK, IUTGK, ABSTOL, NSL, S( ISBEG ),
     $                         Z( IROWZ,ICOLZ ), LDZ, WORK( ITEMP ),
     $                         IWORK( IIWORK ), IWORK( IIFAIL ),
     $                         INFO )
                  IF( INFO.NE.0 ) THEN
*                    Exit with the error code from DSTEVX.
                     RETURN
                  END IF
                  EMIN = ABS( MAXVAL( S( ISBEG:ISBEG+NSL-1 ) ) )
*
                  IF( NSL.GT.0 .AND. WANTZ ) THEN
*
*                    Normalize u=Z([2,4,...],:) and v=Z([1,3,...],:),
*                    changing the sign of v as discussed in the leading
*                    comments. The norms of u and v may be (slightly)
*                    different from 1/sqrt(2) if the corresponding
*                    eigenvalues are very small or too close. We check
*                    those norms and, if needed, reorthogonalize the
*                    vectors.
*
                     IF( NSL.GT.1 .AND.
     $                   VUTGK.EQ.ZERO .AND.
     $                   MOD(NTGK,2).EQ.0 .AND.
     $                   EMIN.EQ.0 .AND. .NOT.SPLIT ) THEN
*
*                       D=0 at the top or bottom of the active submatrix:
*                       one eigenvalue is equal to zero; concatenate the
*                       eigenvectors corresponding to the two smallest
*                       eigenvalues.
*
                        Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-2 ) =
     $                  Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-2 ) +
     $                  Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-1 )
                        Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-1 ) =
     $                  ZERO
*                       IF( IUTGK*2.GT.NTGK ) THEN
*                          Eigenvalue equal to zero or very small.
*                          NSL = NSL - 1
*                       END IF
                     END IF
*
                     DO I = 0, MIN( NSL-1, NRU-1 )
                        NRMU = DNRM2( NRU, Z( IROWU, ICOLZ+I ), 2 )
                        IF( NRMU.EQ.ZERO ) THEN
                           INFO = N*2 + 1
                           RETURN
                        END IF
                        CALL DSCAL( NRU, ONE/NRMU,
     $                              Z( IROWU,ICOLZ+I ), 2 )
                        IF( NRMU.NE.ONE .AND.
     $                      ABS( NRMU-ORTOL )*SQRT2.GT.ONE )
     $                      THEN
                           DO J = 0, I-1
                              ZJTJI = -DDOT( NRU, Z( IROWU, ICOLZ+J ),
     $                                       2, Z( IROWU, ICOLZ+I ), 2 )
                              CALL DAXPY( NRU, ZJTJI,
     $                                    Z( IROWU, ICOLZ+J ), 2,
     $                                    Z( IROWU, ICOLZ+I ), 2 )
                           END DO
                           NRMU = DNRM2( NRU, Z( IROWU, ICOLZ+I ), 2 )
                           CALL DSCAL( NRU, ONE/NRMU,
     $                                 Z( IROWU,ICOLZ+I ), 2 )
                        END IF
                     END DO
                     DO I = 0, MIN( NSL-1, NRV-1 )
                        NRMV = DNRM2( NRV, Z( IROWV, ICOLZ+I ), 2 )
                        IF( NRMV.EQ.ZERO ) THEN
                           INFO = N*2 + 1
                           RETURN
                        END IF
                        CALL DSCAL( NRV, -ONE/NRMV,
     $                              Z( IROWV,ICOLZ+I ), 2 )
                        IF( NRMV.NE.ONE .AND.
     $                      ABS( NRMV-ORTOL )*SQRT2.GT.ONE )
     $                      THEN
                           DO J = 0, I-1
                              ZJTJI = -DDOT( NRV, Z( IROWV, ICOLZ+J ),
     $                                       2, Z( IROWV, ICOLZ+I ), 2 )
                              CALL DAXPY( NRU, ZJTJI,
     $                                    Z( IROWV, ICOLZ+J ), 2,
     $                                    Z( IROWV, ICOLZ+I ), 2 )
                           END DO
                           NRMV = DNRM2( NRV, Z( IROWV, ICOLZ+I ), 2 )
                           CALL DSCAL( NRV, ONE/NRMV,
     $                                 Z( IROWV,ICOLZ+I ), 2 )
                        END IF
                     END DO
                     IF( VUTGK.EQ.ZERO .AND.
     $                   IDPTR.LT.IDEND .AND.
     $                   MOD(NTGK,2).GT.0 ) THEN
*
*                       D=0 in the middle of the active submatrix (one
*                       eigenvalue is equal to zero): save the corresponding
*                       eigenvector for later use (when bottom of the
*                       active submatrix is reached).
*
                        SPLIT = .TRUE.
                        Z( IROWZ:IROWZ+NTGK-1,N+1 ) =
     $                     Z( IROWZ:IROWZ+NTGK-1,NS+NSL )
                        Z( IROWZ:IROWZ+NTGK-1,NS+NSL ) =
     $                     ZERO
                     END IF
                  END IF !** WANTZ **!
*
                  NSL = MIN( NSL, NRU )
                  SVEQ0 = .FALSE.
*
*                 Absolute values of the eigenvalues of TGK.
*
                  DO I = 0, NSL-1
                     S( ISBEG+I ) = ABS( S( ISBEG+I ) )
                  END DO
*
*                 Update pointers for TGK, S and Z.
*
                  ISBEG = ISBEG + NSL
                  IROWZ = IROWZ + NTGK
                  ICOLZ = ICOLZ + NSL
                  IROWU = IROWZ
                  IROWV = IROWZ + 1
                  ISPLT = IDPTR + 1
                  NS = NS + NSL
                  NRU = 0
                  NRV = 0
               END IF !** NTGK.GT.0 **!
               IF( IROWZ.LT.N*2 .AND. WANTZ ) THEN
                  Z( 1:IROWZ-1, ICOLZ ) = ZERO
               END IF
            END DO !** IDPTR loop **!
            IF( SPLIT .AND. WANTZ ) THEN
*
*              Bring back eigenvector corresponding
*              to eigenvalue equal to zero.
*
               Z( IDBEG:IDEND-NTGK+1,ISBEG-1 ) =
     $         Z( IDBEG:IDEND-NTGK+1,ISBEG-1 ) +
     $         Z( IDBEG:IDEND-NTGK+1,N+1 )
               Z( IDBEG:IDEND-NTGK+1,N+1 ) = 0
            END IF
            IROWV = IROWV - 1
            IROWU = IROWU + 1
            IDBEG = IEPTR + 1
            SVEQ0 = .FALSE.
            SPLIT = .FALSE.
         END IF !** Check for split in E **!
      END DO !** IEPTR loop **!
*
*     Sort the singular values into decreasing order (insertion sort on
*     singular values, but only one transposition per singular vector)
*
      DO I = 1, NS-1
         K = 1
         SMIN = S( 1 )
         DO J = 2, NS + 1 - I
            IF( S( J ).LE.SMIN ) THEN
               K = J
               SMIN = S( J )
            END IF
         END DO
         IF( K.NE.NS+1-I ) THEN
            S( K ) = S( NS+1-I )
            S( NS+1-I ) = SMIN
            IF( WANTZ ) CALL DSWAP( N*2, Z( 1,K ), 1, Z( 1,NS+1-I ), 1 )
         END IF
      END DO
*
*     If RANGE=I, check for singular values/vectors to be discarded.
*
      IF( INDSV ) THEN
         K = IU - IL + 1
         IF( K.LT.NS ) THEN
            S( K+1:NS ) = ZERO
            IF( WANTZ ) Z( 1:N*2,K+1:NS ) = ZERO
            NS = K
         END IF
      END IF
*
*     Reorder Z: U = Z( 1:N,1:NS ), V = Z( N+1:N*2,1:NS ).
*     If B is a lower diagonal, swap U and V.
*
      IF( WANTZ ) THEN
      DO I = 1, NS
         CALL DCOPY( N*2, Z( 1,I ), 1, WORK, 1 )
         IF( LOWER ) THEN
            CALL DCOPY( N, WORK( 2 ), 2, Z( N+1,I ), 1 )
            CALL DCOPY( N, WORK( 1 ), 2, Z( 1  ,I ), 1 )
         ELSE
            CALL DCOPY( N, WORK( 2 ), 2, Z( 1  ,I ), 1 )
            CALL DCOPY( N, WORK( 1 ), 2, Z( N+1,I ), 1 )
         END IF
      END DO
      END IF
*
      RETURN
*
*     End of DBDSVDX
*
      END


module mod_fillps

  use mod_param
  use mod_common

  implicit none

  private
  public fillps

contains

  subroutine fillps(p)
    !
    ! Fill the RHS of the Poisson equation for the correction pressure.
    !
    ! The discrete divergence is:
    !
    ! w(i,j,k)-w(i,j,k-1)   v(i,j,k)-v(i,j-1,k)   u(i,j,k)-u(i-1,j,k)
    ! ------------------- + ------------------- + -------------------  = div
    !         dz                    dy                    dx
    !
    ! Note: in this subroutine p is not the correction pressure, but
    ! the rhs of the Poisson equation, i.e.
    !
    ! p = RHS = rho0 / dt * div
    !-----------------------------------------------------------------------

    implicit none

    integer :: i,j,k,im,jm,km
    real :: coef, vel_x,vel_y,vel_z
    real, intent(out), dimension(0:,0:,0:) :: p

    coef = rho0/dt

    do k=1,kmax
       km = k-1
       do j=1,jmax
          jm = j-1
          do i=1,imax
             im = i-1

             vel_x = (dudt(i,j,k)-dudt(im,j,k))*dxi
             vel_y = (dvdt(i,j,k)-dvdt(i,jm,k))*dyi
             vel_z = (dwdt(i,j,k)-dwdt(i,j,km))*dzi

             p(i,j,k) = coef*(vel_x + vel_y + vel_z)

          enddo
       enddo
    enddo

    return
  end subroutine fillps

end module mod_fillps


c     ==================================================================
      subroutine setaux(mbc,mx,my,mz,xlower,ylower,zlower,
     &                  dx,dy,dz,maux,aux)
c     ==================================================================
c
c     # set auxiliary arrays
c
c     # acoustics in a heterogeneous medium:
c     #  aux(i,j,k,1) = impedance Z in (i,j) cell
c     #  aux(i,j,k,2) = sound speed c in (i,j) cell
c
c
      implicit double precision (a-h,o-z)
      double precision aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc,1-mbc:mz+mbc)
      common /comaux/ z1,c1,z2,c2

      do  k = 1-mbc,mz+mbc
        do j = 1-mbc,my+mbc
           do i = 1-mbc,mx+mbc
               zcell = zlower + (k-0.5d0)*dz
               if (zcell .lt. 0.d0) then
                  aux(1,i,j,k) = z1
                  aux(2,i,j,k) = c1
                else
                  aux(1,i,j,k) = z2
                  aux(2,i,j,k) = c2
                endif
           enddo
        enddo
      enddo

      return
      end


        subroutine get_elong_a(ialt_start,ialt_end,ialt_delt  &! I
                   ,jazi_start,jazi_end,jazi_delt             &! I
                   ,minalt,maxalt,minazi,maxazi               &! I
                   ,sol_alt,sol_azi,view_alt,view_az          &! I
                   ,elong                                   )  ! O

        include 'trigd.inc'

        cosunitvectors(a1,a2,a3,b1,b2,b3) = min(max(a1*b1+a2*b2+a3*b3,-1.),+1.)
        angleunitvectors(a1,a2,a3,b1,b2,b3) = acosd(cosunitvectors(a1,a2,a3,b1,b2,b3))

        real elong(minalt:maxalt,minazi:maxazi)
        real view_alt(minalt:maxalt,minazi:maxazi)
        real view_az(minalt:maxalt,minazi:maxazi)

        do ialt = ialt_start,ialt_end,ialt_delt

         altray = view_alt(ialt,jazi_start)

         do jazi = jazi_start,jazi_end,jazi_delt

          altray = view_alt(ialt,jazi)
          view_altitude_deg = altray

          view_azi_deg = view_az(ialt,jazi)

          xs = cosd(sol_alt) * cosd(sol_azi)
          ys = cosd(sol_alt) * sind(sol_azi)
          zs = sind(sol_alt)

          xo = cosd(altray) * cosd(view_azi_deg)
          yo = cosd(altray) * sind(view_azi_deg)
          zo = sind(altray)

          elong(ialt,jazi) = angleunitvectors(xs,ys,zs,xo,yo,zo)

         enddo ! jazi
        enddo ! ialt

        return
        end