PROGRAM multi

!*****************************************!
!* 1d multi-layer shallow-Water model    *!
!*                                       *!
!* including:                            *!
!* - horizontal pressure-gradient force  *!
!* - Shapiro filter                      *!
!* - flooding algorithm                  *!
!*                                       *!
!* Author: J. Kaempf, 2008               *!
!*****************************************!

USE param
USE sub

! local parameters
REAL :: time
REAL :: Apadle, Tpadle, pi
REAL :: hmax
INTEGER :: n, ntot, nout

!---- initialisation ----
CALL INIT
!------------------------
! output of initial layer thickness distributions
OPEN(10,file ='h0.dat',form='formatted')
WRITE(10,'(101F12.6)')(htotal(k),k=1,nx)
CLOSE(10)

! automatic setting of time step (10% below CFL threshold)
hmax = 100.0 ! total water depth
dt = 0.9*dx/sqrt(g*hmax)
write(6,*)"Time step = ", dt," seconds"
pause

! set epsilon for Shapiro filter
eps = 0.05

! parameters for wave padle
Apadle = 1.   ! amplitude in metres
! Tpadle = 10.0 ! period in seconds CASE 1
 Tpadle = 2.0*3600.0 ! period in seconds CASE 2

pi = 4.*atan(1.)

! runtime parameters
ntot = INT(10.*Tpadle/dt)

! output parameter
nout = INT(Tpadle/10./dt)

! open files for output
OPEN(10,file ='h.dat',form='formatted')
OPEN(20,file ='u.dat',form='formatted')

! initial configuration
DO i = 1,nz
  WRITE(10,'(101F12.6)')(h(i,k),k=1,nx)
  WRITE(20,'(101F12.6)')(u(i,k),k=1,nx)
END DO

! header file
OPEN(33,file ='header.txt',form='formatted')
  WRITE(33,*)dt*nout, dx, nx, nz, hmax
CLOSE(33)

!---- simulation loop ----
DO n = 1,ntot
!-------------------------
time = REAL(n)*dt

DO i = 1,nz
  eta(i,1) = Apadle*sin(2.0*pi*time/Tpadle)
END DO

!---- prognostic equations ----
CALL dyn
!------------------------------
! data output
IF(MOD(n,nout)==0)THEN
  DO i = 1,nz
    WRITE(10,'(101F12.6)')(h(i,k),k=1,nx)
    WRITE(20,'(101F12.6)')(u(i,k),k=1,nx)
  END DO
  WRITE(6,*)"Data output at time = ",time/60.0," min"
ENDIF

!---- end of iteration loop ----
END DO
!-------------------------------

END PROGRAM multi


C     Naive implementation of backpropagation  to aid understanding of the principles.

      program derp
      implicit none

      integer nx, nh, ny, ntrain
      parameter ( nx=2, nh=2, ny=1, ntrain=4 )
      real        x(nx), h(nh), y(ny)

C     a(i,j): weight from node x(j) to node h(i).
C     b(i,j): weight from node h(j) to node y(i).
C     same convention as bprod.m in NNSYMID package (minus bias unit):
C     http://www.iau.dtu.dk/research/control/nnsysid.html

      real a(nh,nx), b(ny,nh)
      real agrad(size(a,1),size(a,2)), bgrad(size(b,1),size(b,2))
      real ydelta(ny), hdelta(nh)
      real xtrain(nx,ntrain), ytrain(ny,ntrain)

C     Setup training examples

      data xtrain / 0.0, 0.0, 1.0, 0.0, 0.0, 1.0, 1.0, 1.0 /
      data ytrain / 0.0, 1.0, 1.0, 0.0 /

      integer i, j, iter, niter
      real    ecost
      real    tdelta, t0, t1
      real    alpha
      parameter ( niter = 100000 )

C     Initialize weights to something random.

      print*,'=================================================='

      print*, 'Initializing random weights.'

      call random_number(a)
      call random_number(b)

      print*,'=================================================='

      call cost(ecost)

      call printmat('cost', reshape([ecost], [1,1]))

      print*,'=================================================='

      print*, 'Numerical gradient with central differences.'

      agrad = 0.0
      bgrad = 0.0

      call ngrad()

      call printmat('dE/da', agrad)
      call printmat('dE/db', bgrad)

      print*,'=================================================='

      print*, 'Gradient with backpropagation.'

      agrad = 0.0
      bgrad = 0.0

      call bpgrad()

      call printmat('dE/da', agrad)
      call printmat('dE/db', bgrad)

      print*,'=================================================='

      print*, 'Train a xor function to a feed forward neural network'

      call random_number(a)
      call random_number(b)

      alpha = 2.0
      iter = 1

      do
        call cost(ecost)
C       call bpgrad()
        call ngrad()
        a = a - alpha*agrad
        b = b - alpha*bgrad

        if (mod(iter, 1000) == 0) print*, 'iter:', iter,
     $                                    'cost:', ecost
        if (ecost < 1e-3) exit
        iter = iter + 1
      end do
      print*, 'iter:', iter, 'cost:', ecost

      print*,'=================================================='

      do i = 1, ntrain
        x = xtrain(:,i)
        call forward
        call printmat('x', reshape(x,[1,nx]))
        call printmat('y', reshape([y],[1,1]))
      end do

      print*,'=================================================='

      call cpu_time(t0)

      do iter = 1, niter
        call ngrad()
      end do

      call cpu_time(t1)
      tdelta = t1 - t0
      print*, 'Central differences ', niter, ' iterations:', tdelta

      call cpu_time(t0)

      do iter = 1, niter
        call bpgrad()
      end do

      call cpu_time(t1)
      tdelta = t1 - t0
      print*, 'Backpropagation ', niter, ' iterations:', tdelta

      print*,'=================================================='

      contains

      subroutine printmat ( name, smat )
        character(len=*)  name
        real              smat(:,:)
        integer           i
        print*, trim(name), ':'
        do i = 1, size(smat,1)
          print*, smat(i,:)
        end do
      end

      real elemental function sigmoid ( x )
        real, intent(in) :: x
        sigmoid = 1.0 / ( 1.0 + exp(-x) )
      end

      subroutine bnorm ( x )
        real        x(:), xmean, xvar, eps
        integer     m
        parameter ( eps = 100.0 * epsilon(1.0) )
        m = size(x)
        xmean = sum(x) / m
        xvar = sum( ( x - xmean )**2 ) / m
        x = ( x - xmean ) / sqrt(xvar + eps)
        x = 0.8*sqrt(xvar)*x + 3.0*xmean
      end

      subroutine forward ()
        h = matmul(a,x)
        call bnorm(h)
        h = sigmoid(h)
        y = matmul(b,h)
        call bnorm(y)
        y = sigmoid(y)
      end

      subroutine cost ( ecost )
        real              ecost
        integer           k
        ecost = 0.0
        do k = 1, ntrain
          x = xtrain(:,k)
          call forward
          ecost = ecost + (0.5 / ntrain) * sum((y-ytrain(:,k))**2)
        end do
      end

C     compute a numerical approximation of the gradient

      subroutine ngrad ()
        real              delta, aij, bij, ep, en
        integer           i, j
        parameter       ( delta = sqrt(epsilon(1.0)) )
C       Approximate dE/da with central differences.
        do j = 1, size(a,2)
          do i = 1, size(a,1)
            aij = a(i,j)
            a(i,j) = aij + delta
            call cost(ep)
            a(i,j) = aij - delta
            call cost(en)
            agrad(i,j) = (ep-en)/(2*delta)
            a(i,j) = aij
          end do
        end do
C       Approximate dE/db with central differences.
        do j = 1, size(b,2)
          do i = 1, size(b,1)
            bij = b(i,j)
            b(i,j) = bij + delta
            call cost(ep)
            b(i,j) = bij - delta
            call cost(en)
            bgrad(i,j) = (ep-en)/(2*delta)
            b(i,j) = bij
          end do
        end do
      end

C     compute gradient with backpropagation NO UPDATE

      subroutine bpgrad ()
        integer           i, j, k
        agrad = 0.0
        bgrad = 0.0
        do k = 1, ntrain
          x = xtrain(:,k)
          call forward
          do i = 1, ny
            ydelta(i) = ( y(i) - ytrain(i,k) ) * y(i) * ( 1.0 - y(i) )
     $                * (1.0 / ntrain)
          end do
C     compute dE/db
          do j = 1, size(b,2)
            do i = 1, size(b,1)
              bgrad(i,j) = bgrad(i,j) + ydelta(i) * h(j)
            end do
          end do
C     compute hdelta
          hdelta = 0.0
          do j = 1, nh
            hdelta(j) = h(j)*(1.0-h(j))*dot_product(ydelta,b(:,j))
C           hdelta(j) = 0.0
C           do i = 1, ny
C             hdelta(j) = hdelta(j)
C    $                  + ydelta(i) * h(j) * ( 1.0 - h(j) ) * b(i,j)
C           end do
          end do
C     compute dE/da
C       This is a rank-1 update of agrad. Could be optimized with BLAS.
          do j = 1, size(a,2)
            do i = 1, size(a,1)
              agrad(i,j) = agrad(i,j) + hdelta(i) * x(j) ! <<< this is right
            end do
          end do
C     end compute dE/da
        end do
      end

      subroutine stocastic
      end

      subroutine batch
      end

      end program derp


! Do brute force relaxation on a 2-d Poisson equation.  Here we
! experiment with OpenMP
!
! We solve
!    u'' = g(x),
!    u(x=0,:  ) = 0, u(x=1,:  ) = 1
!    u(:  ,y=0) = 0, u(:  ,y=1) = 1
!
!with
!    g(x) = cos(x)*sin(y)
!
!
! compile with:
!
!   gfortran -fopenmp -O -o relax relax.f90
!
! run with:
!
!   export OMP_NUM_THREADS=2; time ./relax
!
! M. Zingale (2010-03-07)

program relax

  USE omp_lib

  implicit none

  integer, parameter :: nx = 1024         ! number of interior zones in x
  integer, parameter :: ny = nx          ! number of interior zones in y
  integer, parameter :: ng = 1           ! number of guardcells

  integer, parameter :: nsmooth = 2500   ! number of smoothing blocks

  ! set the lo/hi boundary conditions in each coordinate direction
  double precision, parameter :: bc_lo_x = 0.d0
  double precision, parameter :: bc_hi_x = 0.d0
  double precision, parameter :: bc_lo_y = 0.d0
  double precision, parameter :: bc_hi_y = 0.d0

  ! imin/imax and jmin/jmax will always point to the starting and
  ! ending index of the interior zones
  integer :: imin, imax, jmin, jmax

  double precision :: xmin, xmax, ymin, ymax, dx, dy
  double precision :: source_norm

  double precision :: xx, yy

  integer :: i, j, n

  double precision, dimension(:,:), allocatable :: v, w, f

  double precision :: temp

  !real :: start, finish
  double precision :: startOMP, finishOMP

  ! measure time to run

  ! cpu_time() is a F95 intrinsic, but note that it adds up the time
  ! for all threads -- it is not wallclock time
  !call cpu_time(start)
  startOMP = omp_get_wtime()

  ! initialize the solution and rhs arrays
  allocate(f(-ng:nx+ng-1,-ng:ny+ng-1))
  allocate(v(-ng:nx+ng-1,-ng:ny+ng-1))
  allocate(w(-ng:nx+ng-1,-ng:ny+ng-1))

  ! integers indicating the range of valid data
  imin = 0           ! index 0 is the first valid cell
  imax = nx-1

  jmin = 0           ! index 0 is the first valid cell
  jmax = ny-1

  !$OMP PARALLEL DO PRIVATE (i,j)
  do j =jmin-ng, jmax+ng
     do i = imin-ng, imax+ng
        f(i,j) = 0.d0
        v(i,j) = 0.d0
     enddo
  enddo
  !$OMP END PARALLEL DO

  ! set the boundary conditions
  v(-ng:-1    ,:) = bc_lo_x
  v(nx:nx+ng-1,:) = bc_hi_x

  v(:,-ng:-1)     = bc_lo_y
  v(:,ny:ny+ng-1) = bc_hi_y

  ! setup the grid
  xmin = 0.d0
  xmax = 1.d0
  dx = (xmax - xmin)/dble(nx)

  ymin = 0.d0
  ymax = 1.0d0
  dy = (ymax - ymin)/dble(ny)

  if (dx /= dy) stop "ERROR: dx /= dy"

  ! fill the RHS of with the true RHS
  !$OMP PARALLEL DO PRIVATE (i,j,xx,yy)
  do j = jmin, jmax
     yy = (dble(j) + 0.5d0)*dy + ymin

     do i = imin, imax
        xx = (dble(i) + 0.5d0)*dx + xmin

        f(i,j) = g(xx,yy)
     enddo
  enddo
  !$OMP END PARALLEL DO

  ! compute the source norm -- we will use this for error estimating
  source_norm = error(nx, ny, ng, dx, dy, f)

  ! relax
  call smooth(nx, ny, ng, dx, dy, &
              bc_lo_x, bc_hi_x, bc_lo_y, bc_hi_y, &
              v, f, nsmooth)

  ! compare to the true solution

  !$OMP PARALLEL DO PRIVATE (i,j,xx,yy)
  do j = jmin, jmax
     yy = (dble(j) + 0.5d0)*dy + ymin

     do i = imin, imax
        xx = (dble(i) + 0.5d0)*dx + xmin
        w(i,j) = true(xx,yy) - v(i,j)
     enddo
  enddo
  !$OMP END PARALLEL DO

  close (unit=10)

100 format(1x, 1g13.6, 1x, 1g13.6, 1x, 1g13.6, 1x, 1g13.6)

  temp = error(nx, ny, ng, dx, dy, w)

  finishOMP = omp_get_wtime()
  !call cpu_time(finish)

  99 format(1x, "nx: ", i4, 3x, "threads: ", i3, 3x, "wallclock: ", g9.4, 3x, &
          "error: ", g10.5)

  write(*,99) nx, omp_get_max_threads(), finishOMP-startOMP, temp

contains

!=============================================================================
! g
!=============================================================================

function g(x,y)

  ! the RHS of the Poisson equation we are solving

  implicit none

  double precision :: g, x, y
  double precision, parameter :: pi = 3.14159265358979323846d0

  g = -2.d0*(2.0*pi)**2 * sin(2.0*pi*x) * sin(2.0*pi*y)

  return
end function g

!=============================================================================
! true
!=============================================================================

function true(x,y)

  ! the analytic solution to our equation

  implicit none

  double precision true, x, y
  double precision, parameter :: pi = 3.14159265358979323846d0

  true = sin(2.0*pi*x) * sin(2.0*pi*y)

  return
end function true

!=============================================================================
! error
!=============================================================================

function error(nx, ny, ng, dx, dy, v)

  ! compute the L2 norm

  implicit none

  integer :: nx, ny, ng
  double precision :: dx, dy
  double precision :: v(-ng:,-ng:)

  integer :: i, j, imin, imax, jmin, jmax
  double precision :: error

  imin = 0
  imax = nx-1

  jmin = 0
  jmax = ny-1

  error = 0.d0

  !$OMP PARALLEL DO REDUCTION(+:error) PRIVATE (i,j)
  do j = jmin, jmax
     do i = imin, imax
        error = error + v(i,j)**2
     enddo
  enddo
  !$OMP END PARALLEL DO

  error = dx*dy*error    ! make it grid invariant
  error = sqrt(error)

  return
end function error

!=============================================================================
! smooth
!=============================================================================

subroutine smooth(nx, ny, ng, dx, dy, &
                  bc_lo_x, bc_hi_x, bc_lo_y, bc_hi_y, &
                  v, f, nsmooth)

  ! given a solution vector, v, and a RHS vector, f,
  ! smooth v to better satisfy the equation.  This is
  ! done in place, using Red-Black Gauss-Seidel

  ! hi and lo Dirichlet boundary conditions are also passed.
  ! Because we are finite-volume, and therefore, cell-centered, we
  ! need to extrapolate to match the desired Dirichlet BC.

  implicit none

  integer :: nx, ny, ng, nsmooth
  double precision :: dx, dy
  double precision :: bc_lo_x, bc_hi_x, bc_lo_y, bc_hi_y
  double precision, dimension(-ng:,-ng:) :: v, f

  integer :: i, j, m, ioff, color
  integer :: imin, imax, jmin, jmax

  imin = 0
  imax = nx -1

  jmin = 0
  jmax = ny -1

  ! do some smoothing -- Red-Black Gauss-Seidel
  do m = 1, nsmooth

     do color = 0, 1

        ! set the guardcells to give the proper boundary condition, using
        ! extrapolation
        v(imin-1,:) = 2*bc_lo_x - v(imin,:)
        v(imax+1,:) = 2*bc_hi_x - v(imax,:)

        v(:,jmin-1) = 2*bc_lo_y - v(:,jmin)
        v(:,jmax+1) = 2*bc_hi_y - v(:,jmax)

        !$OMP PARALLEL DO PRIVATE (i,j,ioff)
        do j = jmin, jmax

           if (color == 0) then
              ioff = mod(j,2)
           else
              ioff = 1 - mod(j,2)
           endif

           do i = imin+ioff, imax, 2
              v(i,j) = 0.25d0*(v(i-1,j) + v(i+1,j) + &
                               v(i,j-1) + v(i,j+1) - dx*dx*f(i,j))
           enddo

        enddo
        !$OMP END PARALLEL DO

     enddo

  enddo

  return
end subroutine smooth

end program relax


!***********************************/
!	Name:CFL条件に基づく局所最大時間刻みを求めるプログラム
!	Alias:CalcTimeWidth
!	Description:局所時間刻み幅を使うのか統一時間刻みを使うのかは外部ルーチンで制御
!	Type:
!	Input:
!	Output:
!	Note:
!	Author:Akitaka Toyota
!	Date:2018.02.01
!	Update:
!	Other:
!***********************************/
subroutine CalcTimeWidth(Geom,CC)
use StructVar_Mod
use ConstantVar_Mod, Gamma => SpecificOfHeatRatio, CFL => CourantFriedrichsLewyCondition
implicit none
    type(Geometry), intent(in) :: Geom
    type(CellCenter), intent(inout) :: CC
    type(CalcTimeWidthWithOMP) :: CTW
    integer :: iCenterX, iCenterY
    double precision :: AverageCellWidthHalf

    AverageCellWidthHalf = min(Geom%Width(1,1,1),Geom%Width(1,1,2)) !sqrtと迷ったが，歪んだ直交格子を考えればminが正しいことが分かる

!$omp parallel num_threads(CoreNumberOfCPU),shared(Geom,CC,AverageCellWidthHalf),private(iCenterX,iCenterY,CTW)
!$omp do
    do iCenterY=1, Geom%CellNumber(2)
        do iCenterX=1, Geom%CellNumber(1)
            if(Geom%Interpolated(iCenterX,iCenterY,1) == 0) then
                CTW%AbsoluteVelocity2 = dot_product(CC%ConservedQuantity(2:3,iCenterX,iCenterY,1),CC%ConservedQuantity(2:3,iCenterX,iCenterY,1)) &
                                        &   / (CC%ConservedQuantity(1,iCenterX,iCenterY,1)**2) !速度L2ノルム

                if((Gamma*Gmin1*(CC%ConservedQuantity(4,iCenterX,iCenterY,1) / CC%ConservedQuantity(1,iCenterX,iCenterY,1) &
                                    & - 0.5d0 * CTW%AbsoluteVelocity2)) < 0.0d0) then
                        write(6,*) iCenterX,iCenterY
                        write(6,*) CC%ConservedQuantity(1,iCenterX,iCenterY,1), CC%ConservedQuantity(4,iCenterX,iCenterY,1)
                        write(6,*) CC%ConservedQuantity(2,iCenterX,iCenterY,1), CC%ConservedQuantity(3,iCenterX,iCenterY,1)
                end if

                CTW%LocalSoundSpeed = sqrt(Gamma*Gmin1*(CC%ConservedQuantity(4,iCenterX,iCenterY,1) / CC%ConservedQuantity(1,iCenterX,iCenterY,1) &
                                    & - 0.5d0 * CTW%AbsoluteVelocity2)) !局所音速

                CTW%AbsoluteVelocity = sqrt(CTW%AbsoluteVelocity2) !速度絶対値

                CC%TmpTimeWidth(iCenterX,iCenterY,1,1) = CFL*2.0d0*AverageCellWidthHalf / (CTW%LocalSoundSpeed + CTW%AbsoluteVelocity) !衝撃波が通過する速度

            else
                CC%TmpTimeWidth(iCenterX,iCenterY,1,1) = FixedTimeStep
            end if
        end do
    end do
!$omp end do
!$omp end parallel

    do iCenterY = 1, Geom%CellNumber(2)
        CC%TmpTimeWidth(0,iCenterY,1,1) = CC%TmpTimeWidth(1,iCenterY,1,1)
        CC%TmpTimeWidth(Geom%CellNumber(1)+1,iCenterY,1,1) = CC%TmpTimeWidth(Geom%CellNumber(1),iCenterY,1,1)
    end do

    do iCenterX = 0, Geom%CellNumber(1)+1
        CC%TmpTimeWidth(iCenterX,0,1,1) = CC%TmpTimeWidth(iCenterY,1,1,1)
        CC%TmpTimeWidth(iCenterX,Geom%CellNumber(2)+1,1,1) = CC%TmpTimeWidth(iCenterY,Geom%CellNumber(2),1,1)
    end do

!$omp parallel num_threads(CoreNumberOfCPU),shared(Geom,CC),private(iCenterX,iCenterY)
!$omp do
    do iCenterY=1, Geom%CellNumber(2)
        do iCenterX=1, Geom%CellNumber(1)

            CC%TimeWidth(iCenterX,iCenterY,1) = min(CC%TmpTimeWidth(iCenterX,iCenterY,1,1),&
                    &   CC%TmpTimeWidth(iCenterX-1,iCenterY,1,1), CC%TmpTimeWidth(iCenterX+1,iCenterY,1,1), &
                    &   CC%TmpTimeWidth(iCenterX,iCenterY-1,1,1), CC%TmpTimeWidth(iCenterX,iCenterY+1,1,1))

        end do
    end do
!$omp end do
!$omp end parallel

return
end subroutine CalcTimeWidth


!-------------------------------------------------------------------------------
! Copyright (c) 2016 The University of Tokyo
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief  This module contains functions for interpolation in 3 nodes
!!     line element   (Langrange  interpolation)
module shape_line3n
  integer, parameter, private :: kreal = kind(0.0d0)

contains
  subroutine ShapeFunc_line3n(lcoord,func)
    real(kind=kreal), intent(in) :: lcoord(1)
    real(kind=kreal) :: func(3)
    func(1) =-0.5d0*(1.d0-lcoord(1))*lcoord(1)
    func(2) = 0.5d0*(1.d0+lcoord(1))*lcoord(1)
    func(3) = 1.0d0-lcoord(1)*lcoord(1)
  end subroutine

  subroutine ShapeDeriv_line3n(lcoord,func)
    real(kind=kreal), intent(in) :: lcoord(1)
    real(kind=kreal) :: func(3,1)
    func(1,1) = lcoord(1)-0.5d0
    func(2,1) = lcoord(1)+0.5d0
    func(3,1) =-2.d0*lcoord(1)
  end subroutine

  subroutine Shape2ndDeriv_line3n(func)
    real(kind=kreal) :: func(3,1,1)
    func(1,1,1) = 1.d0
    func(2,1,1) = 1.d0
    func(3,1,1) = -2.d0
  end subroutine

end module


! { dg-do compile }
! PR32489 Endless loop when compiling.
! Derived from fft257.f90, Public domain 2004 James Van Buskirk.
! Note: The problem solved here was not an infinite loop issue. Middle-end
! could not handle the array constructor unfolded by the front end.
! WARNING: Potential resource hog.
! Jerry DeLisle  <jvdelisle@gcc.gnu.org>
program test
   implicit none
   integer, parameter :: dp = selected_real_kind(15,300)
   integer, parameter :: N = 257
   complex(dp) h1(0:N-1)
   complex(dp) h2(0:N-1)
   complex(dp) hh(0:N-1)
   complex(dp), parameter :: ri(2) = (/(1,0),(0,1)/)
   integer i, j, k, L
   real(dp) pi

   pi = 4*atan(1.0_dp)
   do i = 0, N-1
     do j = 1, 2
       h2 = 0
       h2(i) = ri(j)
       h1 = (/(sum((/(exp(-2*pi*(0,1)*mod(k*L,N)/N)*h2(L),L=0,N-1)/)),k=0,N-1)/)
     end do
   end do
end program test


c     program DRSHERQL
c>> 1996-05-28 DRSHERQL  Krogh Added external statement.
c>> 1994-10-19 DRSHERQL  Krogh  Changes to use M77CON
c>> 1994-09-23 DRSHERQL  CLL
c>> 1992-04-23 CLL
c>> 1992-03-04 DRSHERQL  Krogh Initial version.
c     Demonstrate Hermitian eigenvalue/eigenvector subroutine SHERQL.
c     ------------------------------------------------------------------
c--S replaces "?": DR?HERQL, ?HERQL, ?VECP, ?MATP, ?DOT
c     ------------------------------------------------------------------
      integer I, IERR, J, LDA, LDA3, N
      parameter (LDA = 4)
      parameter (LDA3 = 3*LDA)
      real             AR(LDA, LDA), AI(LDA, LDA)
      real             ARSAV(LDA, LDA), AISAV(LDA, LDA), ANORM
      external SDOT
      real             SDOT, DR(LDA,LDA), DI(LDA,LDA), EVAL(LDA)
      real             VR(LDA, LDA), VI(LDA, LDA), WORK(LDA3)
      data AR(1,1)          /  25.0e0 /
      data (AR(2,I), I=1,2) /  -3.0e0,  25.0e0 /
      data (AR(3,I), I=1,3) /  -08.0e0,  0.0e0,  25.0e0 /
      data (AR(4,I), I=1,4) /  0.0e0,  -08.0e0,  3.0e0, 25.0e0 /
      data AI(1,1)          /  0.0e0 /
      data (AI(2,I), I=1,2) /  4.0e0,  0.0e0 /
      data (AI(3,I), I=1,3) /  -06.0e0,  0.0e0, 0.0e0 /
      data (AI(4,I), I=1,4) / 0.0e0,  06.0e0, 4.0e0, 0.0e0 /
      data ANORM / 46.0e0 /
      data N /LDA/
c     ------------------------------------------------------------------
      print*,'DRSHERQL..  Demo driver for SHERQL.'
c
c     First copy AR() and AI() to ARSAV() and AISAV() for later
c     residual check.
c
      do 20 I = 1,N
         do 10 J = 1,I
            ARSAV(I,J) = AR(I,J)
            ARSAV(J,I) = ARSAV(I,J)
            AISAV(I,J) = AI(I,J)
            AISAV(J,I) = -AISAV(I,J)
   10    continue
   20 continue

      call SHERQL(AR, AI, LDA, N, EVAL, VR, VI, WORK, IERR)
      if (IERR .eq. 0) then
         call SVECP(EVAL, N, '0 Eigenvalues')
         call SMATP(VR,LDA,N,N,
     *     '0 Real parts of eigenvectors as column vectors')
         call SMATP(VI,LDA,N,N,
     *     '0 Imaginary parts of eigenvectors as column vectors')
c
c        As a check compute D = (ASAV*EVEC - EVEC*EVAL) / ANORM.
c        Expect D to be close to the machine precision.
c
         do 40 J = 1, LDA
            do 30 I = 1, LDA
               DR(I, J) = (SDOT(LDA,ARSAV(I,1),LDA,VR(1,J),1) -
     *                     SDOT(LDA,AISAV(I,1),LDA,VI(1,J),1) -
     *                     VR(I,J)*EVAL(J))/ANORM
               DI(I, J) = (SDOT(LDA,ARSAV(I,1),LDA,VI(1,J),1) +
     *                     SDOT(LDA,AISAV(I,1),LDA,VR(1,J),1) -
     *                     VI(I,J)*EVAL(J))/ANORM
   30       continue
   40    continue
       call SMATP(DR, LDA, N, N,
     * '0Real part of residual matrix D = (A*EVEC - EVEC*EVAL) / ANORM')
       call SMATP(DI, LDA, N, N,
     * '0Imag part of residual matrix D = (A*EVEC - EVEC*EVAL) / ANORM')
      else
         print '(/a,i5)',' Convergence failure in SHERQL, IERR =',IERR
      end if
      stop
      end