!! ------------------------------------------------------------------------- !!
!>
!! An example code of an implementation of the absorbing boundary condition
!! for tsunami wave propagation: Liner Long Wave (LLW) case
!!
!! @license
!!   (c) 2015 Takuto Maeda, Hiroaki Tsushima, and Takashi Furumura
!!   License: MIT
!!
!!   In addition, the users are suggested to cite the following accompanying
!!   paper when you use this code.
!!
!!   Maeda, T., H. Tsushima, and T. Furumura,
!!   An effective absorbing boundary condition for linear long-wave and
!!   linear dispersive wave tsunami simulations,
!!   in press, 2016.
!!
!<
!! ------------------------------------------------------------------------- !!
program llw

  implicit none

  !! fixed parameters
  integer, parameter :: STDERR  = 0            !< Standard Error
  integer, parameter :: STDOUT  = 6            !< Standard Output
  real,    parameter :: PI      = atan(1.0)*4
  real,    parameter :: g0      = 9.80665      !< gravity
  integer, parameter :: na=20                  !< absorber thickness

  !! control parameters
  integer            :: nx,  ny                !< model size
  integer            :: nt                     !< time step size
  real               :: dx,  dy                !< grid width
  real               :: dt                     !< time step
  character(80)      :: title                  !< model title

  !! derived global variables
  real               :: dxi, dyi               !< inverse grid width
  real               :: xbeg, ybeg             !< model edge
  integer            :: nst                    !< number of stations

  !! arrays
  real,    allocatable :: eta(:,:)             !< tsunami height
  real,    allocatable :: mm(:,:)              !< tsunami vel
  real,    allocatable :: nn(:,:)              !< tsunami vel
  real,    allocatable :: hh(:,:)              !< bathymetry
  real,    allocatable :: hm(:,:)              !< x-averaged bathymetry
  real,    allocatable :: hn(:,:)              !< y-averaged bathymetry
  real,    allocatable :: fh(:,:)              !< land filter
  real,    allocatable :: fm(:,:)              !< land filter
  real,    allocatable :: fn(:,:)              !< land filter
  real,    allocatable :: x(:), y(:)           !< coordinate
  real,    allocatable :: g1x(:,:), g2x(:,:)   !< PML absorber
  real,    allocatable :: g1y(:,:), g2y(:,:)   !< PML absorber
  real,    allocatable :: eta_x(:,:)           !< PML eta(x)
  real,    allocatable :: wav(:,:)             !< waveform at stations
  integer, allocatable :: ist(:), jst(:)       !< station location (i,j)
  real,    allocatable :: xst(:), yst(:)       !< station location (x,y)

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

  !! parameter input
  include "blk_param.f90"

  !! ----------------------------------------------------------------------- !!
  !>
  !! memory allocation
  !<
  !! --
  block

    integer :: i, j

    allocate( eta(1:nx,1:ny) )
    allocate( mm (1:nx,1:ny) )
    allocate( nn (1:nx,1:ny) )
    allocate( hh (1:nx,1:ny) )
    allocate( hm (1:nx,1:ny) )
    allocate( hn (1:nx,1:ny) )
    allocate( fh (1:nx,1:ny) )
    allocate( fm (1:nx,1:ny) )
    allocate( fn (1:nx,1:ny) )
    allocate( g1x(2,nx), g2x(2,nx), g1y(2,ny), g2y(2,ny) )
    allocate( eta_x(nx,ny) )

    eta(:,:) = 0.0
    mm (:,:) = 0.0
    nn (:,:) = 0.0

    allocate( x(nx), y(ny) )
    do i=1, nx
       x(i) = (i-1) * dx + xbeg
    end do
    do j=1, ny
       y(j) = (j-1) * dy + ybeg
    end do

  end block

  include 'blk_initheight.f90'

  include 'blk_bathymetry.f90'

  include 'blk_station.f90'

  !! ----------------------------------------------------------------------- !!
  !>
  !! PML absorber settings
  !<
  !! --
  block

    real :: d1, d2, b1, b2
    integer :: i, j
    real :: d0, b0, R0
    real :: xxb, xxc
    real :: hx
    integer, parameter :: pd = 2
    integer, parameter :: pb = 2
    real,    parameter :: c0 = 500.0 !! assumed phase speed
    !! --

    !! damping profile constants
    hx = na * dx
    R0 = 10**( - ( log10( real(na) ) - 1 ) / log10( 2.0 )  - 3.0 )
    d0 = - ( 1.0 / (2.0*hx) ) * ( pd +1 ) * c0 * log( R0 )
    b0 = 2.0

    !! initialize eta: assume initial amplitude wihtin PML layer is zero
    eta_x(1:nx,1:ny) = 0.0

    !! initialize
    do i=1, 2
       do j=1, nx
          g1x(i,j) = 1.0
          g2x(i,j) = 1.0
       end do
       do j=1, ny
          g1y(i,j) = 1.0
          g2y(i,j) = 1.0
       end do
    end do

    !! set absorber
    do i=1, na

      !! distance from PML boundary
       xxb = max(hx  - (i    ) * dx,0.)
       xxc = max(hx  - (i+0.5) * dx,0.)

       d1 = d0 * ( xxb / hx )**pd
       b1 = 1.0 + ( b0 - 1.0 ) * ( xxb / hx )**pb

       d2 = d0 * ( xxc / hx )**pd
       b2 = 1.0 + ( b0 - 1.0 ) * ( xxc / hx )**pb

       g1x(1,i) = (b1 - d1/2.0*dt) / (b1 + d1/2*dt)
       g1x(2,i) = (b1 - d2/2.0*dt) / (b1 + d2/2*dt)
       g2x(1,i) =  1.0             / (b1 + d1/2*dt)
       g2x(2,i) =  1.0             / (b1 + d2/2*dt)

       g1y(:,i) = g1x(:,i)
       g2y(:,i) = g2x(:,i)

       ! Opposite Side; Exchange Staggered Grid
       g1x(1,nx-i+1) = g1x(2,i)
       g1x(2,nx-i+1) = g1x(1,i)
       g2x(1,nx-i+1) = g2x(2,i)
       g2x(2,nx-i+1) = g2x(1,i)

       g1y(1,ny-i+1) = g1x(2,i)
       g1y(2,ny-i+1) = g1x(1,i)
       g2y(1,ny-i+1) = g2x(2,i)
       g2y(2,ny-i+1) = g2x(1,i)

    end do

  end block

  !! ----------------------------------------------------------------------- !!
  !>
  !! Use 10-m cut off for linear long wave
  !<
  block

    integer :: i, j
    real, parameter :: CUTOFF_DEPTH = 10.0

    do j=1, ny
       do i=1, nx
          if( hh(i,j) < 0.0 ) then
             eta(i,j) = 0.0
          else if ( hh(i,j) < CUTOFF_DEPTH ) then
             hh(i,j) = 10.0
          end if
       end do
    end do

  end block

  !! ----------------------------------------------------------------------- !!
  !>
  !! bathymetry averaging for staggered grid calculation
  !<
  block

    integer :: i, j

    ! x-averaged bathymetry
    do j=1, ny
       hm(1,j) = max( hh(1,j), 0.0 )
       do i=2, nx
          hm(i,j) = ( hh(i,j)+hh(i-1,j) ) / 2.0
          if( hh(i,j) <= 0.0  .or.  hh(i-1,j) <= 0.0 ) hm(i,j) = 0.0
       end do
    end do

    ! y-averaged bathymetry
    do i=1, nx
       do j=2, ny
          hn(i,j) = ( hh(i,j) + hh(i,j-1) ) / 2.0
          if( hh(i,j) <= 0.0  .or.  hh(i,j-1) <= 0.0 ) hn(i,j) = 0.0
       end do
       hn(i,1) = max( hh(i,1), 0.0 )
    end do

  end block

  !! ----------------------------------------------------------------------- !!
  !>
  !! define land-filter matrix for reflection boundaries
  !<
  block

    integer :: i, j

    fm(:,:) = 1.0
    fn(:,:) = 1.0
    fh(:,:) = 1.0

    do j=1, ny
       do i=1, nx
          if( hm(i,j) < 0.0 ) fm(i,j) = 0.0
          if( hn(i,j) < 0.0 ) fn(i,j) = 0.0
          if( hh(i,j) < 0.0 ) fh(i,j) = 0.0
       end do
    end do

  end block

  !! ----------------------------------------------------------------------- !!
  !>
  !! CFL stability condition check
  !<
  block

    if( min(dx,dy)/dt < sqrt( 2*g0*maxval(hh(:,:)) ) ) then
       write(STDERR,*) "ERROR: stability condition is violated: ",  &
            min(dx,dy)/dt,  sqrt( 2*g0*maxval(hh(:,:)) )
       stop
    end if

  end block

  !! ----------------------------------------------------------------------- !!
  !>
  !! time stepping
  !<
  block

    integer :: it
    real :: dxeta(nx,ny), dyeta(nx,ny)
    real :: dxm(nx,ny), dyn(nx,ny)
    !! --

    do it= 1, nt

       if( mod(it,100) == 0 ) then
          write(STDERR,'(A,I4.4,A,I4.4)') trim(title) // &
               ": cycle = ", it, " / ", nt
       end if

       !! ------------------------------------------------------------------ !!
       !>
       !! difference of eta with respect to x, y
       !<
       !! --
       block

         integer :: i, j
         !! --

         do j=1, ny
            do i=2, nx
               dxeta(i,j) = ( eta(i,j) - eta(i-1,j) ) * dxi
            end do
            dxeta(1,j) = ( eta(1,j) -        0.0 ) * dxi
         end do

         do i=1, nx
            do j=2, ny
               dyeta(i,j) = ( eta(i,j) - eta(i,j-1) ) * dyi
            end do
            dyeta(i,1) = ( eta(i,1) -        0.0 ) * dyi
         end do

       end block

       !! ------------------------------------------------------------------ !!
       !>
       !! update velocity in the interior domain
       !<
       !!--
       update_vel: block

         integer :: i, j
         real    :: dtxi, dtyi
         !! --

         dtxi = dt * dxi
         dtyi = dt * dyi

         do j=na+1, ny-na
            do i=na+1, nx-na
               mm(i,j) = mm(i,j) - g0*hm(i,j)*dxeta(i,j)*dt*fm(i,j)
               nn(i,j) = nn(i,j) - g0*hn(i,j)*dyeta(i,j)*dt*fn(i,j)
            end do
         end do

       end block update_vel

       !! ------------------------------------------------------------------ !!
       !>
       !! update velocity in the PML layer
       !<
       !! --
       block

         integer :: i, j
         !! --

         !! South
         do j=1, na
            do i=1, nx
               mm(i,j) = g1x(1,i) * mm(i,j) &
                       - g2x(1,i) * g0 * hm(i,j) * dxeta(i,j) * dt * fm(i,j)
               nn(i,j) = g1y(1,j) * nn(i,j) &
                       - g2y(1,j) * g0 * hn(i,j) * dyeta(i,j) * dt * fn(i,j)
            end do
         end do

         !! North
         do j=ny-na+1,ny
            do i=1, nx
               mm(i,j) = g1x(1,i) * mm(i,j) &
                       - g2x(1,i) * g0 * hm(i,j) * dxeta(i,j) * dt * fm(i,j)
               nn(i,j) = g1y(1,j) * nn(i,j) &
                       - g2y(1,j) * g0 * hn(i,j) * dyeta(i,j) * dt * fn(i,j)
            end do
         end do

         !! West
         do j=na+1, ny-na
            do i=1, na
               mm(i,j) = g1x(1,i) * mm(i,j) &
                       - g2x(1,i) * g0 * hm(i,j) * dxeta(i,j) * dt * fm(i,j)
               nn(i,j) = g1y(1,j) * nn(i,j) &
                       - g2y(1,j) * g0 * hn(i,j) * dyeta(i,j) * dt * fn(i,j)
            end do
         end do

         !! East
         do j=na+1, ny-na
            do i=nx-na+1,nx
               mm(i,j) = g1x(1,i) * mm(i,j) &
                       - g2x(1,i) * g0 * hm(i,j) * dxeta(i,j) * dt * fm(i,j)
               nn(i,j) = g1y(1,j) * nn(i,j) &
                       - g2y(1,j) * g0 * hn(i,j) * dyeta(i,j) * dt * fn(i,j)
            end do
         end do

       end block

       !! ------------------------------------------------------------------ !!
       !>
       !! difference of velocities with respect to x, y
       !<
       !! --
       block

         integer :: i, j
         !! --

         do j=1, ny
            dxm(nx,j) = ( 0.0 - mm(nx,j)  ) * dxi
            do i=1, nx-1
               dxm(i,j) = ( mm(i+1,j) - mm(i,j) ) * dxi
            end do
         end do

         do i=1, nx
            dyn(i,ny) = ( 0.0 - nn(i,ny) ) * dyi
            do j=1, ny-1
               dyn(i,j) = ( nn(i,j+1) - nn(i,j) ) * dyi
            end do
         end do

       end block

       !! ------------------------------------------------------------------ !!
       block

         integer i, j
         real :: dtxi, dtyi
         !! --

         dtxi = dt * dxi
         dtyi = dt * dyi

         do j=na+1, ny-na
            do i=na+1, nx-na
               eta(i,j) =  eta(i,j) - ( dxm(i,j) +  dyn(i,j) )*dt * fh(i,j)
            end do
         end do

       end block

       !! ------------------------------------------------------------------ !!
       block

         integer :: i, j
         real :: eta_y
         !! --

         do j=1, na
            do i=1, nx
               eta_y = eta(i,j) - eta_x(i,j)

               eta_x(i,j) = g1x(2,i) * eta_x(i,j) - g2x(2,i) * dxm(i,j) * dt
               eta_y      = g1y(2,j) * eta_y      - g2y(2,j) * dyn(i,j) * dt

               eta(i,j) = ( eta_x(i,j) + eta_y ) * fh(i,j)

            end do
         end do

         do j=ny-na+1,ny
            do i=1, nx
               eta_y = eta(i,j) - eta_x(i,j)

               eta_x(i,j) = g1x(2,i) * eta_x(i,j) - g2x(2,i) * dxm(i,j) * dt
               eta_y      = g1y(2,j) * eta_y      - g2y(2,j) * dyn(i,j) * dt

               eta(i,j) = ( eta_x(i,j) + eta_y ) * fh(i,j)
            end do
         end do

         do j=na+1, ny-na
            do i=1, na
               eta_y = eta(i,j) - eta_x(i,j)

               eta_x(i,j) = g1x(2,i) * eta_x(i,j) - g2x(2,i) * dxm(i,j) * dt
               eta_y      = g1y(2,j) * eta_y      - g2y(2,j) * dyn(i,j) * dt

               eta(i,j) = ( eta_x(i,j) + eta_y ) * fh(i,j)
            end do
         end do

         do j=na+1, ny-na
            do i=nx-na+1,nx
               eta_y = eta(i,j) - eta_x(i,j)

               eta_x(i,j) = g1x(2,i) * eta_x(i,j) - g2x(2,i) * dxm(i,j) * dt
               eta_y      = g1y(2,j) * eta_y      - g2y(2,j) * dyn(i,j) * dt

               eta(i,j) = ( eta_x(i,j) + eta_y ) * fh(i,j)
            end do
         end do

       end block

       !! ------------------------------------------------------------------ !!
       block

         integer :: i

         do i=1, nst
            wav(i,it) = eta( ist(i), jst(i) )
         end do

       end block

    end do

  end block

  !! ----------------------------------------------------------------------- !!
  block

    integer :: i, it
    character(256) :: fn
    integer, parameter :: io = 100
    !! --

    do i=1, nst
       write(fn,'(A,I3.3,A)') trim(adjustl(title))//'_', i, '.wav'
       open(io, file=fn, action='write', status='unknown' )
       do it=0, nt
          write(io,*) it*dt, wav(i,it)
       end do
       close(io)
    end do

  end block

  !! ----------------------------------------------------------------------- !!
  block

    deallocate( eta )
    deallocate( mm  )
    deallocate( nn  )
    deallocate( hh  )
    deallocate( hm  )
    deallocate( hn  )
    deallocate( fh  )
    deallocate( fm  )
    deallocate( fn  )
    deallocate( x, y )
    deallocate( ist, jst, xst, yst )
    deallocate( wav )
    deallocate( g1x, g2x, g1y, g2y )
    deallocate( eta_x )

  end block

end program llw
!! ------------------------------------------------------------------------- !!


c***********************************************************************
c	                    COORD_VB2H.F
c***********************************************************************
*     PURPOSE: Converts from Barycentric to Helio coords.
*               Velocity only
*     ARGUMENTS:  Input is
*                    nbod ==> number of bodies (must be less than NBMAX)
*                             (integer)
*	             mass(*) ==>  masses (real array)
*                                 NOT USED BUT INCLUDED IN ORDER TO HAVE
*                                 SYMMETRY IN SUBROUTINE CALLS
*		     vxb(*),vyb(*),vzb(*) ==> Barycentric particle velocities
*                                             (real array)
*                 Returned are
*                    vxh(*),vyh(*),vzh(*) ==> Helio particle velocities
*                                            (real array)
*
*     ALGORITHM: Obvious
*     Authors:  Hal Levison
*     WRITTEN:  11/14/96
*     REVISIONS: 11/21/96

      subroutine coord_vb2h(nbod,mass,vxb,vyb,vzb,vxh,vyh,vzh)

      include '../swift.inc'

c...  Inputs:
      integer nbod
      real*8 mass(nbod)
      real*8 vxb(nbod),vyb(nbod),vzb(nbod)

c...  Outputs:
      real*8 vxh(nbod),vyh(nbod),vzh(nbod)

c...  Internals:
      integer i

c----
c...  Executable code

	vxb(1) = - mass(2)*vxb(2)
	vyb(1) = - mass(2)*vyb(2)
	vzb(1) = - mass(2)*vzb(2)

	do i=3,nbod
	   vxb(1) = vxb(1) - mass(i)*vxb(i)
	   vyb(1) = vyb(1) - mass(i)*vyb(i)
	   vzb(1) = vzb(1) - mass(i)*vzb(i)
	enddo

	vxb(1) = vxb(1)/mass(1)
	vyb(1) = vyb(1)/mass(1)
	vzb(1) = vzb(1)/mass(1)

	do i=2,nbod
	   vxh(i) = vxb(i)  - vxb(1)
	   vyh(i) = vyb(i)  - vyb(1)
	   vzh(i) = vzb(i)  - vzb(1)
	enddo

	return
	end     ! coord_vb2h

c--------------------------------------------------------------------------


module BoxLibRNGs
   ! These are written in C and part of BoxLib
   use Random_Numbers ! Used to generate unpredictable seeds or initial seeds for Marsenne twister
   use NonUniformRNGs ! Generates samples from several nonuniform distributions (we use our own for Guassian)
   implicit none
   public

   integer, parameter, private :: dp=kind(0.0d0)

   ! These are written in C and part of BoxLib
   interface SeedRNG_C
      subroutine srandgen(seed) bind(c)
         ! Seed the generator (should be called at the beginning)
         ! Use the shell script $RANDOM to generate a truly random seed
         integer, value :: seed
      end subroutine
   end interface

! This is not used at present and since it requires a C++ compiler I leave it out here
!   interface SeedParallelRNG_C
!      subroutine SeedParallelRNG(seed) bind(c, name="SeedParallelRNG")
!         ! Seed the generator on each processor (should be called at the beginning)
!         ! This requires MPI to be initialized and running and is compiled with C++
!         integer, value :: seed
!      end subroutine
!   end interface

   interface UniformInteger
      ! void genrandint (const gsl_rng * r, unsigned long int n)
      subroutine genrandint(number, range) bind(c)
         ! Returns an integer uniformly distributed in the range [1,range]
         import
         integer, intent(out) :: number
         integer, intent(in), value :: range
      end subroutine
   end interface

   interface UniformRNG
      subroutine genrand(number) bind(c)
         ! Returns pseudorandom number in interval [0,1).
         import
         real(dp), intent(out) :: number
      end subroutine
   end interface

   interface NormalRNG  ! The Fortran version of this is below and may be faster
      subroutine genrandn(number) bind(c)
         ! Returns a normally-distributed number with mean 0 and variance 1
         import
         real(dp), intent(out) :: number
      end subroutine
   end interface

contains ! It is likely that vectorized versions will do better here

   ! This is in principle callable by C directly, but we go through the wrapper here for safety
   ! void SeedRNG(int *seed); // On output, the actual seed used
   !
   subroutine SeedRNG(seed) BIND(C,NAME="SeedRNG")
      integer, intent(inout) :: seed ! If zero, the clock will be used to find an unpredictable seed

      if(seed==0) then
         call UnpredictableSeeds(seed)
         write(*,*) "SeedRNG @ BoxLibRNGs: Generated unpredictable SEED=", seed
      end if

      call SeedRNG_C(seed)

   end subroutine SeedRNG

  subroutine UniformRNGs(numbers, n_numbers)
    integer, intent(in) :: n_numbers
    real(dp), intent(out) :: numbers(n_numbers)

    integer :: i

    do i=1, n_numbers
       call UniformRNG(numbers(i)) ! Marsenne-Twister in C
    end do

  end subroutine UniformRNGs

  subroutine NormalRNGs(numbers, n_numbers)
    integer, intent(in) :: n_numbers
    real(dp), intent(out) :: numbers(n_numbers)

    integer :: i

    do i=1, n_numbers
       call NormalRNG(numbers(i))
    end do

  end subroutine NormalRNGs

  subroutine NormalRNG_Fortran(invnormdist)
      ! This is the Fortran equivalent of the C blinvnormdist, just for the record
      real(dp), intent(inout) :: invnormdist

      real(dp)     :: p

      real(dp) ::  q,r
      real(dp), parameter :: a1=-39.6968302866538d0
      real(dp), parameter :: a2=220.946098424521d0
      real(dp), parameter :: a3=-275.928510446969d0
      real(dp), parameter :: a4=138.357751867269d0
      real(dp), parameter :: a5=-30.6647980661472d0
      real(dp), parameter :: a6=2.50662827745924d0
      real(dp), parameter :: b1=-54.4760987982241d0
      real(dp), parameter :: b2=161.585836858041d0
      real(dp), parameter :: b3=-155.698979859887d0
      real(dp), parameter :: b4=66.8013118877197d0
      real(dp), parameter :: b5=-13.2806815528857d0
      real(dp), parameter :: c1=-0.00778489400243029d0
      real(dp), parameter :: c2=-0.322396458041136d0
      real(dp), parameter :: c3=-2.40075827716184d0
      real(dp), parameter :: c4=-2.54973253934373d0
      real(dp), parameter :: c5=4.37466414146497d0
      real(dp), parameter :: c6=2.93816398269878d0
      real(dp), parameter :: d1=0.00778469570904146d0
      real(dp), parameter :: d2=0.32246712907004d0
      real(dp), parameter :: d3=2.445134137143d0
      real(dp), parameter :: d4=3.75440866190742d0
      real(dp), parameter :: p_low=0.02425d0
      real(dp), parameter :: p_high=0.9575d0

      call UniformRNG(p)

      if(p.lt.p_low) then
         q=dsqrt(-2.d0*dlog(p))
         invnormdist = (((((c1*q+c2)*q+c3)*q+c4)*q+c5)*q+c6)/   &
             ((((d1*q+d2)*q+d3)*q+d4)*q+1.d0)
      elseif (p.le.p_high)then
         q=p-0.5d0
         r=q*q
         invnormdist = (((((a1*r+a2)*r+a3)*r+a4)*r+a5)*r+a6)*q/  &
                   (((((b1*r+b2)*r+b3)*r+b4)*r+b5)*r+1.d0)
      else
         q=dsqrt(-2.d0*dlog(1.d0-p))
         invnormdist = -(((((c1*q+c2)*q+c3)*q+c4)*q+c5)*q+c6)/   &
               ((((d1*q+d2)*q+d3)*q+d4)*q+1.d0)
      endif

  end subroutine

  subroutine NormalRNGFast(p)
  real(dp)     :: u,p
  real(dp), parameter :: f = 3.46410161514d0

  call UniformRNG(u)
  p = f*(u-0.5_dp)

  end subroutine NormalRNGFast

 SUBROUTINE PoissonNumber(number,mean)
    INTEGER, INTENT(OUT) :: number
    REAL(dp), INTENT(IN) :: mean

    number=random_Poisson(mu=real(mean), first=.true.)

 END SUBROUTINE

end module


function vrefmod(z,ips)
real zref(600)
common/refmod/nref,href(600),vref(600,2)

zref=href
if(nref.eq.0) then
	write(*,*)' the reference model is not defined!'
	pause
end if

!write(*,*)' z=',z,hmod(1),hmod(nref)
if(z.le.zref(1))then
	vrefmod=vref(ips,1)
else if(z.ge.zref(nref)) then
	z1=zref(nref-1)
	z2=zref(nref)
	v1=vref(ips,nref-1)
	v2=vref(ips,nref)
	vrefmod=v1+((v2-v1)/(z2-z1))*(z-z1)
else
	do i=1,nref-1
		z1=zref(i)
		z2=zref(i+1)
		v1=vref(ips,i)
		v2=vref(ips,i+1)
		if((z1-z)*(z2-z).gt.0.) cycle
		vrefmod=v1+((v2-v1)/(z2-z1))*(z-z1)
		exit
	end do
end if

return
end


      SUBROUTINE MB3JZP( COMPQ, N, A, LDA, D, LDD, B, LDB, F, LDF, Q,
     $                   LDQ, NEIG, TOL, DWORK, ZWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To move the eigenvalues with strictly negative real parts of an
C     N-by-N complex skew-Hamiltonian/Hamiltonian pencil aS - bH in
C     structured Schur form to the leading principal subpencil, while
C     keeping the triangular form. On entry, we have
C
C           (  A  D  )      (  B  F  )
C       S = (        ), H = (        ),
C           (  0  A' )      (  0 -B' )
C
C     where A and B are upper triangular.
C     S and H are transformed by a unitary matrix Q such that
C
C                            (  Aout  Dout  )
C       Sout = J Q' J' S Q = (              ), and
C                            (    0   Aout' )
C                                                                    (1)
C                            (  Bout  Fout  )           (  0  I  )
C       Hout = J Q' J' H Q = (              ), with J = (        ),
C                            (    0  -Bout' )           ( -I  0  )
C
C     where Aout and Bout remain in upper triangular form. The notation
C     M' denotes the conjugate transpose of the matrix M.
C     Optionally, if COMPQ = 'I' or COMPQ = 'U', the unitary matrix Q
C     that fulfills (1) is computed.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPQ   CHARACTER*1
C             Specifies whether or not the unitary transformations
C             should be accumulated in the array Q, as follows:
C             = 'N':  Q is not computed;
C             = 'I':  the array Q is initialized internally to the unit
C                     matrix, and the unitary matrix Q is returned;
C             = 'U':  the array Q contains a unitary matrix Q0 on
C                     entry, and the matrix Q0*Q is returned, where Q
C                     is the product of the unitary transformations
C                     that are applied to the pencil aS - bH to reorder
C                     the eigenvalues.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the pencil aS - bH.  N >= 0, even.
C
C     A       (input/output) COMPLEX*16 array, dimension (LDA, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular matrix A.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Aout.
C             The strictly lower triangular part of this array is not
C             referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1, N/2).
C
C     D       (input/output) COMPLEX*16 array, dimension (LDD, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular part of the skew-Hermitian
C             matrix D.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Dout.
C             The strictly lower triangular part of this array is not
C             referenced.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= MAX(1, N/2).
C
C     B       (input/output) COMPLEX*16 array, dimension (LDB, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular matrix B.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Bout.
C             The strictly lower triangular part of this array is not
C             referenced.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1, N/2).
C
C     F       (input/output) COMPLEX*16 array, dimension (LDF, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular part of the Hermitian matrix
C             F.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Fout.
C             The strictly lower triangular part of this array is not
C             referenced.
C
C     LDF     INTEGER
C             The leading dimension of the array F.  LDF >= MAX(1, N/2).
C
C     Q       (input/output) COMPLEX*16 array, dimension (LDQ, N)
C             On entry, if COMPQ = 'U', then the leading N-by-N part of
C             this array must contain a given matrix Q0, and on exit,
C             the leading N-by-N part of this array contains the product
C             of the input matrix Q0 and the transformation matrix Q
C             used to transform the matrices S and H.
C             On exit, if COMPQ = 'I', then the leading N-by-N part of
C             this array contains the unitary transformation matrix Q.
C             If COMPQ = 'N' this array is not referenced.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.
C             LDQ >= 1,         if COMPQ = 'N';
C             LDQ >= MAX(1, N), if COMPQ = 'I' or COMPQ = 'U'.
C
C     NEIG    (output) INTEGER
C             The number of eigenvalues in aS - bH with strictly
C             negative real part.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance used to decide the sign of the eigenvalues.
C             If the user sets TOL > 0, then the given value of TOL is
C             used. If the user sets TOL <= 0, then an implicitly
C             computed, default tolerance, defined by MIN(N,10)*EPS, is
C             used instead, where EPS is the machine precision (see
C             LAPACK Library routine DLAMCH). A larger value might be
C             needed for pencils with multiple eigenvalues.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (N/2)
C
C     ZWORK   COMPLEX*16 array, dimension (N/2)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: succesful exit;
C             < 0: if INFO = -i, the i-th argument had an illegal value.
C
C     METHOD
C
C     The algorithm reorders the eigenvalues like the following scheme:
C
C     Step 1: Reorder the eigenvalues in the subpencil aA - bB.
C          I. Reorder the eigenvalues with negative real parts to the
C             top.
C         II. Reorder the eigenvalues with positive real parts to the
C             bottom.
C
C     Step 2: Reorder the remaining eigenvalues with negative real parts.
C          I. Exchange the eigenvalues between the last diagonal block
C             in aA - bB and the last diagonal block in aS - bH.
C         II. Move the eigenvalues in the N/2-th place to the (MM+1)-th
C             place, where MM denotes the current number of eigenvalues
C             with negative real parts in aA - bB.
C
C     The algorithm uses a sequence of unitary transformations as
C     described on page 43 in [1]. To achieve those transformations the
C     elementary SLICOT Library subroutines MB03DZ and MB03HZ are called
C     for the corresponding matrix structures.
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
C         Numerical Computation of Deflating Subspaces of Embedded
C         Hamiltonian Pencils.
C         Tech. Rep. SFB393/99-15, Technical University Chemnitz,
C         Germany, June 1999.
C
C     NUMERICAL ASPECTS
C                                                               3
C     The algorithm is numerically backward stable and needs O(N )
C     complex floating point operations.
C
C     FURTHER COMMENTS
C
C     For large values of N, the routine applies the transformations on
C     panels of columns. The user may specify in INFO the desired number
C     of columns. If on entry INFO <= 0, then the routine estimates a
C     suitable value of this number.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Jan. 2011.
C     M. Voigt, Max Planck Institute for Dynamics of Complex Technical
C     Systems, Dec. 2011.
C
C     REVISIONS
C
C     V. Sima, June 2013, June 2014, Nov. 2014.
C     M. Voigt, July 2013, July 2014.
C
C     KEYWORDS
C
C     Eigenvalue reordering, upper triangular matrix,
C     skew-Hamiltonian/Hamiltonian pencil, structured Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, TEN
      PARAMETER          ( ZERO = 0.0D+0, TEN = 1.0D+1 )
      COMPLEX*16         CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ), CONE = ( 1.0D+0,
     $                     0.0D+0 ) )
C
C     .. Scalar Arguments ..
      CHARACTER          COMPQ
      INTEGER            INFO, LDA, LDB, LDD, LDF, LDQ, N, NEIG
      DOUBLE PRECISION   TOL
C
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), B( LDB, * ), D( LDD, * ),
     $                   F( LDF, * ), Q( LDQ, * ), ZWORK( * )
      DOUBLE PRECISION   DWORK( * )
C
C     .. Local Scalars ..
      LOGICAL            LCMPQ, LINIQ, LUPDQ
      INTEGER            IC, ICS, IUPD, J, JE, JS, K, M, M1, MM, MP, NB,
     $                   NC, UPDS
      DOUBLE PRECISION   CO1, CO2, EPS
      COMPLEX*16         CJF, SI1, SI2, TMP
C
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, LSAME
C
C     .. External Subroutines ..
      EXTERNAL           MB03DZ, MB03HZ, XERBLA, ZGEQRF, ZLASET, ZROT
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C
      NB    = INFO
      M     = N/2
      M1    = MAX( 1, M )
      NEIG  = 0
      LINIQ = LSAME( COMPQ, 'I' )
      LUPDQ = LSAME( COMPQ, 'U' )
      LCMPQ = LINIQ .OR. LUPDQ
C
C     Test the input arguments.
C
      INFO = 0
      IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.M1 ) THEN
         INFO = -4
      ELSE IF( LDD.LT.M1 ) THEN
         INFO = -6
      ELSE IF( LDB.LT.M1 ) THEN
         INFO = -8
      ELSE IF( LDF.LT.M1 ) THEN
         INFO = -10
      ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N ) ) THEN
         INFO = -12
      END IF
      IF( INFO.NE.0) THEN
         CALL XERBLA( 'MB3JZP', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
C     A block algorithm is used for large M.
C
      IF( NB.LE.0 ) THEN
         CALL ZGEQRF( M, M, A, LDA, ZWORK, ZWORK, -1, INFO )
         NB = MIN( MAX( INT( ZWORK( 1 ) )/M1, 2 ), M )
      END IF
C
      EPS = TOL
      IF ( EPS.LE.ZERO ) THEN
C
C        Use the default tolerance.
C
         EPS = MIN( DBLE( N ), TEN )*DLAMCH( 'Precision' )
      END IF
C
C     STEP 0. Initializations.
C
      IF( LINIQ ) THEN
         IUPD = M + 1
         UPDS = M
         CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
      ELSE IF( LUPDQ ) THEN
         IUPD = 1
         UPDS = N
      END IF
C
C     STEP 1. Reorder the eigenvalues in the subpencil aA - bB.
C
      MM = 0
      MP = M + 1
C
C     I. Reorder the eigenvalues with negative real parts to the top.
C
      DO 180 K = 1, M
         IF(  DBLE( A( K, K ) )* DBLE( B( K, K ) ) +
     $       DIMAG( A( K, K ) )*DIMAG( B( K, K ) ).LT.
     $        -ABS( A( K, K ) )*  ABS( B( K, K ) )*EPS ) THEN
C
            JS = K
            JE = MIN( M, JS+NB-1 )
            IC = 1
            DO 10 J = K - 1, MM + 1, -1
C
C              Perform eigenvalue exchange.
C
               CALL MB03DZ( A( J, J ), LDA, B( J, J ), LDB, CO1, SI1,
     $                      CO2, SI2 )
               DWORK( IC ) =  CO2
               ZWORK( IC ) = -SI2
               IC = IC + 1
C
C              Update A and D.
C
               CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 )
               A( J, J )     = CO2*A( J, J ) +
     $                         SI2*A( J+1, J+1 )*DCONJG( SI1 )
               A( J+1, J+1 ) = CO1*A( J+1, J+1 )
C
               CJF = -DCONJG( D( J, J+1 ) )
               TMP = CO2*CJF - DCONJG( SI2 )*D( J+1, J+1 )
               CALL ZROT( J, D( 1, J+1 ), 1, D( 1, J ), 1, CO2, SI2 )
               D( J, J )     = CO2*D( J, J )     - SI2*TMP
               D( J+1, J+1 ) = CO2*D( J+1, J+1 ) + SI2*CJF
C
C              Update B and F.
C
               CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 )
               B( J, J )     = CO2*B( J, J ) +
     $                         SI2*B( J+1, J+1 )*DCONJG( SI1 )
               B( J+1, J+1 ) = CO1*B( J+1, J+1 )
C
               CJF = DCONJG( F( J, J+1 ) )
               TMP = CO2*CJF - DCONJG( SI2 )*F( J+1, J+1 )
               CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO2, SI2 )
               F( J, J )     = CO2*F( J, J )     - SI2*TMP
               F( J+1, J+1 ) = CO2*F( J+1, J+1 ) + SI2*CJF
C
               IF( LCMPQ ) THEN
C
C                 Update Q.
C
                  CALL ZROT( UPDS, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1,
     $                       SI1 )
                  CALL ZROT( UPDS, Q( IUPD, M+J+1 ), 1, Q( IUPD, M+J ),
     $                       1, CO2, SI2 )
               END IF
   10       CONTINUE
C
C           Panel Updates.
C
C           Update A.
C
            ICS = 1
            JE  = K - 1
C
C           WHILE( JE.GT.2 ) DO
   20       CONTINUE
            IF( JE.GE.MM+1 ) THEN
               NC  = 0
               IC  = ICS
               ICS = ICS + NB
               DO 30 J = JE, MM + 1, -1
                  NC = MIN( NC+1, NB )
                  JS = JE - NC + 1
                  CALL ZROT( NC, A( J, JS+1 ), LDA, A( J+1, JS+1 ), LDA,
     $                       DWORK( IC ), ZWORK( IC ) )
                  IC = IC + 1
   30          CONTINUE
               JE = JE - NB
               GO TO 20
            END IF
C           END WHILE 20
C
            DO 50 JS = K, M-1, NB
               JE = MIN( M-1, JS+NB-1 )
               NC = JE - JS + 1
               IC = 1
               DO 40 J = K - 1, MM + 1, -1
                  CALL ZROT( NC, A( J, JS+1 ), LDA, A( J+1, JS+1 ), LDA,
     $                       DWORK( IC ), ZWORK( IC ) )
                  IC = IC + 1
   40          CONTINUE
   50       CONTINUE
C
C           Update B.
C
            ICS = 1
            JE  = K - 1
C
C           WHILE( JE.GT.2 ) DO
   60       CONTINUE
            IF( JE.GE.MM+1 ) THEN
               NC  = 0
               IC  = ICS
               ICS = ICS + NB
               DO 70 J = JE, MM + 1, -1
                  NC = MIN( NC+1, NB )
                  JS = JE - NC + 1
                  CALL ZROT( NC, B( J, JS+1 ), LDB, B( J+1, JS+1 ), LDB,
     $                       DWORK( IC ), ZWORK( IC ) )
                  IC = IC + 1
   70          CONTINUE
               JE = JE - NB
               GO TO 60
            END IF
C           END WHILE 60
C
            DO 90 JS = K, M-1, NB
               JE = MIN( M-1, JS+NB-1 )
               NC = JE - JS + 1
               IC = 1
               DO 80 J = K - 1, MM + 1, -1
                  CALL ZROT( NC, B( J, JS+1 ), LDB, B( J+1, JS+1 ), LDB,
     $                       DWORK( IC ), ZWORK( IC ) )
                  IC = IC + 1
   80          CONTINUE
   90       CONTINUE
C
C           Update D.
C
            ICS = 1
            JE  = K - 1
C
C           WHILE( JE.GT.2 ) DO
  100       CONTINUE
            IF( JE.GE.MM+1 ) THEN
               NC  = 0
               IC  = ICS
               ICS = ICS + NB
               DO 110 J = JE, MM + 1, -1
                  NC = MIN( NC+1, NB )
                  JS = JE - NC + 1
                  CALL ZROT( NC, D( J, JS+1 ), LDD, D( J+1, JS+1 ), LDD,
     $                       DWORK( IC ), ZWORK( IC ) )
                  IC = IC + 1
  110          CONTINUE
               JE = JE - NB
               GO TO 100
            END IF
C           END WHILE 100
C
            DO 130 JS = K, M-1, NB
               JE = MIN( M-1, JS+NB-1 )
               NC = JE - JS + 1
               IC = 1
               DO 120 J = K - 1, MM + 1, -1
                  CALL ZROT( NC, D( J, JS+1 ), LDD, D( J+1, JS+1 ), LDD,
     $                       DWORK( IC ), ZWORK( IC ) )
                  IC = IC + 1
  120          CONTINUE
  130       CONTINUE
C
C           Update F.
C
            ICS = 1
            JE  = K - 1
C
C           WHILE( JE.GT.2 ) DO
  140       CONTINUE
            IF( JE.GE.MM+1 ) THEN
               NC  = 0
               IC  = ICS
               ICS = ICS + NB
               DO 150 J = JE, MM + 1, -1
                  NC = MIN( NC+1, NB )
                  JS = JE - NC + 1
                  CALL ZROT( NC, F( J, JS+1 ), LDF, F( J+1, JS+1 ), LDF,
     $                       DWORK( IC ), ZWORK( IC ) )
                  IC = IC + 1
  150          CONTINUE
               JE = JE - NB
               GO TO 140
            END IF
C           END WHILE 140
C
            DO 170 JS = K, M-1, NB
               JE = MIN( M-1, JS+NB-1 )
               NC = JE - JS + 1
               IC = 1
               DO 160 J = K - 1, MM + 1, -1
                  CALL ZROT( NC, F( J, JS+1 ), LDF, F( J+1, JS+1 ), LDF,
     $                       DWORK( IC ), ZWORK( IC ) )
                  IC = IC + 1
  160          CONTINUE
  170       CONTINUE
C
            MM = MM + 1
         END IF
  180 CONTINUE
C
C     II. Reorder the eigenvalues with positive real parts to the bottom.
C
      DO 280 K = M, MM + 1, -1
         IF(  DBLE( A( K, K ) )* DBLE( B( K, K ) ) +
     $       DIMAG( A( K, K ) )*DIMAG( B( K, K ) ).GT.
     $         ABS( A( K, K ) )*  ABS( B( K, K ) )*EPS ) THEN
C
            IC = 1
            DO 190 J = K, MP - 2
C
C              Perform eigenvalue exchange.
C
               CALL MB03DZ( A( J, J ), LDA, B( J, J ), LDB, CO1, SI1,
     $                      CO2, SI2 )
               DWORK( IC ) =  CO2
               ZWORK( IC ) = -SI2
               IC = IC + 1
C
C              Update A and D.
C
               CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 )
               A( J, J )     = CO2*A( J, J ) +
     $                         SI2*A( J+1, J+1 )*DCONJG( SI1 )
               A( J+1, J+1 ) = CO1*A( J+1, J+1 )
               CALL ZROT( MP-J-1, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA,
     $                    CO2, -SI2 )
C
               CJF = -DCONJG( D( J, J+1 ) )
               TMP = CO2*CJF - DCONJG( SI2 )*D( J+1, J+1 )
               CALL ZROT( J, D( 1, J+1 ), 1, D( 1, J ), 1, CO2, SI2 )
               D( J, J )     = CO2*D( J, J )     - SI2*TMP
               D( J+1, J+1 ) = CO2*D( J+1, J+1 ) + SI2*CJF
               CALL ZROT( MP-J-1, D( J, J+1 ), LDD, D( J+1, J+1 ), LDD,
     $                    CO2, -SI2 )
C
C              Update B and F.
C
               CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 )
               B( J, J )     = CO2*B( J, J ) +
     $                         SI2*B( J+1, J+1 )*DCONJG( SI1 )
               B( J+1, J+1 ) = CO1*B( J+1, J+1 )
               CALL ZROT( MP-J-1, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB,
     $                    CO2, -SI2 )
C
               CJF = DCONJG( F( J, J+1 ) )
               TMP = CO2*CJF - DCONJG( SI2 )*F( J+1, J+1 )
               CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO2, SI2 )
               F( J, J )     = CO2*F( J, J )     - SI2*TMP
               F( J+1, J+1 ) = CO2*F( J+1, J+1 ) + SI2*CJF
               CALL ZROT( MP-J-1, F( J, J+1 ), LDF, F( J+1, J+1 ), LDF,
     $                    CO2, -SI2 )
C
               IF( LCMPQ ) THEN
C
C                 Update Q.
C
                  CALL ZROT( UPDS, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1,
     $                       SI1 )
                  CALL ZROT( UPDS, Q( IUPD, M+J+1 ), 1, Q( IUPD, M+J ),
     $                       1, CO2, SI2 )
               END IF
  190       CONTINUE
C
C           Panel Updates.
C
C           Update A.
C
            ICS = 1
            DO 210 JS = MP, M, NB
               IC = ICS
               JE = MIN( JS+NB, M )
               NC = MIN( NB, JE-JS+1 )
               DO 200 J = K, MP-2
                  CALL ZROT( NC, A( J, JS ), LDA, A( J+1, JS ),
     $                       LDA, DWORK( IC ), ZWORK( IC ) )
                  IC = IC + 1
  200          CONTINUE
  210       CONTINUE
C
C           Update D.
C
            ICS = 1
            DO 230 JS = MP, M, NB
               IC = ICS
               JE = MIN( JS+NB, M )
               NC = MIN( NB, JE-JS+1 )
               DO 220 J = K, MP-2
                  CALL ZROT( NC, D( J, JS ), LDD, D( J+1, JS ),
     $                       LDD, DWORK( IC ), ZWORK( IC ) )
                  IC = IC + 1
  220          CONTINUE
  230       CONTINUE
C
C           Update B.
C
            ICS = 1
            DO 250 JS = MP, M, NB
               IC = ICS
               JE = MIN( JS+NB, M )
               NC = MIN( NB, JE-JS+1 )
               DO 240 J = K, MP-2
                  CALL ZROT( NC, B( J, JS ), LDB, B( J+1, JS ),
     $                       LDB, DWORK( IC ), ZWORK( IC ) )
                  IC = IC + 1
  240          CONTINUE
  250       CONTINUE
C
C           Update F.
C
            ICS = 1
            DO 270 JS = MP, M, NB
               IC = ICS
               JE = MIN( JS+NB, M )
               NC = MIN( NB, JE-JS+1 )
               DO 260 J = K, MP-2
                  CALL ZROT( NC, F( J, JS ), LDF, F( J+1, JS ),
     $                       LDF, DWORK( IC ), ZWORK( IC ) )
                  IC = IC + 1
  260          CONTINUE
  270       CONTINUE
C
            MP = MP - 1
         END IF
  280 CONTINUE
C
C
C     The remaining M-MP+1 eigenvalues with negative real part are now in
C     the bottom right subpencil of aS - bH.
C
C     STEP 2. Reorder the remaining M-MP+1 eigenvalues.
C
      DO 380 K = M, MP, -1
C
C        I. Exchange the eigenvalues between two diagonal blocks.
C
C        Perform eigenvalue exchange.
C
         CALL MB03HZ( A( M, M ), D( M, M ), B( M, M ), F( M, M ), CO1,
     $                SI1 )
C
C        Update A and D.
C
         TMP = DCONJG( A( M, M ) )
         CALL ZROT( M, D( 1, M ), 1, A( 1, M ), 1, CO1, SI1 )
         A( M, M ) = A( M, M )*CO1 + TMP*DCONJG( SI1 )**2
         D( M, M ) = D( M, M )*CO1 - TMP*DCONJG( SI1 )*CO1
C
C        Update B and F.
C
         TMP = -DCONJG( B( M, M ) )
         CALL ZROT( M, F( 1, M ), 1, B( 1, M ), 1, CO1, SI1 )
         B( M, M ) = B( M, M )*CO1 + TMP*DCONJG( SI1 )**2
         F( M, M ) = F( M, M )*CO1 - TMP*DCONJG( SI1 )*CO1
C
         IF( LCMPQ ) THEN
C
C           Update Q.
C
            CALL ZROT( N, Q( 1, N ), 1, Q( 1, M ), 1, CO1, SI1 )
         END IF
C
C        II. Move the eigenvalue in the M-th diagonal position to the
C            (MM+1)-th position.
C
         MM = MM + 1
         IC = 1
         DO 290 J = M - 1, MM, -1
C
C           Perform eigenvalue exchange.
C
            CALL MB03DZ( A( J, J ), LDA, B( J, J ), LDB, CO1, SI1, CO2,
     $                   SI2 )
            DWORK( IC ) =  CO2
            ZWORK( IC ) = -SI2
            IC = IC + 1
C
C           Update A and D.
C
            CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 )
            A( J, J )     = CO2*A( J, J ) +
     $                      SI2*A( J+1, J+1 )*DCONJG( SI1 )
            A( J+1, J+1 ) = CO1*A( J+1, J+1 )
C
            CJF = -DCONJG( D( J, J+1 ) )
            TMP = CO2*CJF - DCONJG( SI2 )*D( J+1, J+1 )
            CALL ZROT( J, D( 1, J+1 ), 1, D( 1, J ), 1, CO2, SI2 )
            D( J, J )     = CO2*D( J, J )     - SI2*TMP
            D( J+1, J+1 ) = CO2*D( J+1, J+1 ) + SI2*CJF
C
C           Update B and F.
C
            CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 )
            B( J, J )     = CO2*B( J, J ) +
     $                      SI2*B( J+1, J+1 )*DCONJG( SI1 )
            B( J+1, J+1 ) = CO1*B( J+1, J+1 )
C
            CJF = DCONJG( F( J, J+1 ) )
            TMP = CO2*CJF - DCONJG( SI2 )*F( J+1, J+1 )
            CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO2, SI2 )
            F( J, J )     = CO2*F( J, J )     - SI2*TMP
            F( J+1, J+1 ) = CO2*F( J+1, J+1 ) + SI2*CJF
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C
               CALL ZROT( N, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1, SI1 )
               CALL ZROT( N, Q( 1, M+J+1 ), 1, Q( 1, M+J ), 1, CO2, SI2
     $                     )
            END IF
  290    CONTINUE
C
C        Panel Updates.
C
C        Update A.
C
         ICS = 1
         JE  = M - 1
C
C        WHILE( JE.GT.2 ) DO
  300    CONTINUE
         IF( JE.GE.MM ) THEN
            NC  = 0
            IC  = ICS
            ICS = ICS + NB
            DO 310 J = JE, MM, -1
               NC = MIN( NC+1, NB )
               JS = JE - NC + 1
               CALL ZROT( NC, A( J, JS+1 ), LDA, A( J+1, JS+1 ), LDA,
     $                    DWORK( IC ), ZWORK( IC ) )
               IC = IC + 1
  310       CONTINUE
            JE = JE - NB
            GO TO 300
         END IF
C        END WHILE 300
C
C        Update B.
C
         ICS = 1
         JE  = M - 1
C
C        WHILE( JE.GT.2 ) DO
  320    CONTINUE
         IF( JE.GE.MM ) THEN
            NC  = 0
            IC  = ICS
            ICS = ICS + NB
            DO 330 J = JE, MM, -1
               NC = MIN( NC+1, NB )
               JS = JE - NC + 1
               CALL ZROT( NC, B( J, JS+1 ), LDB, B( J+1, JS+1 ), LDB,
     $                    DWORK( IC ), ZWORK( IC ) )
               IC = IC + 1
  330       CONTINUE
            JE = JE - NB
            GO TO 320
         END IF
C        END WHILE 320
C
C        Update D.
C
         ICS = 1
         JE  = M - 1
C
C        WHILE( JE.GT.2 ) DO
  340    CONTINUE
         IF( JE.GE.MM ) THEN
            NC  = 0
            IC  = ICS
            ICS = ICS + NB
            DO 350 J = JE, MM, -1
               NC = MIN( NC+1, NB )
               JS = JE - NC + 1
               CALL ZROT( NC, D( J, JS+1 ), LDD, D( J+1, JS+1 ), LDD,
     $                    DWORK( IC ), ZWORK( IC ) )
               IC = IC + 1
  350       CONTINUE
            JE = JE - NB
            GO TO 340
         END IF
C        END WHILE 340
C
C        Update F.
C
         ICS = 1
         JE  = M - 1
C
C        WHILE( JE.GT.2 ) DO
  360    CONTINUE
         IF( JE.GE.MM ) THEN
            NC  = 0
            IC  = ICS
            ICS = ICS + NB
            DO 370 J = JE, MM, -1
               NC = MIN( NC+1, NB )
               JS = JE - NC + 1
               CALL ZROT( NC, F( J, JS+1 ), LDF, F( J+1, JS+1 ), LDF,
     $                    DWORK( IC ), ZWORK( IC ) )
               IC = IC + 1
  370       CONTINUE
            JE = JE - NB
            GO TO 360
         END IF
C        END WHILE 360
C
  380 CONTINUE
C
      NEIG = MM
C
      RETURN
C *** Last line of MB3JZP ***
      END


      subroutine qlbox8(Y,musq,Ires)
      implicit none
C   $I_4^{\{D=4-2 \e\}}(0,0,\pt^2,\pq^2; s_{12},s_{23};0,0,0,m^2)$}

c                 [                            s12     msq - p4sq ]
c                 [     0           0        - ---     ---------- ]
c                 [                             2          2      ]
c                 [                                               ]
c                 [                                    msq - s23  ]
c                 [     0           0          0       ---------  ]
c                 [                                        2      ]
c            y8 = [                                               ]
c                 [     s12                            msq - p3sq ]
c                 [   - ---         0          0       ---------- ]
c                 [      2                                 2      ]
c                 [                                               ]
c                 [ msq - p4sq  msq - s23  msq - p3sq             ]
c                 [ ----------  ---------  ----------     msq     ]
c                 [     2           2          2                  ]
      include 'qlconstants.f'
      integer iep
      double precision msq,si,p3sqbar,p4sqbar,tabar,musq,Y(4,4),
     .     r1,r2,ieps1,ieps2
      double complex Ires(-2:0),qllnrat,wlogs,qlLi2omrat,qlLi2omx2,
     . wlogp3,wlogp4,dilog34,dilog4,dilog3

      msq=Y(4,4)
      tabar=2d0*Y(2,4)
      si=2d0*Y(1,3)
      p3sqbar=2d0*Y(3,4)
      p4sqbar=2d0*Y(1,4)
      wlogs=qllnrat(si,musq)
      wlogp3=qllnrat(p3sqbar,tabar)
      wlogp4=qllnrat(p4sqbar,tabar)

      dilog3=qlLi2omrat(p3sqbar,tabar)
      dilog4=qlLi2omrat(p4sqbar,tabar)
      dilog34=qlLi2omx2(p3sqbar,p4sqbar,si,msq)

      call qlratreal(p3sqbar,si,r1,ieps1)
      call qlratreal(p4sqbar,msq,r2,ieps2)

      Ires(-2)=cone
      Ires(-1)=wlogp3+wlogp4-wlogs

      Ires( 0)=-2d0*dilog3-2d0*dilog4-dilog34
     . -dcmplx(pisq/6d0)+0.5d0*(qllnrat(si,musq)**2-qllnrat(si,msq)**2)
     . +2d0*qllnrat(si,musq)*qllnrat(tabar,msq)
     . -qllnrat(p3sqbar,musq)*qllnrat(p3sqbar,msq)
     . -qllnrat(p4sqbar,musq)*qllnrat(p4sqbar,msq)
      do iep=-2,0
      Ires(iep)=Ires(iep)/dcmplx(si*tabar)
      enddo
      return
      end


      SUBROUTINE GX (ZZ,RH,XK,GZ,GZP)
C     SEGMENT END CONTRIBUTIONS FOR THIN WIRE APPROX.
      COMPLEX GZ,GZP
      R2=ZZ*ZZ+RH*RH
      R=SQRT(R2)
      RK=XK*R
      GZ=CMPLX(COS(RK),-SIN(RK))/R
      GZP=-CMPLX(1.,RK)*GZ/R2
      RETURN
      END


module tests
    use spin_system
    use utils
    use types
    use callbacks
    use eigen
    implicit none

    type, extends(VectorFunctor) :: HeisenbergHamiltonianOperator
        real(dp),allocatable :: M(:,:)
    contains
        procedure :: eval => VectorMatrixMult
    end type

    contains

    function VectorMatrixMult(this,x) result(fx)
        class(HeisenbergHamiltonianOperator) :: this
        real(dp),intent(in) :: x(:)

        real(dp),dimension(:), allocatable :: fx
        integer :: i

        allocate(fx(size(x,1)))

        !standard matrix vec mutliplication
        fx = matmul(this%M,x)
    end function VectorMatrixMult

    subroutine test()

        integer, dimension(4) :: b2
        integer, dimension(8) :: b3
        integer, dimension(16) :: b4
        real(dp) :: Psi(2),NPsi(2)
        integer ::f1,f2
        logical :: valid
        real(dp) :: weight
        b2 = (/1,2,0,0/)
        b4 = (/3,5,6,9,10,12,0,0,0,0,0,0,0,0,0,0/)

        print *,"Testing..."
        call InitSpinSystem(2)

        call assert(ALL(Basis == b2))
        ! call OperatorSiSiNext(1,weight)

        Psi = 0
        Psi(1) = 1
        print *,Basis
        call OperateHamiltonian(Psi,NPsi)
        print *,NPsi

        print *, "All tests pass"

        call InitSpinSystem(4)

        call assert(ALL(Basis == b4))

        ! test spin flip
        call OperatorSpinFlip(0,1,f2,valid)
        call assert(valid)!, "not valid")
        call assert(f2 == 2)!, "not 2")

        call OperatorSpinFlip(3,8,f2,valid)
        call assert(valid)!, "not valid")
        call assert(f2 == 1)!, "not 1")
        call OperatorSpinFlip(1,1,f2,valid)
        call assert(.not. valid)!, "valid")

    end subroutine test

    subroutine test_eigen
        type(HeisenbergHamiltonianOperator) :: op
        real(dp) :: M1(2,2), M2(5,5), M3(100,100)
        real(dp) :: E1(2), v1(2,2), E2(5),V2(5,5), E3(100), V3(100,100)
        integer :: i
        M3 = 0
        do i = 1,100
            M3(i,i) = -20*i
            if ( i >1) M3(i,i - 1) = 0.1
            if (i < 100) M3(i,i +1) = 0.1
        enddo

        M1(1,:) = [1,1]
        M1(2,:) = [1,3]
        ! M(3,:) = [1,1]
        op%M = M1
        ! call symetric_eigenvalues(2,M,v)

     ! call lanczos(2,[ 1.0_dp,0.0_dp],op,E1,v1)
     ! print *,"EigenValues = ",E1
     ! call symetric_eigenvalues(2,M1,E1)
     ! print *,"EigenValues ExactDiag = ",E1

     M2 = reshape([1.96,  -6.49, -0.47,  -7.20,  -0.65,&
                  -6.49,  3.80,  -6.39,  1.50, -6.34,&
                  -0.47, -6.39,  4.17,  -1.51,  2.67,&
                   -7.20,  1.50, -1.51,  5.70,  1.80,&
                    -0.65, -6.34,  2.67,  1.80, -7.10],[5,5])

     op%M = M2

    ! call random_number(E2)
    ! print *, E2
    ! ! call lanczos(5,[1.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp],op,E2,v2)
    ! call lanczos(5,E2,op,E2,v2)
    ! print *,"EigenValues = ",E2
    ! call symetric_eigenvalues(5,M2,E2)
    ! print *,"EigenValues  ExactDiag = ",E2
    ! call random_number(E2)
    ! print *, E2
    ! ! call lanczos(5,[1.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp],op,E2,v2)
    ! call lanczos(5,E2,op,E2,v2)
    ! print *,"EigenValues = ",E2
    ! call symetric_eigenvalues(5,M2,E2)
    ! print *,"EigenValues  ExactDiag = ",E2

    op%M = M3
    print *, "M3"
    call random_number(E3)

    call lanczos(100,E3,op,E3,v3)
    print *,"EigenValues = ",E3(1)
    call symetric_eigenvalues(100,M3,E3)
    print *,"EigenValues  ExactDiag = ",minval(E3)

    print *, "result",E3(1)

    end subroutine test_eigen

end module tests


program ch0807
    ! Rank 1 Arrays and the dot_product Intrinsic
    implicit none

    integer, dimension(1:3) :: x, y
    integer :: result

    x = [ 1, 3, 5 ]
    y = (/ 2, 4, 6 /)
    result = dot_product(x, y)
    print *, result
end program


! Copyright 2018 Timothy Hume
!
! Permission to use, copy, modify, and/or distribute this software for any
! purpose with or without fee is hereby granted, provided that the above
! copyright notice and this permission notice appear in all copies.
!
! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
! REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
! INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
! LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
! OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
! PERFORMANCE OF THIS SOFTWARE.

module image
use, intrinsic  :: iso_fortran_env
use m_mrgrnk

contains

subroutine colourise(niter, nx, ny, cpt, imgfile)
    implicit none
    real(kind=real64), intent(in), dimension(nx,ny) :: niter
    integer(kind=int32), intent(in)                 :: nx, ny
    character(len=*), intent(in)                    :: cpt
    character(len=*), intent(in)                    :: imgfile

    real(kind=real64), allocatable                  :: niter_flat(:)
    integer(kind=int32), allocatable                :: niter_rank(:)
    real(kind=real64), allocatable                  :: normalised(:, :)
    integer(kind=int32)                             :: i, j
    integer(kind=int32),dimension(3)                :: rgb
    integer                                         :: nout

    allocate(normalised(nx, ny))
    allocate(niter_flat(nx*ny))
    allocate(niter_rank(nx*ny))

    niter_flat = reshape(niter, (/nx*ny/))
    call mrgrnk(niter_flat, niter_rank)

    do i=1,ny*nx
        niter_flat(niter_rank(i)) = real(i, real64)/(ny*nx)
    end do
    normalised = reshape(niter_flat, (/nx, ny/))

    !
    ! Apply a colour palette to the normalised data,
    ! and save it as a PPM image
    !
    open(newunit=nout, status="replace", form='formatted', file=imgfile)
    write(unit=nout, fmt="(A2,3I8)") "P6", nx, ny, 255
    close(unit=nout)

    open(newunit=nout, form='unformatted', access='stream', position='append', file=imgfile)
    do j=ny,1,-1
        do i=1,nx
            if (niter(i,j) > 0) then
                select case (cpt)
                    case ("grey")
                        call cpt_grey(normalised(i, j), rgb)
                    case ("haxby")
                        call cpt_haxby(normalised(i, j), rgb)
                    case ("rainbow")
                        call cpt_rainbow(normalised(i, j), rgb)
                    case ("seis")
                        call cpt_seis(normalised(i, j), rgb)
                    case ("plasma")
                        call cpt_plasma(normalised(i, j), rgb)
                    case ("jet")
                        call cpt_jet(normalised(i, j), rgb)
                    case ("viridis")
                        call cpt_viridis(normalised(i, j), rgb)
                    case default
                        call cpt_haxby(normalised(i, j), rgb)
                end select
            else
                rgb = (/0, 0, 0/)
            end if
            write(unit=nout) int(huge(int8)-255+rgb, int8)
        end do
    end do
    close(unit=nout)

    !
    ! Deallocate memory.
    !
    deallocate(normalised)
    deallocate(niter_flat)
    deallocate(niter_rank)

end subroutine

subroutine interpcolour(val, lev, cptr, cptg, cptb, rgb)
    implicit none
    real(kind=real64), intent(in)                   :: val
    real(kind=real64), intent(in), dimension(:)     :: lev
    integer(kind=int32), intent(in), dimension(:)   :: cptr, cptg, cptb
    integer(kind=int32), intent(out), dimension(3)  :: rgb

    real(kind=real64)                               :: interp
    integer(kind=int32)                             :: i

    do i=2,size(lev)
        if ((val >= lev(i-1)) .and. (val < lev(i))) then
            interp = (val - lev(i-1))/(lev(i) - lev(i-1))
            rgb(1) = int(interp*(cptr(i)-cptr(i-1)), int32) + cptr(i-1)
            rgb(2) = int(interp*(cptg(i)-cptg(i-1)), int32) + cptg(i-1)
            rgb(3) = int(interp*(cptb(i)-cptb(i-1)), int32) + cptb(i-1)
        endif
    end do
end subroutine

subroutine cpt_grey(val, rgb)
    implicit none
    real(kind=real64), intent(in)                   :: val
    integer(kind=int32), intent(out), dimension(3)  :: rgb
    real(kind=real64), dimension(2)                 :: lev
    integer(kind=int32), dimension(2)               :: r, g, b

    lev = (/0, 1/)
    r   = (/0, 255/)
    g   = (/0, 255/)
    b   = (/0, 255/)

    call interpcolour(val, lev, r, g, b, rgb)
end subroutine

subroutine cpt_haxby(val, rgb)
    implicit none
    real(kind=real64), intent(in)                   :: val
    integer(kind=int32), intent(out), dimension(3)  :: rgb
    real(kind=real64), dimension(32)                :: lev
    integer(kind=int32), dimension(32)              :: r, g, b
    integer(kind=int32)                             :: i

    do i=1,32
        lev(i) = real((i-1),real64)/31.0
    end do

    r = (/ 10, 40, 20,  0,  0,  0, 26, 13, 25, 50, 68, 97,&
        &106,124,138,172,205,223,240,247,255,255,244,238,255,&
        &255,255,245,255,255,255,255/)
    g = (/  0,  0,  0, 10, 25, 40,102,129,175,190,202,225,&
        &235,235,236,245,255,245,236,215,189,160,117, 80, 90,&
        &124,158,179,196,215,235,254/)
    b = (/121,150,175,200,212,224,240,248,255,255,255,240,&
        &225,200,174,168,162,141,121,104, 87, 69, 75, 78, 90,&
        &124,158,174,196,215,235,253/)

    call interpcolour(val, lev, r, g, b, rgb)
end subroutine

subroutine cpt_rainbow(val, rgb)
    implicit none
    real(kind=real64), intent(in)                   :: val
    integer(kind=int32), intent(out), dimension(3)  :: rgb
    real(kind=real64), dimension(50)                :: lev
    integer(kind=int32), dimension(50)              :: r, g, b
    integer(kind=int32)                             :: i

    do i=1,50
        lev(i) = real((i-1),real64)/49.0
    end do

    r = (/242,216,191,165,140,114,89,63,38,12,&
    &0,0,0,0,0,0,0,0,0,0,&
    &0,0,0,0,0,0,0,0,0,0,&
    &12,38,63,89,114,140,165,191,216,242,&
    &255,255,255,255,255,255,255,255,255,255/)
    g = (/0,0,0,0,0,0,0,0,0,0,&
    &12,38,63,89,114,140,165,191,216,242,&
    &255,255,255,255,255,255,255,255,255,255,&
    &255,255,255,255,255,255,255,255,255,255,&
    &242,216,191,165,140,114,89,63,38,12/)
    b = (/255,255,255,255,255,255,255,255,255,255,&
    &255,255,255,255,255,255,255,255,255,255,&
    &242,216,191,165,140,114,89,63,38,12,&
    &0,0,0,0,0,0,0,0,0,0,&
    &0,0,0,0,0,0,0,0,0,0/)

    call interpcolour(val, lev, r, g, b, rgb)
end subroutine

subroutine cpt_seis(val, rgb)
    implicit none
    real(kind=real64), intent(in)                   :: val
    integer(kind=int32), intent(out), dimension(3)  :: rgb
    real(kind=real64), dimension(50)                :: lev
    integer(kind=int32), dimension(50)              :: r, g, b
    integer(kind=int32)                             :: i

    do i=1,50
        lev(i) = real((i-1),real64)/49.0
    end do

    r = (/177,192,208,223,238,254,255,255,255,255,&
    &255,255,255,255,255,255,255,255,255,255,&
    &255,255,255,255,255,255,255,255,233,203,&
    &174,144,114,87,71,54,38,22,6,0,&
    &0,0,0,0,0,0,0,0,0,0/)
    g = (/0,0,0,0,0,0,14,29,45,60,&
    &75,90,106,121,136,152,167,182,198,213,&
    &228,243,255,255,255,255,255,255,255,255,&
    &255,255,255,254,251,249,246,243,241,222,&
    &193,164,136,107,79,64,50,36,21,7/)
    b = (/0,0,0,0,0,0,0,0,0,0,&
    &0,0,0,0,0,0,0,0,0,0,&
    &0,0,0,0,0,0,0,0,3,9,&
    &14,20,25,32,46,61,75,90,104,125,&
    &152,178,204,230,254,245,236,227,218,209/)

    call interpcolour(val, lev, r, g, b, rgb)
end subroutine

subroutine cpt_plasma(val, rgb)
    implicit none
    real(kind=real64), intent(in)                   :: val
    integer(kind=int32), intent(out), dimension(3)  :: rgb
    real(kind=real64), dimension(50)                :: lev
    integer(kind=int32), dimension(50)              :: r, g, b
    integer(kind=int32)                             :: i

    do i=1,50
        lev(i) = real((i-1),real64)/49.0
    end do

    r = (/20,33,43,52,61,70,78,86,94,102,&
    &110,118,125,133,140,148,154,161,167,173,&
    &179,185,190,195,200,205,210,214,218,222,&
    &226,230,233,237,240,243,246,248,250,251,&
    &252,253,254,253,253,251,249,247,244,241/)
    g = (/7,6,5,4,4,3,2,1,1,0,&
    &0,1,3,5,10,16,22,27,33,39,&
    &45,50,56,61,67,74,79,85,91,97,&
    &103,109,115,121,127,135,141,148,155,162,&
    &170,177,185,193,201,210,218,226,235,244/)
    b = (/137,143,147,151,155,159,162,164,166,167,&
    &168,168,168,166,165,161,158,154,150,146,&
    &141,136,132,127,122,117,113,108,104,99,&
    &95,91,87,82,78,73,68,64,60,56,&
    &51,47,44,41,38,36,36,37,39,37/)

    call interpcolour(val, lev, r, g, b, rgb)
end subroutine

subroutine cpt_jet(val, rgb)
    implicit none
    real(kind=real64), intent(in)                   :: val
    integer(kind=int32), intent(out), dimension(3)  :: rgb
    real(kind=real64), dimension(50)                :: lev
    integer(kind=int32), dimension(50)              :: r, g, b
    integer(kind=int32)                             :: i

    do i=1,50
        lev(i) = real((i-1),real64)/49.0
    end do

    r = (/0,0,0,0,0,0,0,0,0,0,&
    &0,0,0,0,0,0,0,0,0,15,&
    &35,56,76,96,117,137,158,178,198,219,&
    &239,255,255,255,255,255,255,255,255,255,&
    &255,255,255,255,239,219,198,178,157,137/)
    g = (/0,0,0,0,0,0,5,25,45,66,&
    &86,107,127,147,168,188,209,229,249,255,&
    &255,255,255,255,255,255,255,255,255,255,&
    &255,249,229,209,188,168,147,127,107,86,&
    &66,45,25,5,0,0,0,0,0,0/)
    b = (/137,157,178,198,219,239,255,255,255,255,&
    &255,255,255,255,255,255,255,255,255,239,&
    &219,198,178,158,137,117,96,76,56,35,&
    &15,0,0,0,0,0,0,0,0,0,&
    &0,0,0,0,0,0,0,0,0,0/)

    call interpcolour(val, lev, r, g, b, rgb)
end subroutine

subroutine cpt_viridis(val, rgb)
    implicit none
    real(kind=real64), intent(in)                   :: val
    integer(kind=int32), intent(out), dimension(3)  :: rgb
    real(kind=real64), dimension(50)                :: lev
    integer(kind=int32), dimension(50)              :: r, g, b
    integer(kind=int32)                             :: i

    do i=1,50
        lev(i) = real((i-1),real64)/49.0
    end do

    r = (/69,70,71,72,72,72,71,69,68,66,&
    &63,61,59,56,54,51,49,46,44,42,&
    &41,39,37,35,33,32,31,30,31,33,&
    &36,40,46,54,62,72,82,92,103,115,&
    &128,140,154,167,180,194,208,221,234,246/)
    g = (/4,12,19,26,32,40,46,52,58,64,&
    &70,76,81,87,92,98,103,108,113,117,&
    &122,127,131,136,141,146,151,156,161,165,&
    &170,174,179,183,188,193,197,200,204,208,&
    &211,214,216,219,221,223,225,227,229,230/)
    b = (/88,95,102,108,114,120,124,128,131,134,&
    &136,138,139,140,141,141,142,142,142,142,&
    &142,142,142,142,141,140,139,137,135,133,&
    &130,127,124,120,115,109,104,98,91,85,&
    &77,69,60,52,43,34,27,24,26,32/)

    call interpcolour(val, lev, r, g, b, rgb)
end subroutine

end module


! { dg-do run }
program main
  implicit none
  integer, parameter :: n=5
  character(len=6), dimension(n,n) :: a
  integer, dimension(n,n) :: v
  character(len=6), dimension(n) :: r1, r2
  character(len=6), dimension(:,:), allocatable :: a_alloc
  integer, dimension(:,:), allocatable :: v_alloc
  character(len=6), parameter :: zero = achar(0) // achar(0) // achar(0) // achar(0) // achar(0) // achar(0)
  integer :: i
  character(len=6),dimension(1) :: ret
  logical, dimension(n,n) :: mask
  logical :: smask

  v = reshape([(i*i+200-17*i,i=1,n*n)],shape(v))
  write (unit=a,fmt='(I6.6)') (i*i+200-17*i,i=1,n*n)

  r1 =  maxval(a,dim=1)
  write (unit=r2,fmt='(I6.6)') maxval(v,dim=1)
  if (any (r1 /= r2)) STOP 1
  r1 = 'x'
  write (unit=r1,fmt='(I6.6)') maxval(v,dim=1)
  if (any (r1 /= r2)) STOP 2

  r1 = 'y'
  r1 =  maxval(a,dim=2)
  write (unit=r2,fmt='(I6.6)') maxval(v,dim=2)
  if (any (r1 /= r2)) STOP 3
  r1 = 'z'
  write (unit=r1,fmt='(I6.6)') maxval(v,dim=2)
  if (any (r1 /= r2)) STOP 4

  allocate (a_alloc(0,1), v_alloc(0,1))
  ret = 'what'
  ret = maxval(a_alloc,dim=1)
  if (ret(1) /= zero) STOP 5

  r1 = 'qq'
  r1 = maxval(a, dim=1, mask=a>"000200");
  if (any(r1 /= zero .neqv. maxval(v,dim=1, mask=v>200) > 0)) STOP 6
  if (any(maxval(a, dim=1, mask=a>"000200") /= zero .neqv. maxval(v,dim=1, mask=v>200) > 0)) STOP 7

  r1 = 'rr'
  r1 = maxval(a, dim=2, mask=a>"000200");
  if (any(r1 /= zero .neqv. maxval(v,dim=2, mask=v>200) > 0)) STOP 8
  if (any(maxval(a, dim=2, mask=a>"000200") /= zero .neqv. maxval(v,dim=2, mask=v>200) > 0)) STOP 9

  mask = .true.
  forall (i=1:n)
     mask(i,i) = .false.
  end forall

  r1 = 'aa'
  r1 = maxval(a, dim=1, mask=mask)
  write(unit=r2,fmt='(I6.6)') maxval(v,dim=1, mask=mask)
  if (any(r1 /= r2)) STOP 10

  r1 = 'xyz'
  smask = .true.
  r1 = maxval(a, dim=1, mask=smask)
  write (unit=r2,fmt='(I6.6)') maxval(v,dim=1)
  if (any (r1 /= r2)) STOP 11

  smask = .false.
  r1 = 'foobar'
  r1 = maxval(a, dim=1, mask=smask)
  if (any(r1 /= zero)) STOP 12
end program main


 SUBROUTINE SGBSV1_F95( A, B, K, IPIV, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!   .. USE STATEMENTS ..
    USE LA_PRECISION, ONLY: WP => SP
    USE LA_AUXMOD, ONLY: ERINFO
    USE F77_LAPACK, ONLY: GBSV_F77 => LA_GBSV
!   .. IMPLICIT STATEMENT ..
    IMPLICIT NONE
!   .. SCALAR ARGUMENTS ..
    INTEGER, INTENT(IN), OPTIONAL :: K
    INTEGER, INTENT(OUT), OPTIONAL :: INFO
!   .. ARRAY ARGUMENTS ..
    INTEGER, INTENT(OUT), OPTIONAL, TARGET :: IPIV(:)
    REAL(WP), INTENT(INOUT) :: A(:,:), B(:)
!   .. PARAMETERS ..
    CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_GBSV'
!   .. LOCAL SCALARS ..
    INTEGER :: LINFO, ISTAT, ISTAT1, SIPIV, LDA, N, LK, KU
!   .. LOCAL POINTERS ..
    INTEGER, POINTER :: LPIV(:)
!   .. INTRINSIC FUNCTIONS ..
    INTRINSIC SIZE, PRESENT
!   .. EXECUTABLE STATEMENTS ..
    LINFO = 0; ISTAT = 0
    LDA = SIZE(A,1); N = SIZE(A,2)
    IF( PRESENT(K) ) THEN; LK = K; ELSE; LK = (LDA-1)/3; ENDIF
    IF( PRESENT(IPIV) )THEN; SIPIV = SIZE(IPIV); ELSE; SIPIV = N; ENDIF
!   .. TEST THE ARGUMENTS
    IF( LDA - 2*LK -1 < 0 .OR. LDA < 0 .OR. N < 0 ) THEN; LINFO = -1
    ELSE IF( SIZE( B ) /= N ) THEN; LINFO = -2
    ELSE IF( LDA - 2*LK -1 < 0 .OR. LK < 0 ) THEN; LINFO = -3
    ELSE IF( SIPIV /= N )THEN; LINFO = -4
    ELSE IF ( N > 0 ) THEN
       IF( PRESENT(IPIV) )THEN; LPIV => IPIV; ELSE
           ALLOCATE( LPIV(N), STAT = ISTAT ); END IF
       IF ( ISTAT == 0 ) THEN
          KU = LDA -2*LK -1
          CALL GBSV_F77( N, LK, KU, 1, A, LDA, LPIV, B, N, LINFO )
       ELSE
          LINFO = -100
       END IF
       IF( .NOT.PRESENT(IPIV) )THEN
          DEALLOCATE(LPIV, STAT = ISTAT1 )
       END IF
    END IF
    CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
 END SUBROUTINE SGBSV1_F95


      SUBROUTINE polin2(x1a,x2a,ya,m,n,x1,x2,y,dy)
      INTEGER m,n,NMAX,MMAX
      REAL dy,x1,x2,y,x1a(m),x2a(n),ya(m,n)
      PARAMETER (NMAX=20,MMAX=20)
CU    USES polint
      INTEGER j,k
      REAL ymtmp(MMAX),yntmp(NMAX)
      do 12 j=1,m
        do 11 k=1,n
          yntmp(k)=ya(j,k)
11      continue
        call polint(x2a,yntmp,n,x2,ymtmp(j),dy)
12    continue
      call polint(x1a,ymtmp,m,x1,y,dy)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/polin2.for


!* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
!* See https://llvm.org/LICENSE.txt for license information.
!* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!*
!* Tests that the random number generator does not return zeros
!* This occurs for all releases before 5.1-6 when using -r8

PROGRAM P
IMPLICIT NONE

! - - - local variables - - -
!
integer, parameter :: N=3
integer, parameter :: NT=1
REAL*8 :: pool(N,N,N) ! random number pool
INTEGER :: i
INTEGER, dimension(NT) :: exp, res

CALL RANDOM_SEED()               ! set seed to random number based on time
CALL RANDOM_NUMBER(pool)        ! fill pool with random data ( 0. -> 1. )

exp(1) = 3
res(1) = 0
DO i = 1,N
   IF (pool(i,i,i) > 0) THEN
      res(1) = res(1) + 1
   ELSE
      WRITE (*,*) 'Random numbers should not be zeros'
      WRITE (*,*) '---- pool(1:3,1:3,i) i=', i
      WRITE (*,*) pool(1:3,1:3,i)
   ENDIF
END DO

call check(res, exp, NT)

END PROGRAM P


!> This module contains the necessary functions
!! for random number generation.
MODULE random_numbers
  USE kinds
  IMPLICIT NONE
  REAL(dp), PRIVATE :: cdf_g(0:10000), cdf_e(0:10000)
  REAL(dp), ALLOCATABLE :: radial_f(:,:), radial_b(:,:)
  !> cdf_g, cdf_e are radial cumulative distribution functions
  !! for the ground and first excited harmonic oscillator states

  !> radial_f, radial_b are the full radial CDFs for forward
  !! and backward mapping variables based on linear combinations of
  !! cdf_g, cdf_e where coefficients come from final mapping variable
  !! values from previous propagation. These are what the mapping variables
  !! are sampled from

  CONTAINS

      !> Inserts the random number generation seed based
      !! upon the current time. If the calculation is being
      !! done with MPI-parallelization, this subroutine takes
      !! the processing element ID number as an argument to ensure
      !! that the seeds are unique.
    SUBROUTINE initialize_rn(my_pe)
      ! Initialize the random number generator
      IMPLICIT NONE
      INTEGER :: time(12), seedsize
      INTEGER, ALLOCATABLE :: seed(:)
      INTEGER, OPTIONAL, INTENT(in) :: my_pe
      time = 0

      CALL RANDOM_SEED(SIZE=seedsize)

      ALLOCATE( seed(seedsize) )
      seed(:) = 0

      CALL DATE_AND_TIME(VALUES=time)

      IF ( seedsize >= size(time) ) THEN
        seed = seed + time(8)
        seed( 1 : size(time) ) = seed( 1 : size(time) ) + time(:)
      ELSE
        seed(:) = seed(:) + time( 1 : seedsize )
      END IF

      IF ( PRESENT(my_pe) ) seed(:) = seed(:) + 5 * my_pe

      CALL RANDOM_SEED(PUT=seed)

      DEALLOCATE( seed )

    END SUBROUTINE initialize_rn

      !> sample a uniform [0,1) random number
    FUNCTION uniform_rn(input) RESULT(res)
      USE parameters
      IMPLICIT NONE
      REAL(dp) :: input(:)
      REAL(dp) :: res(SIZE(input))

      CALL RANDOM_NUMBER(HARVEST=res)

    END FUNCTION uniform_rn

      !> Gaussian random number generation using
      !! the Box-Mueller process with two uniform
      !! [0,1) random number
    FUNCTION gaussian_rn(input) RESULT(res)
      USE parameters
      IMPLICIT NONE
      REAL(dp) :: input(:)
      REAL(dp) :: res(SIZE(input))
      REAL(dp) :: make_grn(2, SIZE(input))

      CALL RANDOM_NUMBER(HARVEST=make_grn)
      res(:) = DSQRT( -2.0_dp * DLOG(make_grn(1,:)) ) * DCOS( 2.0_dp * pi * make_grn(2,:))
    END FUNCTION gaussian_rn

    !> This is a subroutine that builds the normalized cumulative
    !! distribution functions for the radial portion of
    !! the ground and first excited state harmonic states
    !! in polar coordinates (\f$ (x - i p) \rightarrow r e^{-i \theta} \f$)

    SUBROUTINE build_current_cdfs(c_f,c_b, islice)
    !SUBROUTINE build_current_cdfs(c, islice)
      USE input_output
      IMPLICIT NONE
      INTEGER :: i, j, k, l
      INTEGER, INTENT(in) :: islice
      REAL(dp) :: dr = 0.001_dp, a_f, a_b
      REAL(dp) :: a
      COMPLEX(dp), INTENT(in) :: c_f( nstate ), c_b( nstate )
      !COMPLEX(dp), INTENT(in) :: c( nstate, nstate )

      ! allocate memory for radial distributions
      IF ( ALLOCATED( radial_f ) .EQV. .FALSE. ) THEN
        ALLOCATE( radial_f( nstate, 0 : SIZE(cdf_e) -1 ) )
      END IF
      IF ( ALLOCATED( radial_b ) .EQV. .FALSE. ) THEN
        ALLOCATE( radial_b( nstate, 0 : SIZE(cdf_e) -1 ) )
      END IF
      radial_f = 0.0_dp ; radial_b = 0.0_dp

      IF ( islice == 1 ) THEN
        cdf_g = 1.0_dp * dr ; cdf_e = 0.0_dp
        DO i = 1, SIZE(cdf_e)-1
          cdf_g(i) = cdf_g(i-1) + dr * EXP( - (i * dr) / 2.0_dp )
          cdf_e(i) = cdf_e(i-1) + dr * SQRT(( i * dr )) * EXP( - (i * dr) / 2.0_dp )
        END DO
      END IF

      ! Build the current radial CDF based on linear combination of
      ! ground and first excited state radial harmonic oscillator CDFs
      DO i = 1, nstate
        ! prepare normalized coefficients for current term
        a_f =  SQRT( c_f(i) * CONJG( c_f(i) ) )
        a_b =  SQRT( c_b(i) * CONJG( c_b(i) ) )
        ! add component of excited state for current term
        radial_f(i,:) = radial_f(i,:) + a_f * cdf_e(:)
        radial_b(i,:) = radial_b(i,:) + a_b * cdf_e(:)
        DO j=1,nstate
          IF ( j /= i ) THEN
            ! add component of ground state for current term
            radial_f(j,:) = radial_f(j,:) + a_f * cdf_g(:)
            radial_b(j,:) = radial_b(j,:) + a_b * cdf_g(:)
          END IF
        END DO
      END DO

      !DO i = 1, nstate
        !DO j = 1, nstate
          ! prepare normalized coefficients for current term
      !  j=i

          ! TRY SQRT(A) ALSOOOOO
      !    a = SQRT( c(i,j) * CONJG(c(i,j)) )

      !    a = SQRT( a )

          ! add component of excited state for current term
      !    radial_f(i,:) = radial_f(i,:) + a * cdf_e(:)
      !    radial_b(j,:) = radial_b(j,:) + a * cdf_e(:)
      !    DO k=1,nstate
      !      IF ( k /= i ) THEN
      !        ! add component of ground state for current term
      !        radial_f(k,:) = radial_f(k,:) + a * cdf_g(:)
      !      END IF
      !      IF ( k /= j ) THEN
      !        ! add component of ground state for current term
      !        radial_b(k,:) = radial_b(k,:) + a * cdf_g(:)
      !      END IF
      !    END DO
      !  !END DO
      !END DO

      !normalize
      DO i = 1, nstate
        radial_f(i,:) = radial_f(i,:) / radial_f(i, SIZE(radial_f(i,:)) - 1)
        radial_b(i,:) = radial_b(i,:) / radial_b(i, SIZE(radial_b(i,:)) - 1)
      END DO

    END SUBROUTINE build_current_cdfs

    !> subroutine to sample the current cumulative distribution
    !! functions for the radial portion of the harmonic oscillator
    !! states
    SUBROUTINE sample_current_cdfs( r, rt )
      USE input_output
      IMPLICIT NONE
      REAL(dp), INTENT(out) :: r(nstate), rt(nstate)
      REAL(dp) :: dr = 0.001_dp
      INTEGER :: sval,svalt, i ! sampled index values

      CALL RANDOM_NUMBER( HARVEST = r )
      CALL RANDOM_NUMBER( HARVEST = rt )

      DO i = 1, nstate
        sval = MINLOC( ABS( radial_f(i,:) - r(i) ), 1 )
        svalt = MINLOC( ABS( radial_b(i,:) - rt(i) ), 1 )
        r(i) = sval * dr
        rt(i) = svalt * dr
      END DO

    END SUBROUTINE sample_current_cdfs

    !> This function assigns a random number distributed according to the
    !! radial portion of the ground harmonic oscillator state in polar coordinates
    FUNCTION ground_rn() RESULT( res )
      IMPLICIT NONE
      REAL(dp) :: res
      REAL(dp) :: dr = 0.001_dp
      INTEGER :: sval

      CALL RANDOM_NUMBER( HARVEST = res )

      sval = MINLOC( ABS( cdf_g - res ), 1 )

      res = sval * dr

    END FUNCTION ground_rn

    !> This function assigns a random number distributed according to the
    !! radial portion of the first excited harmonic oscillator state in polar coordinates
    FUNCTION excited_rn() RESULT( res )
      IMPLICIT NONE
      REAL(dp) :: res
      REAL(dp) :: dr = 0.001_dp
      INTEGER :: sval

      CALL RANDOM_NUMBER( HARVEST = res )

      sval = MINLOC( ABS( cdf_e - res ), 1 )

      res = sval * dr

    END FUNCTION excited_rn

END MODULE random_numbers


C++***************************************************************
C Program to normalize the bispectrum
C
C JLP
C Version of 23-10-92
C--***************************************************************
	PROGRAM NORM_BISPEC
	INTEGER*4 IN1,OUT2,MADRID(1)
	CHARACTER NAME*40,COMMENTS*80
	COMMON /VMR/MADRID

C To get the possibility of command line
	CALL JLP_BEGIN

C Inquire the format (input/output) :
	CALL JLP_INQUIFMT

        PRINT 81
81	FORMAT(' Program NORM_BISPEC to normalize a bispectrum ')

C Input :
	NAME=' '
	CALL JLP_VM_READIMAG(IN1,NX1,NY1,NAME,COMMENTS)

C Get memory space:
	ISIZE=NX1*NY1*4
	CALL JLP_GETVM(OUT2,ISIZE)

C Processing
	CALL NORMALIZE(MADRID(IN1),MADRID(OUT2),NX1,NY1)

C Output :
	WRITE(COMMENTS,84) NAME(1:40)
84	FORMAT(' Normalized version of ',A40)
	NAME=' '
	  CALL JLP_WRITEIMAG(MADRID(OUT2),NX1,NY1,NX1,
     1	NAME,COMMENTS)

99	CALL JLP_END
	STOP
	END
C*********************************************************************
	SUBROUTINE NORMALIZE(IN1,OUT2,NX1,NY1)
	INTEGER NX1,NY1,NNULL
	INTEGER I,J
	REAL*4 IN1(NX1,*),OUT2(NX1,*),XNORM

        NNULL=0
	DO I=1,NX1
            XNORM=IN1(I,1)*IN1(I,1)+IN1(I,2)*IN1(I,2)
            IF(XNORM.NE.0)THEN
                 XNORM=SQRT(XNORM)
                 OUT2(I,1)=IN1(I,1)/XNORM
                 OUT2(I,2)=IN1(I,2)/XNORM
            ELSE
              NNULL=NNULL+1
            ENDIF
        ENDDO

C Copy third line (SNR) if present
        IF(NY1.GE.3)THEN
           OUT2(I,3)=IN1(I,3)
        ENDIF

        IF(NNULL.GT.0)THEN
          PRINT *,'BISP_NORMALIZE/Warning: ',NNULL,' null complex terms'
        ENDIF

	RETURN
	END


      SUBROUTINE rsolv(a,n,np,d,b)
      INTEGER n,np
      REAL a(np,np),b(n),d(n)
      INTEGER i,j
      REAL sum
      b(n)=b(n)/d(n)
      do 12 i=n-1,1,-1
        sum=0.
        do 11 j=i+1,n
          sum=sum+a(i,j)*b(j)
11      continue
        b(i)=(b(i)-sum)/d(i)
12    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/rsolv.for


** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

*   Deletable store & IVDEP.

      program kc00
c
c     a very trivial fft comparer
c
      integer N
      parameter (N=32)
      doubleprecision res(N), expect(N)
      integer t
      data res /
     +  0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,
     +  23,24,25,26,27,28,29,30,31
     + /
      data expect /
     +  0,1,30,31,28,29,26,27,24,25, 22,23,20,21,18,19,16,17,14,15,
     +  12,13,10,11,8,9,6,7,4,5,2,3
     + /

      CALL fft (res, N/2)
      call checkd(res,expect, N)
      end
      SUBROUTINE FFT(A, n)
      IMPLICIT doubleprecision (A-H,O-Z)
      DIMENSION A(1)

      I1 = 3
      I2 = (n-1)*2 + 1
CDIR$ IVDEP
      DO 10 M=1,n/2
C     SWAP REAL AND IMAGINARY PORTIONS
d	print *, 'before'
d	print *, 'i1',i1
d	print *, 'i2',i2
d	write(*,99) i1, a(i1), i1+1, a(i1+1)
d	write(*,99) i2, a(i2), i2+1, a(i2+1)
d
      HREAL = A(I1)
      HIMAG = A(I1+1)
      A(I1) = A(I2)
      A(I1+1) = A(I2+1)
      A(I2) = HREAL
      A(I2+1) = HIMAG
d	print *, 'after'
d	write(*,99) i1, a(i1), i1+1, a(i1+1)
d	write(*,99) i2, a(i2), i2+1, a(i2+1)
      I1 = I1+2
      I2 = I2-2

   10 CONTINUE

99	format(' a(',i2,')=',f6.1)
	end


      SUBROUTINE DGEMV(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE lsame_I
      USE xerbla_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: M
      INTEGER , INTENT(IN) :: N
      INTEGER , INTENT(IN) :: LDA
      INTEGER , INTENT(IN) :: INCX
      INTEGER , INTENT(IN) :: INCY
      REAL(DOUBLE) , INTENT(IN) :: ALPHA
      REAL(DOUBLE) , INTENT(IN) :: BETA
      CHARACTER  :: TRANS
      REAL(DOUBLE) , INTENT(IN) :: A(LDA,*)
      REAL(DOUBLE) , INTENT(IN) :: X(*)
      REAL(DOUBLE) , INTENT(INOUT) :: Y(*)
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      REAL(DOUBLE), PARAMETER :: ONE = 1.0D+0
      REAL(DOUBLE), PARAMETER :: ZERO = 0.0D+0
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
      REAL(DOUBLE) :: TEMP
!-----------------------------------------------
!   I n t r i n s i c  F u n c t i o n s
!-----------------------------------------------
      INTRINSIC MAX
!-----------------------------------------------
!     .. Scalar Arguments ..
!     .. Array Arguments ..
!     ..
!
!  Purpose
!  =======
!
!  DGEMV  performs one of the matrix-vector operations
!
!     y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y,
!
!  where alpha and beta are scalars, x and y are vectors and A is an
!  m by n matrix.
!
!  Parameters
!  ==========
!
!  TRANS  - CHARACTER*1.
!           On entry, TRANS specifies the operation to be performed as
!           follows:
!
!              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y.
!
!              TRANS = 'T' or 't'   y := alpha*A'*x + beta*y.
!
!              TRANS = 'C' or 'c'   y := alpha*A'*x + beta*y.
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of the matrix A.
!           M must be at least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
!           Before entry, the leading m by n part of the array A must
!           contain the matrix of coefficients.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. LDA must be at least
!           max( 1, m ).
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of DIMENSION at least
!           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
!           and at least
!           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
!           Before entry, the incremented array X must contain the
!           vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  BETA   - DOUBLE PRECISION.
!           On entry, BETA specifies the scalar beta. When BETA is
!           supplied as zero then Y need not be set on input.
!           Unchanged on exit.
!
!  Y      - DOUBLE PRECISION array of DIMENSION at least
!           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
!           and at least
!           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
!           Before entry with BETA non-zero, the incremented array Y
!           must contain the vector y. On exit, Y is overwritten by the
!           updated vector y.
!
!  INCY   - INTEGER.
!           On entry, INCY specifies the increment for the elements of
!           Y. INCY must not be zero.
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
!     .. Local Scalars ..
!     .. External Functions ..
!     .. External Subroutines ..
!     .. Intrinsic Functions ..
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. .NOT.LSAME(&
         TRANS,'C')) THEN
         INFO = 1
      ELSE IF (M < 0) THEN
         INFO = 2
      ELSE IF (N < 0) THEN
         INFO = 3
      ELSE IF (LDA < MAX(1,M)) THEN
         INFO = 6
      ELSE IF (INCX == 0) THEN
         INFO = 8
      ELSE IF (INCY == 0) THEN
         INFO = 11
      ENDIF
      IF (INFO /= 0) THEN
         CALL XERBLA ('DGEMV ', INFO)
         RETURN
      ENDIF
!
!     Quick return if possible.
!
      IF (M==0 .OR. N==0 .OR. ALPHA==ZERO .AND. BETA==ONE) RETURN
!
!     Set  LENX  and  LENY, the lengths of the vectors x and y, and set
!     up the start points in  X  and  Y.
!
      IF (LSAME(TRANS,'N')) THEN
         LENX = N
         LENY = M
      ELSE
         LENX = M
         LENY = N
      ENDIF
      IF (INCX > 0) THEN
         KX = 1
      ELSE
         KX = 1 - (LENX - 1)*INCX
      ENDIF
      IF (INCY > 0) THEN
         KY = 1
      ELSE
         KY = 1 - (LENY - 1)*INCY
      ENDIF
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through A.
!
!     First form  y := beta*y.
!
      IF (BETA /= ONE) THEN
         IF (INCY == 1) THEN
            IF (BETA == ZERO) THEN
               Y(:LENY) = ZERO
            ELSE
               Y(:LENY) = BETA*Y(:LENY)
            ENDIF
         ELSE
            IY = KY
            IF (BETA == ZERO) THEN
               Y(IY:(LENY-1)*INCY+IY:INCY) = ZERO
            ELSE
               Y(IY:(LENY-1)*INCY+IY:INCY) = BETA*Y(IY:(LENY-1)*INCY+IY:INCY)
            ENDIF
         ENDIF
      ENDIF
      IF (ALPHA == ZERO) RETURN
      IF (LSAME(TRANS,'N')) THEN
!
!        Form  y := alpha*A*x + y.
!
         JX = KX
         IF (INCY == 1) THEN
            DO J = 1, N
               IF (X(JX) /= ZERO) THEN
                  TEMP = ALPHA*X(JX)
                  Y(:M) = Y(:M) + TEMP*A(:M,J)
               ENDIF
               JX = JX + INCX
            END DO
         ELSE
            DO J = 1, N
               IF (X(JX) /= ZERO) THEN
                  TEMP = ALPHA*X(JX)
                  IY = KY
                  Y(IY:(M-1)*INCY+IY:INCY) = Y(IY:(M-1)*INCY+IY:INCY) + TEMP*A(&
                     :M,J)
               ENDIF
               JX = JX + INCX
            END DO
         ENDIF
      ELSE
!
!        Form  y := alpha*A'*x + y.
!
         JY = KY
         IF (INCX == 1) THEN
            DO J = 1, N
               TEMP = ZERO
               TEMP = TEMP + SUM(A(:M,J)*X(:M))
               Y(JY) = Y(JY) + ALPHA*TEMP
               JY = JY + INCY
            END DO
         ELSE
            DO J = 1, N
               TEMP = ZERO
               IX = KX
               TEMP = TEMP + SUM(A(:M,J)*X(IX:(M-1)*INCX+IX:INCX))
               Y(JY) = Y(JY) + ALPHA*TEMP
               JY = JY + INCY
            END DO
         ENDIF
      ENDIF
!
      RETURN
!
!     End of DGEMV .
!
      END SUBROUTINE DGEMV