  !
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
!
!     1/976
!
!     a program for testing all vector laplacian and its inverse
!
!     (1) first set the vector function (rotation about equator) using
!         v = cos(phi) and w = -cos(theta)*sin(phi)
!
!     (2) set vector laplacian ananlytically
!         vlap = -2.*cos(phi)=-2.*v, wlap = -2.*w
!         (i.e., L(v, w) = -2.*(v, w) so (v, w) is an eigenfunction for the
!         vector Laplacian with eigenvalue -2.
!
!     (3) compute the coefficients br, bi, cr, ci of (v, w) using vector analysis
!
!     (3) compute the vector laplacian of (v, w) using vlapec, vlapes, vlapgc, vlapgs
!
!     (4) compare (3) with (2)
!
!     (5) invert (4) and compare with (v, w)
!
program tvlap

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use spherepack, only: &
        ip, & ! Integer precision
        wp, & ! Working precision
        Sphere, &
        Regularsphere, &
        GaussianSphere

    ! Explicit typing only
    implicit none

    ! Dictionary
    class(Sphere), allocatable :: solver

    ! Test gaussian grid
    allocate (GaussianSphere :: solver)
    call test_vector_laplacian_routines(solver)
    deallocate (solver)

    ! Test regular grid
    allocate (RegularSphere :: solver)
    call test_vector_laplacian_routines(solver)
    deallocate (solver)

contains

    subroutine test_vector_laplacian_routines( sphere_type)

        ! Dummy arguments
        class(Sphere), intent(inout)  :: sphere_type

        ! Local variables
        integer(ip), parameter        :: NLONS = 16
        integer(ip), parameter        :: NLATS = 29
        integer(ip)                   :: i, j, k ! Counters
        real(wp)                      :: original_polar_component(NLATS, NLONS)
        real(wp)                      :: original_azimuthal_component(NLATS, NLONS)
        real(wp)                      :: exact_polar_laplacian(NLATS, NLONS)
        real(wp)                      :: exact_azimuthal_laplacian(NLATS, NLONS)
        real(wp)                      :: polar_component(NLATS, NLONS)
        real(wp)                      :: azimuthal_component(NLATS, NLONS)
        real(wp)                      :: approximate_polar_laplacian(NLATS, NLONS)
        real(wp)                      :: approximate_azimuthal_laplacian(NLATS, NLONS)
        character(len=:), allocatable :: previous_polar_laplacian_error
        character(len=:), allocatable :: previous_polar_inversion_error
        character(len=:), allocatable :: previous_azimuthal_laplacian_error
        character(len=:), allocatable :: previous_azimuthal_inversion_error

        !  Set up workspace arrays
        select type(sphere_type)
            type is (GaussianSphere)

            !  Initialize gaussian sphere object
            sphere_type = GaussianSphere(NLATS, NLONS)

            ! Allocate known error from previous platform
            allocate (previous_polar_laplacian_error, source='     polar laplacian error     = 1.761258e-12')
            allocate (previous_azimuthal_laplacian_error, source='     azimuthal laplacian error = 8.710810e-13')
            allocate (previous_polar_inversion_error, source='     polar inversion error     = 5.551115e-16')
            allocate (previous_azimuthal_inversion_error, source='     azimuthal inversion error = 7.216450e-16')

            type is (RegularSphere)

            ! Initialize regular sphere
            sphere_type = RegularSphere(NLATS, NLONS)

            ! Allocate known error from previous platform
            allocate (previous_polar_laplacian_error, source='     polar laplacian error     = 3.113065e-13')
            allocate (previous_azimuthal_laplacian_error, source='     azimuthal laplacian error = 4.702905e-13')
            allocate (previous_polar_inversion_error, source='     polar inversion error     = 5.551115e-16')
            allocate (previous_azimuthal_inversion_error, source='     azimuthal inversion error = 5.551115e-16')
        end select

        !
        !  test all vector laplacian and inverse vector laplacian subroutines
        !
        associate (&
            r => sphere_type%unit_vectors%radial, &
            phi => sphere_type%unit_vectors%azimuthal, &
            ve => original_polar_component, &
            we => original_azimuthal_component, &
            velap => exact_polar_laplacian, &
            welap => exact_azimuthal_laplacian &
           )
            do j=1, NLONS
                do i=1, NLATS
                    associate (&
                        cost => r(i, j)%z, &
                        cosp => phi(i, j)%y, &
                        sinp => -phi(i, j)%x &
                       )
                        !
                        !  set vector field v, w
                        !
                        ve(i, j) = cosp
                        we(i, j) = -cost*sinp
                        !
                        !  set vector laplacian vlap, wlap
                        !
                        velap(i, j) = -2.0_wp * ve(i, j)
                        welap(i, j) = -2.0_wp * we(i, j)
                    end associate
                end do
            end do
        end associate

        associate (&
            ve => original_polar_component, &
            we => original_azimuthal_component, &
            vlap => approximate_polar_laplacian, &
            wlap => approximate_azimuthal_laplacian &
           )
            !
            !  Compute vector laplacian
            !
            call sphere_type%get_laplacian(ve, we, vlap, wlap)

        end associate

        !
        !  Compute laplacian error
        !
        associate (&
            velap => exact_polar_laplacian, &
            welap => exact_azimuthal_laplacian, &
            vlap => approximate_polar_laplacian, &
            wlap => approximate_azimuthal_laplacian &
           )
            associate (&
                err2v => maxval(abs(vlap - velap)), &
                err2w => maxval(abs(wlap - welap)) &
               )

                !
                !  Print earlier output from platform with 64-bit floating point
                !    arithmetic followed by the output from this computer
                !
                write (stdout, '(/a/)') '     tvlap *** TEST RUN *** '
                write (stdout, '(a)') '     grid type = '//sphere_type%grid%grid_type
                write (stdout, '(a)') '     Testing vector laplacian'
                write (stdout, '(2(a, i3))') '     nlat = ', NLATS, ' nlon = ', NLONS
                write (stdout, '(a)') '     Previous 64 bit floating point arithmetic result '
                write (stdout, '(a)') previous_polar_laplacian_error
                write (stdout, '(a)') previous_azimuthal_laplacian_error
                write (stdout, '(a)') '     The output from your computer is: '
                write (stdout, '(a, 1pe15.6)') '     polar laplacian error     = ', err2v
                write (stdout, '(a, 1pe15.6/)') '     azimuthal laplacian error = ', err2w
            end associate
        end associate
        !
        !  Now recompute (v, w) inverting (velap, welap)
        !
        associate (&
            v => polar_component, &
            w => azimuthal_component, &
            velap => exact_polar_laplacian, &
            welap => exact_azimuthal_laplacian &
           )
            call sphere_type%invert_laplacian( velap, welap, v, w)
        end associate

        !
        !  compare this v, w with original
        !
        associate (&
            ve => original_polar_component, &
            we => original_azimuthal_component, &
            v => polar_component, &
            w => azimuthal_component &
           )
            associate (&
                err2v => maxval(abs(v - ve)), &
                err2w => maxval(abs(w - we)) &
               )
                !
                !  Print earlier output from platform with 64-bit floating point
                !    arithmetic followed by the output from this computer
                !
                write (stdout, '(/a/)') '     tvlap *** TEST RUN *** '
                write (stdout, '(a)') '     grid type = '//sphere_type%grid%grid_type
                write (stdout, '(a)') '     Testing vector laplacian inversion'
                write (stdout, '(2(a, i3))') '     nlat = ', NLATS, ' nlon = ', NLONS
                write (stdout, '(a)') '     Previous 64 bit floating point arithmetic result '
                write (stdout, '(a)') previous_polar_inversion_error
                write (stdout, '(a)') previous_azimuthal_inversion_error
                write (stdout, '(a)') '     The output from your computer is: '
                write (stdout, '(a, 1pe15.6)') '     polar inversion error     = ', err2v
                write (stdout, '(a, 1pe15.6/)') '     azimuthal inversion error = ', err2w
            end associate
        end associate
        !
        !  Release memory
        deallocate (previous_polar_laplacian_error)
        deallocate (previous_polar_inversion_error)
        deallocate (previous_azimuthal_laplacian_error)
        deallocate (previous_azimuthal_inversion_error)
        call sphere_type%destroy()

    end subroutine test_vector_laplacian_routines

end program tvlap


program test_fm
use types, only: dp
use constants, only: pi
use special_functions, only: Fm
use utils, only: assert
implicit none

real(dp), allocatable :: F(:), G(:)
real(dp) :: x
real(dp), parameter :: eps = 1e-15_dp
real(dp), parameter :: eps_rel = 1e-12_dp
real(dp), parameter :: xlist(23) = [0._dp, 1e-9_dp, 1e-6_dp, 0.1_dp, 0.5_dp, &
    2._dp, 10._dp, 15._dp, 19._dp, 20._dp, 21._dp, 25._dp, 30._dp, 50._dp, &
    100._dp, 150._dp, 200._dp, 500._dp, 2000._dp, 20000._dp, 2e5_dp, 2e6_dp, &
    2e8_dp]
integer :: m, maxm, i
real(dp) :: F0
! We use downward recursion with initial value 0, so maxm must be very high to
! get accurate results:
maxm = 1000
allocate(F(0:maxm), G(0:maxm))

do i = 1, size(xlist)
    x = xlist(i)
    if (x < 510) then
        call downwards(maxm, x, F)
    else
        call asympt(maxm, x, F)
    end if
    if (x < epsilon(1._dp)) then
        F0 = 1
    else
        F0 = 0.5_dp * sqrt(pi/x) * erf(sqrt(x))
    end if
    call assert(abs(F(0) - F0) < eps)
    call assert(abs(F(0) - F0) / F(0) < 1e-14_dp)
    do m = 0, 500
        call Fm(m, x, G(:m))
        call assert(all(abs(G(:m) - F(:m)) < eps))
        call assert(all(rel_error(F(:m), G(:m)) < eps_rel))
    end do
end do

contains

subroutine downwards(maxm, t, F)
integer, intent(in) :: maxm
real(dp), intent(in) :: t
real(dp), intent(out) :: F(0:)
integer :: m
F(maxm) = 0
do m = maxm-1, 0, -1
    F(m) = (2*t*F(m + 1) + exp(-t)) / (2*m + 1)
end do
end subroutine

subroutine asympt(maxm, t, F)
integer, intent(in) :: maxm
real(dp), intent(in) :: t
real(dp), intent(out) :: F(0:)
integer :: m
do m = 0, maxm
    ! This can overflow (NaN):
    !F(m) = gamma(m+0.5_dp) / (2*t**(m+0.5_dp))
    ! so this is equivalent, but works for large "t" and "m":
    F(m) = exp(log_gamma(m+0.5_dp) - (m+0.5_dp)*log(t)) / 2
end do
end subroutine

real(dp) elemental function rel_error(a, b) result(r)
real(dp), intent(in) :: a, b
real(dp) :: m, d
d = abs(a-b)
m = max(abs(a), abs(b))
if (d < tiny(1._dp)) then
    r = 0
else
    r = d / m
end if
end function

end program


      subroutine OPERATORLAP4(
     &           lofphi
     &           ,ilofphilo0,ilofphilo1,ilofphilo2
     &           ,ilofphihi0,ilofphihi1,ilofphihi2
     &           ,nlofphicomp
     &           ,phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,dx
     &           ,alpha
     &           ,beta
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nlofphicomp
      integer ilofphilo0,ilofphilo1,ilofphilo2
      integer ilofphihi0,ilofphihi1,ilofphihi2
      REAL*8 lofphi(
     &           ilofphilo0:ilofphihi0,
     &           ilofphilo1:ilofphihi1,
     &           ilofphilo2:ilofphihi2,
     &           0:nlofphicomp-1)
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      REAL*8 dx
      REAL*8 alpha
      REAL*8 beta
      REAL*8 dxinv, lap
      integer n,ncomp
      integer i,j,k
      ncomp = nphicomp
      if(ncomp .ne. nlofphicomp) then
         call MAYDAYERROR()
      endif
      dxinv = (1.0d0)/(dx*dx)
      do n = 0, ncomp-1
      do k = iregionlo2,iregionhi2
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
          lap = (
     &   (16.0d0)*phi(i-1,j  ,k  ,n) - phi(i-2,j  ,k  ,n)
     & + (16.0d0)*phi(i+1,j  ,k  ,n) - phi(i+2,j  ,k  ,n)
     & + (16.0d0)*phi(i  ,j-1,k  ,n) - phi(i  ,j-2,k  ,n)
     & + (16.0d0)*phi(i  ,j+1,k  ,n) - phi(i  ,j+2,k  ,n)
     & + (16.0d0)*phi(i  ,j  ,k-1,n) - phi(i  ,j  ,k-2,n)
     & + (16.0d0)*phi(i  ,j  ,k+1,n) - phi(i  ,j  ,k+2,n)
     &                     -((30.0d0)*3)*phi(i,j,k,n) )
     &       * (1.000d0 / 12.000d0) * dxinv
          lofphi(i,j,k,n) = alpha*phi(i,j,k,n)+beta*lap
      enddo
      enddo
      enddo
      enddo
      return
      end
      subroutine OPERATORLAPRES4(
     &           r
     &           ,irlo0,irlo1,irlo2
     &           ,irhi0,irhi1,irhi2
     &           ,nrcomp
     &           ,phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1,irhslo2
     &           ,irhshi0,irhshi1,irhshi2
     &           ,nrhscomp
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,dx
     &           ,alpha
     &           ,beta
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nrcomp
      integer irlo0,irlo1,irlo2
      integer irhi0,irhi1,irhi2
      REAL*8 r(
     &           irlo0:irhi0,
     &           irlo1:irhi1,
     &           irlo2:irhi2,
     &           0:nrcomp-1)
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1,irhslo2
      integer irhshi0,irhshi1,irhshi2
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           irhslo2:irhshi2,
     &           0:nrhscomp-1)
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      REAL*8 dx
      REAL*8 alpha
      REAL*8 beta
      REAL*8 dxinv, lap, lhs
      integer n,ncomp
      integer i,j,k
      ncomp = nphicomp
      dxinv = (1.0d0)/(dx*dx)
      do n = 0, ncomp-1
      do k = iregionlo2,iregionhi2
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
          lap = (
     &   (16.0d0)*phi(i-1,j  ,k  ,n) - phi(i-2,j  ,k  ,n)
     & + (16.0d0)*phi(i+1,j  ,k  ,n) - phi(i+2,j  ,k  ,n)
     & + (16.0d0)*phi(i  ,j-1,k  ,n) - phi(i  ,j-2,k  ,n)
     & + (16.0d0)*phi(i  ,j+1,k  ,n) - phi(i  ,j+2,k  ,n)
     & + (16.0d0)*phi(i  ,j  ,k-1,n) - phi(i  ,j  ,k-2,n)
     & + (16.0d0)*phi(i  ,j  ,k+1,n) - phi(i  ,j  ,k+2,n)
     &                     -((30.0d0)*3)*phi(i,j,k,n) )
     &       * (1.000d0 / 12.000d0) * dxinv
          lhs = alpha*phi(i,j,k,n) + beta*lap
          r(i,j,k,n) = rhs(i,j,k,n) - lhs
      enddo
      enddo
      enddo
      enddo
      return
      end
      subroutine RESTRICTRES4(
     &           res
     &           ,ireslo0,ireslo1,ireslo2
     &           ,ireshi0,ireshi1,ireshi2
     &           ,nrescomp
     &           ,phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1,irhslo2
     &           ,irhshi0,irhshi1,irhshi2
     &           ,nrhscomp
     &           ,alpha
     &           ,beta
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,dx
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nrescomp
      integer ireslo0,ireslo1,ireslo2
      integer ireshi0,ireshi1,ireshi2
      REAL*8 res(
     &           ireslo0:ireshi0,
     &           ireslo1:ireshi1,
     &           ireslo2:ireshi2,
     &           0:nrescomp-1)
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1,irhslo2
      integer irhshi0,irhshi1,irhshi2
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           irhslo2:irhshi2,
     &           0:nrhscomp-1)
      REAL*8 alpha
      REAL*8 beta
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      REAL*8 dx
      REAL*8 denom,dxinv,lofphi,lap
      integer n,ncomp
      integer i,j,k
      integer ii,jj,kk
      ncomp = nphicomp
      dxinv = (1.0d0) / (dx*dx)
      denom = 2  *2  *2
      do n = 0, ncomp-1
      do k = iregionlo2,iregionhi2
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
          ii = i/2
          jj = j/2
          kk = k/2
          lap = (
     &   (16.0d0)*phi(i-1,j  ,k  ,n) - phi(i-2,j  ,k  ,n)
     & + (16.0d0)*phi(i+1,j  ,k  ,n) - phi(i+2,j  ,k  ,n)
     & + (16.0d0)*phi(i  ,j-1,k  ,n) - phi(i  ,j-2,k  ,n)
     & + (16.0d0)*phi(i  ,j+1,k  ,n) - phi(i  ,j+2,k  ,n)
     & + (16.0d0)*phi(i  ,j  ,k-1,n) - phi(i  ,j  ,k-2,n)
     & + (16.0d0)*phi(i  ,j  ,k+1,n) - phi(i  ,j  ,k+2,n)
     &                     -((30.0d0)*3)*phi(i,j,k,n) )
     &       * (1.000d0 / 12.000d0) * dxinv
          lofphi = alpha*phi(i,j,k,n) + beta*lap
          res(ii,jj,kk,n) = res(ii,jj,kk,n)
     &                            + (rhs(i,j,k,n) - lofphi) / denom
      enddo
      enddo
      enddo
      enddo
      return
      end
      subroutine GSRBLAPLACIAN4(
     &           phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1,irhslo2
     &           ,irhshi0,irhshi1,irhshi2
     &           ,nrhscomp
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,dx
     &           ,tmp
     &           ,itmplo0,itmplo1,itmplo2
     &           ,itmphi0,itmphi1,itmphi2
     &           ,ntmpcomp
     &           ,redBlack
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1,irhslo2
      integer irhshi0,irhshi1,irhshi2
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           irhslo2:irhshi2,
     &           0:nrhscomp-1)
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      REAL*8 dx
      integer ntmpcomp
      integer itmplo0,itmplo1,itmplo2
      integer itmphi0,itmphi1,itmphi2
      REAL*8 tmp(
     &           itmplo0:itmphi0,
     &           itmplo1:itmphi1,
     &           itmplo2:itmphi2,
     &           0:ntmpcomp-1)
      integer redBlack
      REAL*8 dx2t, thD
      integer i,j,k
      integer n,ncomp,indtot,imin,imax,red,black
      red = 0
      black = 1
      dx2t = (12.0d0)*dx*dx
      thD  = (1.000d0 / 30.000d0)/3
      ncomp = nphicomp
      if(ncomp .ne. nrhscomp) then
         call MAYDAYERROR()
      endif
      do n = 0, ncomp - 1
         if (redBlack .eq. red) then
        do k=iregionlo2, iregionhi2
          do j=iregionlo1, iregionhi1
            imin = iregionlo0
            indtot = imin + j + k
            imin = imin + abs(mod(indtot+red, 2))
            imax = iregionhi0
            do i = imin, imax, 2
               tmp(i,j,k,n) = thD*(
     &           (16.0d0)*phi(i+1,j,k,n) - phi(i+2,j,k,n)
     &         + (16.0d0)*phi(i-1,j,k,n) - phi(i-2,j,k,n)
     &         + (16.0d0)*phi(i,j+1,k,n) - phi(i,j+2,k,n)
     &         + (16.0d0)*phi(i,j-1,k,n) - phi(i,j-2,k,n)
     &         + (16.0d0)*phi(i,j,k+1,n) - phi(i,j,k+2,n)
     &         + (16.0d0)*phi(i,j,k-1,n) - phi(i,j,k-2,n)
     &         - dx2t*rhs(i,j,k,n) )
            enddo
          enddo
        enddo
        else if (redBlack .eq. black) then
        do k=iregionlo2, iregionhi2
          do j=iregionlo1, iregionhi1
            imin = iregionlo0
            indtot = imin + j + k
            imin = imin + abs(mod(indtot+black, 2))
            imax = iregionhi0
            do i = imin, imax, 2
               phi(i,j,k,n) = thD*(
     &           (16.0d0)*tmp(i+1,j,k,n) - tmp(i+2,j,k,n)
     &         + (16.0d0)*tmp(i-1,j,k,n) - tmp(i-2,j,k,n)
     &         + (16.0d0)*tmp(i,j+1,k,n) - tmp(i,j+2,k,n)
     &         + (16.0d0)*tmp(i,j-1,k,n) - tmp(i,j-2,k,n)
     &         + (16.0d0)*tmp(i,j,k+1,n) - tmp(i,j,k+2,n)
     &         + (16.0d0)*tmp(i,j,k-1,n) - tmp(i,j,k-2,n)
     &         - dx2t*rhs(i,j,k,n) )
            enddo
          enddo
        enddo
        do k=iregionlo2, iregionhi2
          do j=iregionlo1, iregionhi1
            imin = iregionlo0
            indtot = imin + j + k
            imin = imin + abs(mod(indtot+red, 2))
            imax = iregionhi0
            do i = imin, imax, 2
               phi(i,j,k,n) = tmp(i,j,k,n)
            enddo
          enddo
        enddo
        else
           call MAYDAYERROR()
        end if
      enddo
      return
      end
      subroutine SORLAPLACIAN4(
     &           phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1,irhslo2
     &           ,irhshi0,irhshi1,irhshi2
     &           ,nrhscomp
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,dx
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1,irhslo2
      integer irhshi0,irhshi1,irhshi2
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           irhslo2:irhshi2,
     &           0:nrhscomp-1)
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      REAL*8 dx
      REAL*8 dx2t, thD, tmp, omega
      integer i,j,k
      integer n,ncomp
      dx2t = (12.0d0)*dx*dx
      thD  = (1.000d0 / 30.000d0)/3
      omega = 0.47
      ncomp = nphicomp
      if(ncomp .ne. nrhscomp) then
         call MAYDAYERROR()
      endif
      do n = 0, ncomp - 1
      do k = iregionlo2,iregionhi2
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
         tmp = thD*(
     &        (16.0d0)*phi(i+1,j,k,n) - phi(i+2,j,k,n)
     &        + (16.0d0)*phi(i-1,j,k,n) - phi(i-2,j,k,n)
     &        + (16.0d0)*phi(i,j+1,k,n) - phi(i,j+2,k,n)
     &        + (16.0d0)*phi(i,j-1,k,n) - phi(i,j-2,k,n)
     &        + (16.0d0)*phi(i,j,k+1,n) - phi(i,j,k+2,n)
     &        + (16.0d0)*phi(i,j,k-1,n) - phi(i,j,k-2,n)
     &        - dx2t*rhs(i,j,k,n) )
         phi(i,j,k,n) = omega*tmp
     &        + ((1.0d0)-omega)*phi(i,j,k,n)
      enddo
      enddo
      enddo
      enddo
      return
      end
      subroutine GSRBHELMHOLTZ4(
     &           phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1,irhslo2
     &           ,irhshi0,irhshi1,irhshi2
     &           ,nrhscomp
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,dx
     &           ,tmp
     &           ,itmplo0,itmplo1,itmplo2
     &           ,itmphi0,itmphi1,itmphi2
     &           ,ntmpcomp
     &           ,alpha
     &           ,beta
     &           ,redBlack
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1,irhslo2
      integer irhshi0,irhshi1,irhshi2
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           irhslo2:irhshi2,
     &           0:nrhscomp-1)
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      REAL*8 dx
      integer ntmpcomp
      integer itmplo0,itmplo1,itmplo2
      integer itmphi0,itmphi1,itmphi2
      REAL*8 tmp(
     &           itmplo0:itmphi0,
     &           itmplo1:itmphi1,
     &           itmplo2:itmphi2,
     &           0:ntmpcomp-1)
      REAL*8 alpha
      REAL*8 beta
      integer redBlack
      REAL*8 dx2t, lambda, lap, dxinv, helm
      integer i,j,k
      integer n,ncomp,indtot,imin,imax,red,black
      red = 0
      black = 1
      dx2t = (12.0d0)*dx*dx
      dxinv = (1.0d0)/(dx*dx)
      lambda = (1.0d0)/(alpha - beta*(30.0d0)*3*(1.000d0 / 12.000d0)*dxi
     &nv)
      lambda = lambda*(0.60)
      ncomp = nphicomp
      if(ncomp .ne. nrhscomp) then
         call MAYDAYERROR()
      endif
      do n = 0, ncomp - 1
         if (redBlack .eq. red) then
        do k=iregionlo2, iregionhi2
          do j=iregionlo1, iregionhi1
            imin = iregionlo0
            indtot = imin + j + k
            imin = imin + abs(mod(indtot+red, 2))
            imax = iregionhi0
            do i = imin, imax, 2
          lap = (
     &   (16.0d0)*phi(i-1,j  ,k  ,n) - phi(i-2,j  ,k  ,n)
     & + (16.0d0)*phi(i+1,j  ,k  ,n) - phi(i+2,j  ,k  ,n)
     & + (16.0d0)*phi(i  ,j-1,k  ,n) - phi(i  ,j-2,k  ,n)
     & + (16.0d0)*phi(i  ,j+1,k  ,n) - phi(i  ,j+2,k  ,n)
     & + (16.0d0)*phi(i  ,j  ,k-1,n) - phi(i  ,j  ,k-2,n)
     & + (16.0d0)*phi(i  ,j  ,k+1,n) - phi(i  ,j  ,k+2,n)
     &                     -((30.0d0)*3)*phi(i,j,k,n) )
     &       * (1.000d0 / 12.000d0) * dxinv
          helm = alpha*phi(i,j,k,n) + beta*lap
          tmp(i,j,k,n) = phi(i,j,k,n) +
     &      lambda*( rhs(i,j,k,n) - helm )
            enddo
          enddo
        enddo
        else if (redBlack .eq. black) then
        do k=iregionlo2, iregionhi2
          do j=iregionlo1, iregionhi1
            imin = iregionlo0
            indtot = imin + j + k
            imin = imin + abs(mod(indtot+black, 2))
            imax = iregionhi0
            do i = imin, imax, 2
               lap = (
     &           (16.0d0)*tmp(i+1,j,k,n) - tmp(i+2,j,k,n)
     &         + (16.0d0)*tmp(i-1,j,k,n) - tmp(i-2,j,k,n)
     &         + (16.0d0)*tmp(i,j+1,k,n) - tmp(i,j+2,k,n)
     &         + (16.0d0)*tmp(i,j-1,k,n) - tmp(i,j-2,k,n)
     &         + (16.0d0)*tmp(i,j,k+1,n) - tmp(i,j,k+2,n)
     &         + (16.0d0)*tmp(i,j,k-1,n) - tmp(i,j,k-2,n)
     &                     -((30.0d0)*3)*tmp(i,j,k,n) )
     &       * (1.000d0 / 12.000d0) * dxinv
               helm = alpha*tmp(i,j,k,n) + beta*lap
               phi(i,j,k,n) = tmp(i,j,k,n) +
     &              lambda*( rhs(i,j,k,n) - helm )
            enddo
          enddo
        enddo
        do k=iregionlo2, iregionhi2
          do j=iregionlo1, iregionhi1
            imin = iregionlo0
            indtot = imin + j + k
            imin = imin + abs(mod(indtot+red, 2))
            imax = iregionhi0
            do i = imin, imax, 2
               phi(i,j,k,n) = tmp(i,j,k,n)
            enddo
          enddo
        enddo
        else
           call MAYDAYERROR()
        end if
      enddo
      return
      end
      subroutine NEWGETFLUX4(
     &           flux
     &           ,ifluxlo0,ifluxlo1,ifluxlo2
     &           ,ifluxhi0,ifluxhi1,ifluxhi2
     &           ,nfluxcomp
     &           ,phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,iboxlo0,iboxlo1,iboxlo2
     &           ,iboxhi0,iboxhi1,iboxhi2
     &           ,beta_dx
     &           ,a_idir
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer CHF_ID(0:5,0:5)
      data CHF_ID/ 1,0,0,0,0,0 ,0,1,0,0,0,0 ,0,0,1,0,0,0 ,0,0,0,1,0,0 ,0
     &,0,0,0,1,0 ,0,0,0,0,0,1 /
      integer nfluxcomp
      integer ifluxlo0,ifluxlo1,ifluxlo2
      integer ifluxhi0,ifluxhi1,ifluxhi2
      REAL*8 flux(
     &           ifluxlo0:ifluxhi0,
     &           ifluxlo1:ifluxhi1,
     &           ifluxlo2:ifluxhi2,
     &           0:nfluxcomp-1)
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer iboxlo0,iboxlo1,iboxlo2
      integer iboxhi0,iboxhi1,iboxhi2
      REAL*8 beta_dx
      integer a_idir
      INTEGER ncomp,n
      integer ii, jj, kk
      integer i , j , k
      ncomp = nphicomp
      ii = CHF_ID(a_idir, 0)
      jj = CHF_ID(a_idir, 1)
      kk = CHF_ID(a_idir, 2)
      do n = 0, ncomp-1
      do k = iboxlo2,iboxhi2
      do j = iboxlo1,iboxhi1
      do i = iboxlo0,iboxhi0
          flux(i,j,k,n) = beta_dx * (1.000d0 / 12.000d0) *
     &        ( (15.0d0)*phi(i,j,k,n)
     &           + phi(i-2*ii,j-2*jj,k-2*kk,n)
     &           - phi(i+ii,j+jj,k+kk,n)
     &           - (15.0d0)*phi(i-ii,j-jj,k-kk,n) )
      enddo
      enddo
      enddo
      enddo
      return
      end
      subroutine PROLONGLINEAR(
     &           phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,coarse
     &           ,icoarselo0,icoarselo1,icoarselo2
     &           ,icoarsehi0,icoarsehi1,icoarsehi2
     &           ,ncoarsecomp
     &           ,ifineBoxlo0,ifineBoxlo1,ifineBoxlo2
     &           ,ifineBoxhi0,ifineBoxhi1,ifineBoxhi2
     &           ,icrseBoxlo0,icrseBoxlo1,icrseBoxlo2
     &           ,icrseBoxhi0,icrseBoxhi1,icrseBoxhi2
     &           ,r
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer ncoarsecomp
      integer icoarselo0,icoarselo1,icoarselo2
      integer icoarsehi0,icoarsehi1,icoarsehi2
      REAL*8 coarse(
     &           icoarselo0:icoarsehi0,
     &           icoarselo1:icoarsehi1,
     &           icoarselo2:icoarsehi2,
     &           0:ncoarsecomp-1)
      integer ifineBoxlo0,ifineBoxlo1,ifineBoxlo2
      integer ifineBoxhi0,ifineBoxhi1,ifineBoxhi2
      integer icrseBoxlo0,icrseBoxlo1,icrseBoxlo2
      integer icrseBoxhi0,icrseBoxhi1,icrseBoxhi2
      integer r
      INTEGER ncomp, n
      integer i ,j ,k
      integer ic,jc,kc
      ncomp = nphicomp
      do n = 0, ncomp-1
      do k = ifineBoxlo2,ifineBoxhi2
      do j = ifineBoxlo1,ifineBoxhi1
      do i = ifineBoxlo0,ifineBoxhi0
           ic = i/r
           jc = j/r
           kc = k/r
           phi(i,j,k,n) =  phi(i,j,k,n) +
     &          coarse(ic,jc,kc,n)
           if (ic.ne.icrseBoxhi0 .and.
     &         (ic*r.lt.i .or. ic.eq.icrseBoxlo0)) then
              phi(i,j,k,n) =  phi(i,j,k,n) +
     &             (coarse(ic+1,jc,kc,n)
     &              - coarse(ic,jc,kc,n))/r*(i+(0.500d0)-ic*r-(0.500d0)*
     &r)
           else
              phi(i,j,k,n) =  phi(i,j,k,n) +
     &             (- coarse(ic-1,jc,kc,n)
     &              + coarse(ic,jc,kc,n))/r*(i+(0.500d0)-ic*r-(0.500d0)*
     &r)
           endif
           if (jc.ne.icrseBoxhi1 .and.
     &         (jc*r.lt.j .or. jc.eq.icrseBoxlo1)) then
              phi(i,j,k,n) =  phi(i,j,k,n) +
     &             (coarse(ic,jc+1,kc,n)
     &              - coarse(ic,jc,kc,n))/r*(j+(0.500d0)-jc*r-(0.500d0)*
     &r)
           else
              phi(i,j,k,n) =  phi(i,j,k,n) +
     &             (- coarse(ic,jc-1,kc,n)
     &              + coarse(ic,jc,kc,n))/r*(j+(0.500d0)-jc*r-(0.500d0)*
     &r)
           endif
           if (kc.ne.icrseBoxhi2 .and.
     &         (kc*r.lt.k .or. kc.eq.icrseBoxlo2)) then
              phi(i,j,k,n) =  phi(i,j,k,n) +
     &             (coarse(ic,jc,kc+1,n)
     &              - coarse(ic,jc,kc,n))/r*(k+(0.500d0)-kc*r-(0.500d0)*
     &r)
           else
              phi(i,j,k,n) =  phi(i,j,k,n) +
     &             (- coarse(ic,jc,kc-1,n)
     &              + coarse(ic,jc,kc,n))/r*(k+(0.500d0)-kc*r-(0.500d0)*
     &r)
           endif
      enddo
      enddo
      enddo
      enddo
      return
      end


*> \brief \b DDRGSX
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DDRGSX( NSIZE, NCMAX, THRESH, NIN, NOUT, A, LDA, B, AI,
*                          BI, Z, Q, ALPHAR, ALPHAI, BETA, C, LDC, S,
*                          WORK, LWORK, IWORK, LIWORK, BWORK, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, LDA, LDC, LIWORK, LWORK, NCMAX, NIN,
*      $                   NOUT, NSIZE
*       DOUBLE PRECISION   THRESH
*       ..
*       .. Array Arguments ..
*       LOGICAL            BWORK( * )
*       INTEGER            IWORK( * )
*       DOUBLE PRECISION   A( LDA, * ), AI( LDA, * ), ALPHAI( * ),
*      $                   ALPHAR( * ), B( LDA, * ), BETA( * ),
*      $                   BI( LDA, * ), C( LDC, * ), Q( LDA, * ), S( * ),
*      $                   WORK( * ), Z( LDA, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DDRGSX checks the nonsymmetric generalized eigenvalue (Schur form)
*> problem expert driver DGGESX.
*>
*> DGGESX factors A and B as Q S Z' and Q T Z', where ' means
*> transpose, T is upper triangular, S is in generalized Schur form
*> (block upper triangular, with 1x1 and 2x2 blocks on the diagonal,
*> the 2x2 blocks corresponding to complex conjugate pairs of
*> generalized eigenvalues), and Q and Z are orthogonal.  It also
*> computes the generalized eigenvalues (alpha(1),beta(1)), ...,
*> (alpha(n),beta(n)). Thus, w(j) = alpha(j)/beta(j) is a root of the
*> characteristic equation
*>
*>     det( A - w(j) B ) = 0
*>
*> Optionally it also reorders the eigenvalues so that a selected
*> cluster of eigenvalues appears in the leading diagonal block of the
*> Schur forms; computes a reciprocal condition number for the average
*> of the selected eigenvalues; and computes a reciprocal condition
*> number for the right and left deflating subspaces corresponding to
*> the selected eigenvalues.
*>
*> When DDRGSX is called with NSIZE > 0, five (5) types of built-in
*> matrix pairs are used to test the routine DGGESX.
*>
*> When DDRGSX is called with NSIZE = 0, it reads in test matrix data
*> to test DGGESX.
*>
*> For each matrix pair, the following tests will be performed and
*> compared with the threshold THRESH except for the tests (7) and (9):
*>
*> (1)   | A - Q S Z' | / ( |A| n ulp )
*>
*> (2)   | B - Q T Z' | / ( |B| n ulp )
*>
*> (3)   | I - QQ' | / ( n ulp )
*>
*> (4)   | I - ZZ' | / ( n ulp )
*>
*> (5)   if A is in Schur form (i.e. quasi-triangular form)
*>
*> (6)   maximum over j of D(j)  where:
*>
*>       if alpha(j) is real:
*>                     |alpha(j) - S(j,j)|        |beta(j) - T(j,j)|
*>           D(j) = ------------------------ + -----------------------
*>                  max(|alpha(j)|,|S(j,j)|)   max(|beta(j)|,|T(j,j)|)
*>
*>       if alpha(j) is complex:
*>                                 | det( s S - w T ) |
*>           D(j) = ---------------------------------------------------
*>                  ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
*>
*>           and S and T are here the 2 x 2 diagonal blocks of S and T
*>           corresponding to the j-th and j+1-th eigenvalues.
*>
*> (7)   if sorting worked and SDIM is the number of eigenvalues
*>       which were selected.
*>
*> (8)   the estimated value DIF does not differ from the true values of
*>       Difu and Difl more than a factor 10*THRESH. If the estimate DIF
*>       equals zero the corresponding true values of Difu and Difl
*>       should be less than EPS*norm(A, B). If the true value of Difu
*>       and Difl equal zero, the estimate DIF should be less than
*>       EPS*norm(A, B).
*>
*> (9)   If INFO = N+3 is returned by DGGESX, the reordering "failed"
*>       and we check that DIF = PL = PR = 0 and that the true value of
*>       Difu and Difl is < EPS*norm(A, B). We count the events when
*>       INFO=N+3.
*>
*> For read-in test matrices, the above tests are run except that the
*> exact value for DIF (and PL) is input data.  Additionally, there is
*> one more test run for read-in test matrices:
*>
*> (10)  the estimated value PL does not differ from the true value of
*>       PLTRU more than a factor THRESH. If the estimate PL equals
*>       zero the corresponding true value of PLTRU should be less than
*>       EPS*norm(A, B). If the true value of PLTRU equal zero, the
*>       estimate PL should be less than EPS*norm(A, B).
*>
*> Note that for the built-in tests, a total of 10*NSIZE*(NSIZE-1)
*> matrix pairs are generated and tested. NSIZE should be kept small.
*>
*> SVD (routine DGESVD) is used for computing the true value of DIF_u
*> and DIF_l when testing the built-in test problems.
*>
*> Built-in Test Matrices
*> ======================
*>
*> All built-in test matrices are the 2 by 2 block of triangular
*> matrices
*>
*>          A = [ A11 A12 ]    and      B = [ B11 B12 ]
*>              [     A22 ]                 [     B22 ]
*>
*> where for different type of A11 and A22 are given as the following.
*> A12 and B12 are chosen so that the generalized Sylvester equation
*>
*>          A11*R - L*A22 = -A12
*>          B11*R - L*B22 = -B12
*>
*> have prescribed solution R and L.
*>
*> Type 1:  A11 = J_m(1,-1) and A_22 = J_k(1-a,1).
*>          B11 = I_m, B22 = I_k
*>          where J_k(a,b) is the k-by-k Jordan block with ``a'' on
*>          diagonal and ``b'' on superdiagonal.
*>
*> Type 2:  A11 = (a_ij) = ( 2(.5-sin(i)) ) and
*>          B11 = (b_ij) = ( 2(.5-sin(ij)) ) for i=1,...,m, j=i,...,m
*>          A22 = (a_ij) = ( 2(.5-sin(i+j)) ) and
*>          B22 = (b_ij) = ( 2(.5-sin(ij)) ) for i=m+1,...,k, j=i,...,k
*>
*> Type 3:  A11, A22 and B11, B22 are chosen as for Type 2, but each
*>          second diagonal block in A_11 and each third diagonal block
*>          in A_22 are made as 2 by 2 blocks.
*>
*> Type 4:  A11 = ( 20(.5 - sin(ij)) ) and B22 = ( 2(.5 - sin(i+j)) )
*>             for i=1,...,m,  j=1,...,m and
*>          A22 = ( 20(.5 - sin(i+j)) ) and B22 = ( 2(.5 - sin(ij)) )
*>             for i=m+1,...,k,  j=m+1,...,k
*>
*> Type 5:  (A,B) and have potentially close or common eigenvalues and
*>          very large departure from block diagonality A_11 is chosen
*>          as the m x m leading submatrix of A_1:
*>                  |  1  b                            |
*>                  | -b  1                            |
*>                  |        1+d  b                    |
*>                  |         -b 1+d                   |
*>           A_1 =  |                  d  1            |
*>                  |                 -1  d            |
*>                  |                        -d  1     |
*>                  |                        -1 -d     |
*>                  |                               1  |
*>          and A_22 is chosen as the k x k leading submatrix of A_2:
*>                  | -1  b                            |
*>                  | -b -1                            |
*>                  |       1-d  b                     |
*>                  |       -b  1-d                    |
*>           A_2 =  |                 d 1+b            |
*>                  |               -1-b d             |
*>                  |                       -d  1+b    |
*>                  |                      -1+b  -d    |
*>                  |                              1-d |
*>          and matrix B are chosen as identity matrices (see DLATM5).
*>
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] NSIZE
*> \verbatim
*>          NSIZE is INTEGER
*>          The maximum size of the matrices to use. NSIZE >= 0.
*>          If NSIZE = 0, no built-in tests matrices are used, but
*>          read-in test matrices are used to test DGGESX.
*> \endverbatim
*>
*> \param[in] NCMAX
*> \verbatim
*>          NCMAX is INTEGER
*>          Maximum allowable NMAX for generating Kroneker matrix
*>          in call to DLAKF2
*> \endverbatim
*>
*> \param[in] THRESH
*> \verbatim
*>          THRESH is DOUBLE PRECISION
*>          A test will count as "failed" if the "error", computed as
*>          described above, exceeds THRESH.  Note that the error
*>          is scaled to be O(1), so THRESH should be a reasonably
*>          small multiple of 1, e.g., 10 or 100.  In particular,
*>          it should not depend on the precision (single vs. double)
*>          or the size of the matrix.  THRESH >= 0.
*> \endverbatim
*>
*> \param[in] NIN
*> \verbatim
*>          NIN is INTEGER
*>          The FORTRAN unit number for reading in the data file of
*>          problems to solve.
*> \endverbatim
*>
*> \param[in] NOUT
*> \verbatim
*>          NOUT is INTEGER
*>          The FORTRAN unit number for printing out error messages
*>          (e.g., if a routine returns IINFO not equal to 0.)
*> \endverbatim
*>
*> \param[out] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA, NSIZE)
*>          Used to store the matrix whose eigenvalues are to be
*>          computed.  On exit, A contains the last matrix actually used.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of A, B, AI, BI, Z and Q,
*>          LDA >= max( 1, NSIZE ). For the read-in test,
*>          LDA >= max( 1, N ), N is the size of the test matrices.
*> \endverbatim
*>
*> \param[out] B
*> \verbatim
*>          B is DOUBLE PRECISION array, dimension (LDA, NSIZE)
*>          Used to store the matrix whose eigenvalues are to be
*>          computed.  On exit, B contains the last matrix actually used.
*> \endverbatim
*>
*> \param[out] AI
*> \verbatim
*>          AI is DOUBLE PRECISION array, dimension (LDA, NSIZE)
*>          Copy of A, modified by DGGESX.
*> \endverbatim
*>
*> \param[out] BI
*> \verbatim
*>          BI is DOUBLE PRECISION array, dimension (LDA, NSIZE)
*>          Copy of B, modified by DGGESX.
*> \endverbatim
*>
*> \param[out] Z
*> \verbatim
*>          Z is DOUBLE PRECISION array, dimension (LDA, NSIZE)
*>          Z holds the left Schur vectors computed by DGGESX.
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*>          Q is DOUBLE PRECISION array, dimension (LDA, NSIZE)
*>          Q holds the right Schur vectors computed by DGGESX.
*> \endverbatim
*>
*> \param[out] ALPHAR
*> \verbatim
*>          ALPHAR is DOUBLE PRECISION array, dimension (NSIZE)
*> \endverbatim
*>
*> \param[out] ALPHAI
*> \verbatim
*>          ALPHAI is DOUBLE PRECISION array, dimension (NSIZE)
*> \endverbatim
*>
*> \param[out] BETA
*> \verbatim
*>          BETA is DOUBLE PRECISION array, dimension (NSIZE)
*>
*>          On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues.
*> \endverbatim
*>
*> \param[out] C
*> \verbatim
*>          C is DOUBLE PRECISION array, dimension (LDC, LDC)
*>          Store the matrix generated by subroutine DLAKF2, this is the
*>          matrix formed by Kronecker products used for estimating
*>          DIF.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*>          LDC is INTEGER
*>          The leading dimension of C. LDC >= max(1, LDA*LDA/2 ).
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*>          S is DOUBLE PRECISION array, dimension (LDC)
*>          Singular values of C
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK.
*>          LWORK >= MAX( 5*NSIZE*NSIZE/2 - 2, 10*(NSIZE+1) )
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (LIWORK)
*> \endverbatim
*>
*> \param[in] LIWORK
*> \verbatim
*>          LIWORK is INTEGER
*>          The dimension of the array IWORK. LIWORK >= NSIZE + 6.
*> \endverbatim
*>
*> \param[out] BWORK
*> \verbatim
*>          BWORK is LOGICAL array, dimension (LDA)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
*>          > 0:  A routine returned an error code.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup double_eig
*
*  =====================================================================
      SUBROUTINE DDRGSX( NSIZE, NCMAX, THRESH, NIN, NOUT, A, LDA, B, AI,
     $                   BI, Z, Q, ALPHAR, ALPHAI, BETA, C, LDC, S,
     $                   WORK, LWORK, IWORK, LIWORK, BWORK, INFO )
*
*  -- LAPACK test routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     June 2016
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDC, LIWORK, LWORK, NCMAX, NIN,
     $                   NOUT, NSIZE
      DOUBLE PRECISION   THRESH
*     ..
*     .. Array Arguments ..
      LOGICAL            BWORK( * )
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), AI( LDA, * ), ALPHAI( * ),
     $                   ALPHAR( * ), B( LDA, * ), BETA( * ),
     $                   BI( LDA, * ), C( LDC, * ), Q( LDA, * ), S( * ),
     $                   WORK( * ), Z( LDA, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TEN
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ILABAD
      CHARACTER          SENSE
      INTEGER            BDSPAC, I, I1, IFUNC, IINFO, J, LINFO, MAXWRK,
     $                   MINWRK, MM, MN2, NERRS, NPTKNT, NTEST, NTESTT,
     $                   PRTYPE, QBA, QBB
      DOUBLE PRECISION   ABNRM, BIGNUM, DIFTRU, PLTRU, SMLNUM, TEMP1,
     $                   TEMP2, THRSH2, ULP, ULPINV, WEIGHT
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   DIFEST( 2 ), PL( 2 ), RESULT( 10 )
*     ..
*     .. External Functions ..
      LOGICAL            DLCTSX
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           DLCTSX, ILAENV, DLAMCH, DLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           ALASVM, DGESVD, DGET51, DGET53, DGGESX, DLABAD,
     $                   DLACPY, DLAKF2, DLASET, DLATM5, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
*     ..
*     .. Scalars in Common ..
      LOGICAL            FS
      INTEGER            K, M, MPLUSN, N
*     ..
*     .. Common blocks ..
      COMMON             / MN / M, N, MPLUSN, K, FS
*     ..
*     .. Executable Statements ..
*
*     Check for errors
*
      IF( NSIZE.LT.0 ) THEN
         INFO = -1
      ELSE IF( THRESH.LT.ZERO ) THEN
         INFO = -2
      ELSE IF( NIN.LE.0 ) THEN
         INFO = -3
      ELSE IF( NOUT.LE.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.1 .OR. LDA.LT.NSIZE ) THEN
         INFO = -6
      ELSE IF( LDC.LT.1 .OR. LDC.LT.NSIZE*NSIZE / 2 ) THEN
         INFO = -17
      ELSE IF( LIWORK.LT.NSIZE+6 ) THEN
         INFO = -21
      END IF
*
*     Compute workspace
*      (Note: Comments in the code beginning "Workspace:" describe the
*       minimal amount of workspace needed at that point in the code,
*       as well as the preferred amount for good performance.
*       NB refers to the optimal block size for the immediately
*       following subroutine, as returned by ILAENV.)
*
      MINWRK = 1
      IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
         MINWRK = MAX( 10*( NSIZE+1 ), 5*NSIZE*NSIZE / 2 )
*
*        workspace for sggesx
*
         MAXWRK = 9*( NSIZE+1 ) + NSIZE*
     $            ILAENV( 1, 'DGEQRF', ' ', NSIZE, 1, NSIZE, 0 )
         MAXWRK = MAX( MAXWRK, 9*( NSIZE+1 )+NSIZE*
     $            ILAENV( 1, 'DORGQR', ' ', NSIZE, 1, NSIZE, -1 ) )
*
*        workspace for dgesvd
*
         BDSPAC = 5*NSIZE*NSIZE / 2
         MAXWRK = MAX( MAXWRK, 3*NSIZE*NSIZE / 2+NSIZE*NSIZE*
     $            ILAENV( 1, 'DGEBRD', ' ', NSIZE*NSIZE / 2,
     $            NSIZE*NSIZE / 2, -1, -1 ) )
         MAXWRK = MAX( MAXWRK, BDSPAC )
*
         MAXWRK = MAX( MAXWRK, MINWRK )
*
         WORK( 1 ) = MAXWRK
      END IF
*
      IF( LWORK.LT.MINWRK )
     $   INFO = -19
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DDRGSX', -INFO )
         RETURN
      END IF
*
*     Important constants
*
      ULP = DLAMCH( 'P' )
      ULPINV = ONE / ULP
      SMLNUM = DLAMCH( 'S' ) / ULP
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
      THRSH2 = TEN*THRESH
      NTESTT = 0
      NERRS = 0
*
*     Go to the tests for read-in matrix pairs
*
      IFUNC = 0
      IF( NSIZE.EQ.0 )
     $   GO TO 70
*
*     Test the built-in matrix pairs.
*     Loop over different functions (IFUNC) of DGGESX, types (PRTYPE)
*     of test matrices, different size (M+N)
*
      PRTYPE = 0
      QBA = 3
      QBB = 4
      WEIGHT = SQRT( ULP )
*
      DO 60 IFUNC = 0, 3
         DO 50 PRTYPE = 1, 5
            DO 40 M = 1, NSIZE - 1
               DO 30 N = 1, NSIZE - M
*
                  WEIGHT = ONE / WEIGHT
                  MPLUSN = M + N
*
*                 Generate test matrices
*
                  FS = .TRUE.
                  K = 0
*
                  CALL DLASET( 'Full', MPLUSN, MPLUSN, ZERO, ZERO, AI,
     $                         LDA )
                  CALL DLASET( 'Full', MPLUSN, MPLUSN, ZERO, ZERO, BI,
     $                         LDA )
*
                  CALL DLATM5( PRTYPE, M, N, AI, LDA, AI( M+1, M+1 ),
     $                         LDA, AI( 1, M+1 ), LDA, BI, LDA,
     $                         BI( M+1, M+1 ), LDA, BI( 1, M+1 ), LDA,
     $                         Q, LDA, Z, LDA, WEIGHT, QBA, QBB )
*
*                 Compute the Schur factorization and swapping the
*                 m-by-m (1,1)-blocks with n-by-n (2,2)-blocks.
*                 Swapping is accomplished via the function DLCTSX
*                 which is supplied below.
*
                  IF( IFUNC.EQ.0 ) THEN
                     SENSE = 'N'
                  ELSE IF( IFUNC.EQ.1 ) THEN
                     SENSE = 'E'
                  ELSE IF( IFUNC.EQ.2 ) THEN
                     SENSE = 'V'
                  ELSE IF( IFUNC.EQ.3 ) THEN
                     SENSE = 'B'
                  END IF
*
                  CALL DLACPY( 'Full', MPLUSN, MPLUSN, AI, LDA, A, LDA )
                  CALL DLACPY( 'Full', MPLUSN, MPLUSN, BI, LDA, B, LDA )
*
                  CALL DGGESX( 'V', 'V', 'S', DLCTSX, SENSE, MPLUSN, AI,
     $                         LDA, BI, LDA, MM, ALPHAR, ALPHAI, BETA,
     $                         Q, LDA, Z, LDA, PL, DIFEST, WORK, LWORK,
     $                         IWORK, LIWORK, BWORK, LINFO )
*
                  IF( LINFO.NE.0 .AND. LINFO.NE.MPLUSN+2 ) THEN
                     RESULT( 1 ) = ULPINV
                     WRITE( NOUT, FMT = 9999 )'DGGESX', LINFO, MPLUSN,
     $                  PRTYPE
                     INFO = LINFO
                     GO TO 30
                  END IF
*
*                 Compute the norm(A, B)
*
                  CALL DLACPY( 'Full', MPLUSN, MPLUSN, AI, LDA, WORK,
     $                         MPLUSN )
                  CALL DLACPY( 'Full', MPLUSN, MPLUSN, BI, LDA,
     $                         WORK( MPLUSN*MPLUSN+1 ), MPLUSN )
                  ABNRM = DLANGE( 'Fro', MPLUSN, 2*MPLUSN, WORK, MPLUSN,
     $                    WORK )
*
*                 Do tests (1) to (4)
*
                  CALL DGET51( 1, MPLUSN, A, LDA, AI, LDA, Q, LDA, Z,
     $                         LDA, WORK, RESULT( 1 ) )
                  CALL DGET51( 1, MPLUSN, B, LDA, BI, LDA, Q, LDA, Z,
     $                         LDA, WORK, RESULT( 2 ) )
                  CALL DGET51( 3, MPLUSN, B, LDA, BI, LDA, Q, LDA, Q,
     $                         LDA, WORK, RESULT( 3 ) )
                  CALL DGET51( 3, MPLUSN, B, LDA, BI, LDA, Z, LDA, Z,
     $                         LDA, WORK, RESULT( 4 ) )
                  NTEST = 4
*
*                 Do tests (5) and (6): check Schur form of A and
*                 compare eigenvalues with diagonals.
*
                  TEMP1 = ZERO
                  RESULT( 5 ) = ZERO
                  RESULT( 6 ) = ZERO
*
                  DO 10 J = 1, MPLUSN
                     ILABAD = .FALSE.
                     IF( ALPHAI( J ).EQ.ZERO ) THEN
                        TEMP2 = ( ABS( ALPHAR( J )-AI( J, J ) ) /
     $                          MAX( SMLNUM, ABS( ALPHAR( J ) ),
     $                          ABS( AI( J, J ) ) )+
     $                          ABS( BETA( J )-BI( J, J ) ) /
     $                          MAX( SMLNUM, ABS( BETA( J ) ),
     $                          ABS( BI( J, J ) ) ) ) / ULP
                        IF( J.LT.MPLUSN ) THEN
                           IF( AI( J+1, J ).NE.ZERO ) THEN
                              ILABAD = .TRUE.
                              RESULT( 5 ) = ULPINV
                           END IF
                        END IF
                        IF( J.GT.1 ) THEN
                           IF( AI( J, J-1 ).NE.ZERO ) THEN
                              ILABAD = .TRUE.
                              RESULT( 5 ) = ULPINV
                           END IF
                        END IF
                     ELSE
                        IF( ALPHAI( J ).GT.ZERO ) THEN
                           I1 = J
                        ELSE
                           I1 = J - 1
                        END IF
                        IF( I1.LE.0 .OR. I1.GE.MPLUSN ) THEN
                           ILABAD = .TRUE.
                        ELSE IF( I1.LT.MPLUSN-1 ) THEN
                           IF( AI( I1+2, I1+1 ).NE.ZERO ) THEN
                              ILABAD = .TRUE.
                              RESULT( 5 ) = ULPINV
                           END IF
                        ELSE IF( I1.GT.1 ) THEN
                           IF( AI( I1, I1-1 ).NE.ZERO ) THEN
                              ILABAD = .TRUE.
                              RESULT( 5 ) = ULPINV
                           END IF
                        END IF
                        IF( .NOT.ILABAD ) THEN
                           CALL DGET53( AI( I1, I1 ), LDA, BI( I1, I1 ),
     $                                  LDA, BETA( J ), ALPHAR( J ),
     $                                  ALPHAI( J ), TEMP2, IINFO )
                           IF( IINFO.GE.3 ) THEN
                              WRITE( NOUT, FMT = 9997 )IINFO, J,
     $                           MPLUSN, PRTYPE
                              INFO = ABS( IINFO )
                           END IF
                        ELSE
                           TEMP2 = ULPINV
                        END IF
                     END IF
                     TEMP1 = MAX( TEMP1, TEMP2 )
                     IF( ILABAD ) THEN
                        WRITE( NOUT, FMT = 9996 )J, MPLUSN, PRTYPE
                     END IF
   10             CONTINUE
                  RESULT( 6 ) = TEMP1
                  NTEST = NTEST + 2
*
*                 Test (7) (if sorting worked)
*
                  RESULT( 7 ) = ZERO
                  IF( LINFO.EQ.MPLUSN+3 ) THEN
                     RESULT( 7 ) = ULPINV
                  ELSE IF( MM.NE.N ) THEN
                     RESULT( 7 ) = ULPINV
                  END IF
                  NTEST = NTEST + 1
*
*                 Test (8): compare the estimated value DIF and its
*                 value. first, compute the exact DIF.
*
                  RESULT( 8 ) = ZERO
                  MN2 = MM*( MPLUSN-MM )*2
                  IF( IFUNC.GE.2 .AND. MN2.LE.NCMAX*NCMAX ) THEN
*
*                    Note: for either following two causes, there are
*                    almost same number of test cases fail the test.
*
                     CALL DLAKF2( MM, MPLUSN-MM, AI, LDA,
     $                            AI( MM+1, MM+1 ), BI,
     $                            BI( MM+1, MM+1 ), C, LDC )
*
                     CALL DGESVD( 'N', 'N', MN2, MN2, C, LDC, S, WORK,
     $                            1, WORK( 2 ), 1, WORK( 3 ), LWORK-2,
     $                            INFO )
                     DIFTRU = S( MN2 )
*
                     IF( DIFEST( 2 ).EQ.ZERO ) THEN
                        IF( DIFTRU.GT.ABNRM*ULP )
     $                     RESULT( 8 ) = ULPINV
                     ELSE IF( DIFTRU.EQ.ZERO ) THEN
                        IF( DIFEST( 2 ).GT.ABNRM*ULP )
     $                     RESULT( 8 ) = ULPINV
                     ELSE IF( ( DIFTRU.GT.THRSH2*DIFEST( 2 ) ) .OR.
     $                        ( DIFTRU*THRSH2.LT.DIFEST( 2 ) ) ) THEN
                        RESULT( 8 ) = MAX( DIFTRU / DIFEST( 2 ),
     $                                DIFEST( 2 ) / DIFTRU )
                     END IF
                     NTEST = NTEST + 1
                  END IF
*
*                 Test (9)
*
                  RESULT( 9 ) = ZERO
                  IF( LINFO.EQ.( MPLUSN+2 ) ) THEN
                     IF( DIFTRU.GT.ABNRM*ULP )
     $                  RESULT( 9 ) = ULPINV
                     IF( ( IFUNC.GT.1 ) .AND. ( DIFEST( 2 ).NE.ZERO ) )
     $                  RESULT( 9 ) = ULPINV
                     IF( ( IFUNC.EQ.1 ) .AND. ( PL( 1 ).NE.ZERO ) )
     $                  RESULT( 9 ) = ULPINV
                     NTEST = NTEST + 1
                  END IF
*
                  NTESTT = NTESTT + NTEST
*
*                 Print out tests which fail.
*
                  DO 20 J = 1, 9
                     IF( RESULT( J ).GE.THRESH ) THEN
*
*                       If this is the first test to fail,
*                       print a header to the data file.
*
                        IF( NERRS.EQ.0 ) THEN
                           WRITE( NOUT, FMT = 9995 )'DGX'
*
*                          Matrix types
*
                           WRITE( NOUT, FMT = 9993 )
*
*                          Tests performed
*
                           WRITE( NOUT, FMT = 9992 )'orthogonal', '''',
     $                        'transpose', ( '''', I = 1, 4 )
*
                        END IF
                        NERRS = NERRS + 1
                        IF( RESULT( J ).LT.10000.0D0 ) THEN
                           WRITE( NOUT, FMT = 9991 )MPLUSN, PRTYPE,
     $                        WEIGHT, M, J, RESULT( J )
                        ELSE
                           WRITE( NOUT, FMT = 9990 )MPLUSN, PRTYPE,
     $                        WEIGHT, M, J, RESULT( J )
                        END IF
                     END IF
   20             CONTINUE
*
   30          CONTINUE
   40       CONTINUE
   50    CONTINUE
   60 CONTINUE
*
      GO TO 150
*
   70 CONTINUE
*
*     Read in data from file to check accuracy of condition estimation
*     Read input data until N=0
*
      NPTKNT = 0
*
   80 CONTINUE
      READ( NIN, FMT = *, END = 140 )MPLUSN
      IF( MPLUSN.EQ.0 )
     $   GO TO 140
      READ( NIN, FMT = *, END = 140 )N
      DO 90 I = 1, MPLUSN
         READ( NIN, FMT = * )( AI( I, J ), J = 1, MPLUSN )
   90 CONTINUE
      DO 100 I = 1, MPLUSN
         READ( NIN, FMT = * )( BI( I, J ), J = 1, MPLUSN )
  100 CONTINUE
      READ( NIN, FMT = * )PLTRU, DIFTRU
*
      NPTKNT = NPTKNT + 1
      FS = .TRUE.
      K = 0
      M = MPLUSN - N
*
      CALL DLACPY( 'Full', MPLUSN, MPLUSN, AI, LDA, A, LDA )
      CALL DLACPY( 'Full', MPLUSN, MPLUSN, BI, LDA, B, LDA )
*
*     Compute the Schur factorization while swapping the
*     m-by-m (1,1)-blocks with n-by-n (2,2)-blocks.
*
      CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'B', MPLUSN, AI, LDA, BI, LDA,
     $             MM, ALPHAR, ALPHAI, BETA, Q, LDA, Z, LDA, PL, DIFEST,
     $             WORK, LWORK, IWORK, LIWORK, BWORK, LINFO )
*
      IF( LINFO.NE.0 .AND. LINFO.NE.MPLUSN+2 ) THEN
         RESULT( 1 ) = ULPINV
         WRITE( NOUT, FMT = 9998 )'DGGESX', LINFO, MPLUSN, NPTKNT
         GO TO 130
      END IF
*
*     Compute the norm(A, B)
*        (should this be norm of (A,B) or (AI,BI)?)
*
      CALL DLACPY( 'Full', MPLUSN, MPLUSN, AI, LDA, WORK, MPLUSN )
      CALL DLACPY( 'Full', MPLUSN, MPLUSN, BI, LDA,
     $             WORK( MPLUSN*MPLUSN+1 ), MPLUSN )
      ABNRM = DLANGE( 'Fro', MPLUSN, 2*MPLUSN, WORK, MPLUSN, WORK )
*
*     Do tests (1) to (4)
*
      CALL DGET51( 1, MPLUSN, A, LDA, AI, LDA, Q, LDA, Z, LDA, WORK,
     $             RESULT( 1 ) )
      CALL DGET51( 1, MPLUSN, B, LDA, BI, LDA, Q, LDA, Z, LDA, WORK,
     $             RESULT( 2 ) )
      CALL DGET51( 3, MPLUSN, B, LDA, BI, LDA, Q, LDA, Q, LDA, WORK,
     $             RESULT( 3 ) )
      CALL DGET51( 3, MPLUSN, B, LDA, BI, LDA, Z, LDA, Z, LDA, WORK,
     $             RESULT( 4 ) )
*
*     Do tests (5) and (6): check Schur form of A and compare
*     eigenvalues with diagonals.
*
      NTEST = 6
      TEMP1 = ZERO
      RESULT( 5 ) = ZERO
      RESULT( 6 ) = ZERO
*
      DO 110 J = 1, MPLUSN
         ILABAD = .FALSE.
         IF( ALPHAI( J ).EQ.ZERO ) THEN
            TEMP2 = ( ABS( ALPHAR( J )-AI( J, J ) ) /
     $              MAX( SMLNUM, ABS( ALPHAR( J ) ), ABS( AI( J,
     $              J ) ) )+ABS( BETA( J )-BI( J, J ) ) /
     $              MAX( SMLNUM, ABS( BETA( J ) ), ABS( BI( J, J ) ) ) )
     $               / ULP
            IF( J.LT.MPLUSN ) THEN
               IF( AI( J+1, J ).NE.ZERO ) THEN
                  ILABAD = .TRUE.
                  RESULT( 5 ) = ULPINV
               END IF
            END IF
            IF( J.GT.1 ) THEN
               IF( AI( J, J-1 ).NE.ZERO ) THEN
                  ILABAD = .TRUE.
                  RESULT( 5 ) = ULPINV
               END IF
            END IF
         ELSE
            IF( ALPHAI( J ).GT.ZERO ) THEN
               I1 = J
            ELSE
               I1 = J - 1
            END IF
            IF( I1.LE.0 .OR. I1.GE.MPLUSN ) THEN
               ILABAD = .TRUE.
            ELSE IF( I1.LT.MPLUSN-1 ) THEN
               IF( AI( I1+2, I1+1 ).NE.ZERO ) THEN
                  ILABAD = .TRUE.
                  RESULT( 5 ) = ULPINV
               END IF
            ELSE IF( I1.GT.1 ) THEN
               IF( AI( I1, I1-1 ).NE.ZERO ) THEN
                  ILABAD = .TRUE.
                  RESULT( 5 ) = ULPINV
               END IF
            END IF
            IF( .NOT.ILABAD ) THEN
               CALL DGET53( AI( I1, I1 ), LDA, BI( I1, I1 ), LDA,
     $                      BETA( J ), ALPHAR( J ), ALPHAI( J ), TEMP2,
     $                      IINFO )
               IF( IINFO.GE.3 ) THEN
                  WRITE( NOUT, FMT = 9997 )IINFO, J, MPLUSN, NPTKNT
                  INFO = ABS( IINFO )
               END IF
            ELSE
               TEMP2 = ULPINV
            END IF
         END IF
         TEMP1 = MAX( TEMP1, TEMP2 )
         IF( ILABAD ) THEN
            WRITE( NOUT, FMT = 9996 )J, MPLUSN, NPTKNT
         END IF
  110 CONTINUE
      RESULT( 6 ) = TEMP1
*
*     Test (7) (if sorting worked)  <--------- need to be checked.
*
      NTEST = 7
      RESULT( 7 ) = ZERO
      IF( LINFO.EQ.MPLUSN+3 )
     $   RESULT( 7 ) = ULPINV
*
*     Test (8): compare the estimated value of DIF and its true value.
*
      NTEST = 8
      RESULT( 8 ) = ZERO
      IF( DIFEST( 2 ).EQ.ZERO ) THEN
         IF( DIFTRU.GT.ABNRM*ULP )
     $      RESULT( 8 ) = ULPINV
      ELSE IF( DIFTRU.EQ.ZERO ) THEN
         IF( DIFEST( 2 ).GT.ABNRM*ULP )
     $      RESULT( 8 ) = ULPINV
      ELSE IF( ( DIFTRU.GT.THRSH2*DIFEST( 2 ) ) .OR.
     $         ( DIFTRU*THRSH2.LT.DIFEST( 2 ) ) ) THEN
         RESULT( 8 ) = MAX( DIFTRU / DIFEST( 2 ), DIFEST( 2 ) / DIFTRU )
      END IF
*
*     Test (9)
*
      NTEST = 9
      RESULT( 9 ) = ZERO
      IF( LINFO.EQ.( MPLUSN+2 ) ) THEN
         IF( DIFTRU.GT.ABNRM*ULP )
     $      RESULT( 9 ) = ULPINV
         IF( ( IFUNC.GT.1 ) .AND. ( DIFEST( 2 ).NE.ZERO ) )
     $      RESULT( 9 ) = ULPINV
         IF( ( IFUNC.EQ.1 ) .AND. ( PL( 1 ).NE.ZERO ) )
     $      RESULT( 9 ) = ULPINV
      END IF
*
*     Test (10): compare the estimated value of PL and it true value.
*
      NTEST = 10
      RESULT( 10 ) = ZERO
      IF( PL( 1 ).EQ.ZERO ) THEN
         IF( PLTRU.GT.ABNRM*ULP )
     $      RESULT( 10 ) = ULPINV
      ELSE IF( PLTRU.EQ.ZERO ) THEN
         IF( PL( 1 ).GT.ABNRM*ULP )
     $      RESULT( 10 ) = ULPINV
      ELSE IF( ( PLTRU.GT.THRESH*PL( 1 ) ) .OR.
     $         ( PLTRU*THRESH.LT.PL( 1 ) ) ) THEN
         RESULT( 10 ) = ULPINV
      END IF
*
      NTESTT = NTESTT + NTEST
*
*     Print out tests which fail.
*
      DO 120 J = 1, NTEST
         IF( RESULT( J ).GE.THRESH ) THEN
*
*           If this is the first test to fail,
*           print a header to the data file.
*
            IF( NERRS.EQ.0 ) THEN
               WRITE( NOUT, FMT = 9995 )'DGX'
*
*              Matrix types
*
               WRITE( NOUT, FMT = 9994 )
*
*              Tests performed
*
               WRITE( NOUT, FMT = 9992 )'orthogonal', '''',
     $            'transpose', ( '''', I = 1, 4 )
*
            END IF
            NERRS = NERRS + 1
            IF( RESULT( J ).LT.10000.0D0 ) THEN
               WRITE( NOUT, FMT = 9989 )NPTKNT, MPLUSN, J, RESULT( J )
            ELSE
               WRITE( NOUT, FMT = 9988 )NPTKNT, MPLUSN, J, RESULT( J )
            END IF
         END IF
*
  120 CONTINUE
*
  130 CONTINUE
      GO TO 80
  140 CONTINUE
*
  150 CONTINUE
*
*     Summary
*
      CALL ALASVM( 'DGX', NOUT, NERRS, NTESTT, 0 )
*
      WORK( 1 ) = MAXWRK
*
      RETURN
*
 9999 FORMAT( ' DDRGSX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
     $      I6, ', JTYPE=', I6, ')' )
*
 9998 FORMAT( ' DDRGSX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
     $      I6, ', Input Example #', I2, ')' )
*
 9997 FORMAT( ' DDRGSX: DGET53 returned INFO=', I1, ' for eigenvalue ',
     $      I6, '.', / 9X, 'N=', I6, ', JTYPE=', I6, ')' )
*
 9996 FORMAT( ' DDRGSX: S not in Schur form at eigenvalue ', I6, '.',
     $      / 9X, 'N=', I6, ', JTYPE=', I6, ')' )
*
 9995 FORMAT( / 1X, A3, ' -- Real Expert Generalized Schur form',
     $      ' problem driver' )
*
 9994 FORMAT( 'Input Example' )
*
 9993 FORMAT( ' Matrix types: ', /
     $      '  1:  A is a block diagonal matrix of Jordan blocks ',
     $      'and B is the identity ', / '      matrix, ',
     $      / '  2:  A and B are upper triangular matrices, ',
     $      / '  3:  A and B are as type 2, but each second diagonal ',
     $      'block in A_11 and ', /
     $      '      each third diaongal block in A_22 are 2x2 blocks,',
     $      / '  4:  A and B are block diagonal matrices, ',
     $      / '  5:  (A,B) has potentially close or common ',
     $      'eigenvalues.', / )
*
 9992 FORMAT( / ' Tests performed:  (S is Schur, T is triangular, ',
     $      'Q and Z are ', A, ',', / 19X,
     $      ' a is alpha, b is beta, and ', A, ' means ', A, '.)',
     $      / '  1 = | A - Q S Z', A,
     $      ' | / ( |A| n ulp )      2 = | B - Q T Z', A,
     $      ' | / ( |B| n ulp )', / '  3 = | I - QQ', A,
     $      ' | / ( n ulp )             4 = | I - ZZ', A,
     $      ' | / ( n ulp )', / '  5 = 1/ULP  if A is not in ',
     $      'Schur form S', / '  6 = difference between (alpha,beta)',
     $      ' and diagonals of (S,T)', /
     $      '  7 = 1/ULP  if SDIM is not the correct number of ',
     $      'selected eigenvalues', /
     $      '  8 = 1/ULP  if DIFEST/DIFTRU > 10*THRESH or ',
     $      'DIFTRU/DIFEST > 10*THRESH',
     $      / '  9 = 1/ULP  if DIFEST <> 0 or DIFTRU > ULP*norm(A,B) ',
     $      'when reordering fails', /
     $      ' 10 = 1/ULP  if PLEST/PLTRU > THRESH or ',
     $      'PLTRU/PLEST > THRESH', /
     $      '    ( Test 10 is only for input examples )', / )
 9991 FORMAT( ' Matrix order=', I2, ', type=', I2, ', a=', D10.3,
     $      ', order(A_11)=', I2, ', result ', I2, ' is ', 0P, F8.2 )
 9990 FORMAT( ' Matrix order=', I2, ', type=', I2, ', a=', D10.3,
     $      ', order(A_11)=', I2, ', result ', I2, ' is ', 0P, D10.3 )
 9989 FORMAT( ' Input example #', I2, ', matrix order=', I4, ',',
     $      ' result ', I2, ' is', 0P, F8.2 )
 9988 FORMAT( ' Input example #', I2, ', matrix order=', I4, ',',
     $      ' result ', I2, ' is', 1P, D10.3 )
*
*     End of DDRGSX
*
      END