PROGRAM SCOOTER

  ! Finite-element wavenumber integration program

  ! Copyright (C) 2009 Michael B. Porter

  ! This program is free software: you can redistribute it and/or modify
  ! it under the terms of the GNU General Public License as published by
  ! the Free Software Foundation, either version 3 of the License, or
  ! (at your option) any later version.

  ! This program is distributed in the hope that it will be useful,
  ! but WITHOUT ANY WARRANTY; without even the implied warranty of
  ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  ! GNU General Public License for more details.

  ! You should have received a copy of the GNU General Public License
  ! along with this program.  If not, see <http://www.gnu.org/licenses/>.

  ! Initial version developed at the Naval Research Laboratory in 1985.

  USE MathConstants
  USE SourceReceiverPositions
  USE sspMod
  USE AttenMod

  IMPLICIT NONE

  SAVE
  INTEGER, PARAMETER :: ENVFile = 5, PRTFile = 6, GRNFile = 25, IRCFile = 12, MaxMedium = 500
  INTEGER            :: FirstAcoustic, LastAcoustic, Nk
  REAL      (KIND=8) :: Cmin, Clow, CHigh, omega2, RMax, Atten
  CHARACTER  (LEN=8) :: TopOpt, BotOpt

  ! finite-difference grid
  INTEGER              :: Loc( MaxMedium ), N( MaxMedium ), NG( MaxMedium )
  REAL      (KIND=8)   :: H(   MaxMedium )

  ! storage for finite-difference equations
  REAL    (KIND=8),    ALLOCATABLE :: rho( : )
  COMPLEX (KIND=8),    ALLOCATABLE :: B1( : ), B2( : ), B3( : ), B4( : )

  INTEGER              :: ik, NPoints, NTotal1, IAllocStat, ifreq
  REAL                 :: kMin, kMax, deltak, TStart, TEnd
  REAL,    ALLOCATABLE :: k( : ), cVec( : )
  REAL     (KIND=8)    :: freq, freq0
  COMPLEX, ALLOCATABLE :: Green( :, :, : )     ! G( NSz, NRz, Nk )
  CHARACTER (LEN=80)   :: Title, FileRoot
  CHARACTER (LEN=10)   :: PlotType = 'Green'

  CALL CPU_TIME( Tstart )

  ! get the file root for naming all input and output files
  ! should add some checks here ...

  CALL GET_COMMAND_ARGUMENT( 1, FileRoot )

  CALL GetPar( FileRoot, Title, freq0 )

  IF ( SSP%NMedia > 1 ) THEN
     IF ( ANY( SSP%sigma( 2 : SSP%NMedia ) /= 0.0 ) ) CALL ERROUT( PRTFile, 'F', 'SCOOTER', 'Rough interfaces not allowed' )
  ENDIF

  ! Set up vector of wavenumber samples based on highest frequency
  kMin = REAL( 2 * pi * freqVec( Nfreq ) / cHigh )
  kMAX = REAL( 2 * pi * freqVec( Nfreq ) / cLow  )
  Nk   = INT( 2000.0 * RMax * ( kMax - kMin ) / REAL( pi ) )

  WRITE( PRTFile, * ) 'Nk = ', Nk
  IF ( ALLOCATED( k     ) ) DEALLOCATE( k, cVec, Pos%Rr )
  ALLOCATE( k( Nk ), cVec( Nk ), Pos%Rr( Nk ), Stat = IAllocStat )
  IF ( IAllocStat /= 0 ) CALL ERROUT( PRTFile, 'F', 'SCOOTER', 'Insufficient memory to allocate k( Nk ) vector' )

  ! Set-up the vector of k-space points
  Deltak = ( kMax - kMin ) / ( Nk - 1 )
  k(    1 : Nk )   = kMin + [ ( Ik, Ik = 0, Nk - 1 ) ] * Deltak
  cVec( 1 : Nk )   = 2 * pi * freqVec( Nfreq ) / k   ! phase speeds associated with wavenumbers

  IF ( TopOpt( 7 : 7 ) == '0' ) THEN   ! Option to zero out the stabilizing attenuation
     WRITE( PRTFile, * ) 'Option selected to zero out stabilizing attenuation'
  END IF

  IF ( ALLOCATED( Green ) ) DEALLOCATE( Green )
  ALLOCATE ( Green( Pos%NSz, Pos%NRz, Nk ), Stat = IAllocStat )
  IF ( IAllocStat /= 0 ) THEN
     CALL ERROUT( PRTFile, 'F', 'SCOOTER', 'Insufficient memory to allocate Green''s function matrix; reduce Rmax, NSz, or NRz' )
  END IF

  FreqLoop: DO ifreq = 1, Nfreq
     freq = freqVec( ifreq )
     IF ( Nfreq > 1 ) THEN
        WRITE( PRTFile, * ) '__________________________________________________________________________'
        WRITE( PRTFile, * )
        WRITE( PRTFile, "( ' Frequency = ', G11.4, ' Hz' )" ) freq
        CALL FLUSH( PRTFile )
     END IF

     omega2 = ( 2.0D0 * pi * freq ) ** 2

     CALL UpdateSSPLoss( freq, freq0 )
     ! update loss in the halfspaces based on the frequency
     ! depth of HUGE ensure bio loss in the halfspace is not included
     IF ( HSTop%BC == 'A' ) THEN
        HSTop%cP  = CRCI( HUGE( 1D0 ), HSTop%alphaR, HSTop%alphaI, freq, freq0, SSP%AttenUnit, HSTop%beta, HSTop%fT )
        HSTop%cS  = CRCI( HUGE( 1D0 ), HSTop%betaR,  HSTop%betaI,  freq, freq0, SSP%AttenUnit, HSTop%beta, HSTop%fT )
     END IF

     IF ( HSBot%BC == 'A' ) THEN
        HSBot%cP  = CRCI( HUGE( 1D0 ), HSBot%alphaR, HSBot%alphaI, freq, freq0, SSP%AttenUnit, HSBot%beta, HSBot%fT )
        HSBot%cS  = CRCI( HUGE( 1D0 ), HSBot%betaR,  HSBot%betaI,  freq, freq0, SSP%AttenUnit, HSBot%beta, HSBot%fT )
     END IF

     N( 1 : SSP%NMedia ) = freq / freq0 * NG( 1 : SSP%NMedia )   ! scale 'global' grid in proportion to frequency

     ! following done as a loop to avoid mixing vector and scalar in the MAX function
     DO iSSP = 1, SSP%NMedia
        N( iSSP ) = MAX( N( iSSP ), 100 )   ! make sure the grid has at least 100 points
     END DO

     h( 1 : SSP%NMedia ) = ( SSP%Depth( 2 : SSP%NMedia + 1 ) - SSP%Depth( 1 : SSP%NMedia ) ) / N( 1 : SSP%NMedia )  ! vector of mesh widths
     NPoints             = SUM( N( 1 : SSP%NMedia ) ) + SSP%NMedia                                  ! number of solution points

     IF ( ALLOCATED( B1 ) ) DEALLOCATE( B1, B2, B3, B4, rho )
     ALLOCATE ( B1( NPoints ), B2( NPoints ), B3( NPoints ), B4( NPoints ), rho( NPoints ), Stat = IAllocStat )
     IF ( IAllocStat /= 0 ) CALL ERROUT( PRTFile, 'F', 'SCOOTER', 'Insufficient memory to allocate B1, B2, B3, B4 vectors' )

     CALL Initialize( NPoints )    ! Initialize matrices

     ! Set up vector of wavenumber samples, k
     kMin = REAL( 2 * pi * freq / cHigh )
     kMAX = REAL( 2 * pi * freq / cLow  )

     Deltak = ( kMax - kMin ) / ( Nk - 1 )
     k( 1 : Nk ) = kMin + [ ( Ik, Ik = 0, Nk - 1 ) ] * Deltak

     Atten  = Deltak   ! stabilizing attenuation
     IF ( TopOpt( 7 : 7 ) == '0' ) Atten = 0.0   ! Option to zero out the stabilizing attenuation

     ! Write header for Green's function file, if this is the first frequency
     IF ( ifreq == 1 ) THEN
        Pos%Rr  = cVec   ! phase speed vector goes where r (its conjugate variable) is normally stored in the file
        Pos%NRr = Nk
        CALL WriteHeader( TRIM( FileRoot ) // '.grn', Title, REAL( freq0 ), REAL( Atten ), PlotType )
     END IF

     NTotal1 = SUM( N( FirstAcoustic : LastAcoustic ) ) + 1       ! size of matrix for acoustic part
     CALL CalculateKernel( NPoints, k, Green, NTotal1, ifreq )

     CALL CPU_TIME( Tend )
     WRITE( PRTFile, "(' CPU Time: ', G15.5, 's   ---cumulative' )" ) Tend - Tstart
  END DO FreqLoop

  CLOSE( GRNFile )

CONTAINS

  !**********************************************************************!

  SUBROUTINE GetPar( FileRoot, Title, freq0 )

    ! Read in the ENVFile data

    USE ReadEnvironmentMod
    USE RefCoef

    INTEGER, PARAMETER                :: iProf = 1
    REAL      (KIND=8), INTENT( OUT ) :: freq0   ! source frequency
    CHARACTER (LEN=80), INTENT( OUT ) :: Title
    CHARACTER (LEN=80), INTENT( IN  ) :: FileRoot
    REAL                              :: zMin, zMAX

    Title = 'SCOOTER- '

    CALL ReadEnvironment( FileRoot, Title, freq0, MaxMedium, TopOpt, NG, BotOpt, ENVFile, PRTFile )

    READ(  ENVFile, *    ) cLow, cHigh                 ! Spectral limits (m/s)
    WRITE( PRTFile, "( /, ' cLow = ', G12.5, ' m/s      cHigh = ', G12.5, ' m/s' )" ) cLow, cHigh

    IF ( cLow >= cHigh ) &
         CALL ERROUT( PRTFile, 'F', 'GETPAR', 'Need phase speeds cLow < cHigh'  )

    READ(  ENVFile, * ) RMax                           ! Maximum range for calculations (km)
    WRITE( PRTFile, "( ' RMax = ', G12.5, ' km' )" ) RMax
    IF ( RMax <= 0.0 ) CALL ERROUT( PRTFile, 'F', 'GETPAR', 'RMax must be positive'  )

    zMin = REAL( SSP%Depth( 1 ) )
    zMAX = REAL( SSP%Depth( SSP%NMedia + 1 ) )
    CALL ReadSzRz(    zMin, zMAX )       ! Read source/receiver depths
    CALL ReadfreqVec( freq0, TopOpt( 6 : 6 ) )

    CLOSE ( ENVFile )

    omega2 = ( 2.0 * pi * freq0 ) ** 2

    CALL ReadReflectionCoefficient( FileRoot, BotOpt( 1 : 1 ), TopOpt( 2 : 2 ), PRTFile )   ! Bot, Top refl. coef.

  END SUBROUTINE GetPar

  !**********************************************************************!

  SUBROUTINE Initialize( NPoints )

    ! Initializes arrays defining difference equations

    INTEGER, INTENT( IN ) :: NPoints
    LOGICAL           :: ElasticFlag = .FALSE.
    INTEGER           :: ii, J, Medium, N1
    REAL     (KIND=8) :: cMinV, two_h, freq
    COMPLEX  (KIND=8) :: cp( NPoints ), cs( NPoints ), cp2, cs2
    CHARACTER (LEN=8) :: Task

    cMin          = HUGE( cMin )
    FirstAcoustic = 0
    Loc( 1 )      = 0

    MediumLoop: DO Medium = 1, SSP%NMedia
       IF ( Medium /= 1 ) Loc( Medium ) = Loc( Medium - 1 ) + N( Medium - 1 ) + 1
       N1   = N(   Medium ) + 1
       ii   = Loc( Medium ) + 1
       Task = 'TAB'
       CALL EvaluateSSP( cp( ii ), cs( ii ), rho( ii ), Medium, N1, freq, Task, ENVFile, PRTFile )
       IF ( cs( ii ) == ( 0.0, 0.0 ) ) THEN   ! Case of an acoustic medium
          SSP%Material( Medium )  =  'ACOUSTIC'
          IF ( FirstAcoustic == 0 ) FirstAcoustic = Medium
          LastAcoustic = Medium

          cMinV = MINVAL( DBLE( cp( ii:ii + N( Medium ) ) ) )
          cMin  = MIN( cMin, cMinV )
          B1( ii : ii + N( Medium ) ) = omega2 / cp( ii : ii + N( Medium ) ) ** 2
       ELSE                                  ! Case of an elastic medium
          SSP%Material( Medium ) = 'ELASTIC'
          two_h         = 2.0 * h( Medium )

          DO j = ii, ii + N( Medium )
             cMin = MIN( DBLE( cs( j ) ), cMin )

             cp2 = cp( j ) ** 2
             cs2 = cs( j ) ** 2

             B1(  j ) = two_h / ( rho( j ) * cs2 )
             B2(  j ) = two_h / ( rho( j ) * cp2 )
             B3(  j ) = 4.0 * two_h * rho( j ) * cs2 * ( cp2 - cs2 ) / cp2
             B4(  j ) = two_h * ( cp2 - 2.0 * cs2 ) / cp2
             rho( j ) = two_h * omega2 * rho( j )
          END DO

       ENDIF
    END DO MediumLoop

    ! (cLow, cHigh) = phase speed interval for the wavenumber integration
    ! user specified interval is reduced if it exceeds domain of possible phase speeds

    ! Bottom properties
    IF ( HSBot%BC == 'A' ) THEN
       IF ( HSBot%cS /= ( 0.0, 0.0 ) ) THEN    ! Elastic  bottom half-space
          ElasticFlag = .TRUE.
          cMin   = MIN( cMin, DBLE( HSBot%cS ) )
       ELSE                                    ! Acoustic bottom half-space
          cMin   = MIN( cMin, DBLE( HSBot%cP ) )
       END IF
    END IF

    ! Top properties
    IF ( HSTop%BC == 'A' ) THEN
       IF ( HSTop%cS /= ( 0.0, 0.0 ) ) THEN    ! Elastic  top half-space
          ElasticFlag = .TRUE.
          cMin   = MIN( cMin, DBLE( HSTop%cS ) )
       ELSE                                    ! Acoustic top half-space
          cMin   = MIN( cMin, DBLE( HSTop%cP ) )
       END IF
    END IF

    IF ( ElasticFlag ) THEN
       cMin = 0.85 * cMin   ! phase speed a bit less than Scholte/Stoneley wave speed
    ELSE
       cMin = 0.90 * cMin   ! phase speed must be some 10% below slowest acoustic speed
    END IF

    ! The code above calculates phase speed limits, but I'm not using them at the moment
    ! because the k-vector has already been allocated at this stage
    !!!cLow = MAX( cLow, cMin )

  END SUBROUTINE Initialize

  !**********************************************************************!

  SUBROUTINE BCImpedance( x, BotTop, HS, f, g, iPower )

    !     Compute Boundary Condition Impedance
    !     Same subroutine as in KRAKENC except
    !        PEKRT    is replaced by SQRT
    !        COMC     is replaced by COMSCO
    !        cInside  is related to B1 differently

    USE RefCoef

    COMPLEX (KIND=8), PARAMETER :: zero = (0.0D0, 0.0D0 )
    COMPLEX  (KIND=8), INTENT( IN  ) :: x           ! wavenumber squared
    CHARACTER (LEN=3), INTENT( IN  ) :: BotTop      ! flag indicating bottom or top boundary
    TYPE( HSInfo ),    INTENT( IN  ) :: HS          ! structure containing halfspace parameters
    INTEGER,           INTENT( OUT ) :: iPower      ! powers of 10 for large dynamic range of the impedance
    COMPLEX  (KIND=8), INTENT( OUT ) :: f, g        ! functions defining the impedance for that value of x
    TYPE( ReflectionCoef ) :: RInt
    INTEGER                :: Ibot, Itop, Medium
    REAL     (KIND=8)      :: c0, rhoInside = 1., omega
    COMPLEX  (KIND=8)      :: kx, kz, Twersky, gammaS2, gammaP2, gammaS, gammaP, mu, yV( 5 ), RCmplx, cInside = 1500.
    ! complex  (kind=8)      :: k0, znorm   ! air acoustics tests for Richard Evans

    iPower = 0

    ! Get rho, C just inside the boundary
    SELECT CASE ( BotTop )
    CASE ( 'TOP' )
       Itop      = 1
       rhoInside = rho( Itop )
       cInside   = SQRT( omega2 / B1( Itop ) )
    CASE ( 'BOT' )
       Ibot      = Loc( LastAcoustic ) + N( LastAcoustic ) + 1
       rhoInside = rho( Ibot )
       cInside   = SQRT( omega2 / B1( Ibot ) )
    END SELECT

    ! impedance for different boundary types

    SELECT CASE ( HS%BC )
    CASE ( 'V' )                   ! Vacuum
       f       = 1.0
       g       = -i * SQRT( omega2 / cInside ** 2 - x ) * SSP%sigma( 1 ) ** 2
       yV      = CMPLX( [ f, g, zero, zero, zero ] )
    CASE ( 'S', 'H', 'T', 'I'  )  ! Vacuum with Twersky scatter model
       omega   = SQRT( omega2 )
       kx      = SQRT( x )
       f       = 1.0
       c0      = REAL( cInside )
       ! The following is missing an input variable, Option
       ! Disable it for now
       !g     = Twersky( omega, HS, kx, rhoInside, c0 )
       g     = 0   ! replaces Twersky
       g       = g / ( i * omega * rhoInside )
       yV      = CMPLX( [ f, g, zero, zero, zero ] )
    CASE ( 'R' )                    ! Rigid
       f       = 0.0
       g       = 1.0
       yV      = CMPLX( [ f, g, zero, zero, zero ] )
    CASE ( 'A' )                    ! Acousto-elastic half-space
       IF ( REAL( HS%cs ) > 0.0 ) THEN
          gammaS2 = x - omega2 / HS%cs ** 2
          gammaP2 = x - omega2 / HS%cp ** 2
          gammaS  = SQRT( gammaS2 )
          gammaP  = SQRT( gammaP2 )
          mu      = HS%rho * HS%cs ** 2

          yV( 1 ) = ( gammaS * gammaP - x ) / mu
          yV( 2 ) = ( ( gammaS2 + x ) ** 2 - 4.0 * gammaS * gammaP * x ) * mu
          yV( 3 ) = 2.0 * gammaS * gammaP - gammaS2 - x
          yV( 4 ) = gammaP * ( x - gammaS2 )
          yV( 5 ) = gammaS * ( gammaS2 - x )

          f = omega2 * yV( 4 )
          g = yV( 2 )
       ELSE
          gammaP = SQRT( x - omega2 / HS%cp ** 2 )
          f = 1.0
          g = HS%rho / gammaP
       ENDIF
    CASE ( 'F' )                    ! Tabulated reflection coefficient
       ! Compute the grazing angle Theta
       kx         = SQRT( x )
       kz         = SQRT( omega2 / cInside ** 2 - kx ** 2 )
       RInt%theta = RadDeg * ATAN2( REAL( kz ), REAL( kx ) )
       ! RInt%theta = RadDeg * ATAN( kz / kx )
       ! Evaluate R( TheInt )
       SELECT CASE ( BotTop )
       CASE ( 'TOP' )
          CALL InterpolateReflectionCoefficient( RInt, RTop, NTopPts, PRTFile )
       CASE ( 'BOT' )
          CALL InterpolateReflectionCoefficient( RInt, RBot, NBotPts, PRTFile )
       END SELECT

       ! Convert R( Theta ) to (f,g) in Robin BC
       RCmplx = RInt%R * EXP( i * RInt%phi )

       !write( *, * ) RInt%theta, abs( RCmplx )
       ! Richard Evans' case
       !k0 = SQRT( omega2 ) / cInside
       !Znorm  = 12.97 - i * 12.38   ! normalized ground impedance
       !RCmplx = ( kz - k0 / Znorm ) / ( kz + k0 / Znorm )
       !write( *, * ) RInt%theta, abs( RCmplx ), '---'

       f      = 1.0
       g      = rhoInside * ( 1.0 + RCmplx ) / ( i * kz * ( 1.0 - RCmplx ) )

       !k0 = ( 2.0 * pi * 100.0 ) / 343.0 ! local wave number at ground
       !g  = Znorm / ( i * k0 )           ! direct calculation of G (rbe,2/18/17)

    CASE ( 'P' )                    ! Precalculated reflection coef
       CALL InterpolateIRC( x, f, g, iPower, xTab, fTab, gTab, ITab, NkTab )
    END SELECT

    IF ( BotTop == 'TOP' ) g = -g    ! A top BC has the sign flipped relative to a bottom BC

    ! Shoot through elastic layers
    SELECT CASE ( BotTop )
    CASE ( 'TOP' )
       IF ( FirstAcoustic > 1 ) THEN
          DO Medium = 1, FirstAcoustic - 1                ! Shooting down from top
             CALL ElasticDn( x, yV, iPower, Medium )
          END DO
          f = omega2 * yV( 4 )
          g = yV( 2 )
       ENDIF
    CASE ( 'BOT' )
       IF ( LastAcoustic < SSP%NMedia ) THEN
          DO Medium = SSP%NMedia, LastAcoustic + 1, -1    ! Shooting up from bottom
             CALL ElasticUp( x, yV, iPower, Medium )
          END DO
          f = omega2 * yV( 4 )
          g = yV( 2 )
       ENDIF
    END SELECT

  END SUBROUTINE BCImpedance

  !**********************************************************************!

  SUBROUTINE ElasticUp( x, yV, iPower, Medium )

    ! Propagates through an elastic layer using compound matrix formulation

    INTEGER,          PARAMETER :: iPowerR = 5, iPowerF = -5
    REAL    (KIND=8), PARAMETER :: Roof = 1.0E5, Floor = 1.0E-5
    INTEGER,          INTENT( IN    ) :: Medium
    INTEGER,          INTENT( INOUT ) :: iPower
    COMPLEX (KIND=8), INTENT( IN    ) :: x                ! wavenumber, k^2
    INTEGER          :: ii, j
    REAL    (KIND=8) :: two_h
    COMPLEX (KIND=8) :: xV( 5 ), yV( 5 ), zV( 5 )   ! solution of differential equation at 3 successive steps
    COMPLEX (KIND=8) :: two_x, xB3, four_h_x

    ! Euler's method for first step
    two_x    = 2.0 * x
    two_h    = 2.0 * h( Medium )
    four_h_x = 4.0 * h( Medium ) * x
    j        = Loc( Medium ) + N( Medium ) + 1
    xB3      = x * B3( j ) - rho( j )

    zV( 1 ) = yV( 1 ) - 0.5 * (   B1( j ) * yV( 4 ) - B2( j ) * yV( 5 ) )
    zV( 2 ) = yV( 2 ) - 0.5 * ( -rho( j ) * yV( 4 ) -     xB3 * yV( 5 ) )
    zV( 3 ) = yV( 3 ) - 0.5 * (     two_h * yV( 4 ) + B4( j ) * yV( 5 ) )
    zV( 4 ) = yV( 4 ) - 0.5 * (       xB3 * yV( 1 ) + B2( j ) * yV( 2 ) - two_x * B4( j ) * yV( 3 ) )
    zV( 5 ) = yV( 5 ) - 0.5 * (  rho( j ) * yV( 1 ) - B1( j ) * yV( 2 ) -        four_h_x * yV( 3 ) )

    ! Modified midpoint method
    Step: DO ii = N( Medium ), 1, -1
       j = j - 1

       xV = yV
       yV = zV

       xB3 = x * B3( j ) - rho( j )

       zV( 1 ) = xV( 1 ) - (   B1( j ) * yV( 4 ) - B2( j ) * yV( 5 ) )
       zV( 2 ) = xV( 2 ) - ( -rho( j ) * yV( 4 ) -     xB3 * yV( 5 ) )
       zV( 3 ) = xV( 3 ) - (     two_h * yV( 4 ) + B4( j ) * yV( 5 ) )
       zV( 4 ) = xV( 4 ) - (       xB3 * yV( 1 ) + B2( j ) * yV( 2 ) - two_x * B4( j ) * yV( 3 ) )
       zV( 5 ) = xV( 5 ) - (  rho( j ) * yV( 1 ) - B1( j ) * yV( 2 ) -        four_h_x * yV( 3 ) )

       ! Scale if necessary
       IF ( ii /= 1 ) THEN
          IF      ( ABS( DBLE( zV( 2 ) ) ) < Floor ) THEN
             zV     = Roof * zV
             yV     = Roof * yV
             iPower = iPower - iPowerR
          ELSE IF ( ABS( DBLE( zV( 2 ) ) ) > Roof ) THEN
             zV     = Floor * zV
             yV     = Floor * yV
             iPower = iPower - iPowerF
          ENDIF

       ENDIF
    END DO Step

    yV = ( xV + 2.0 * yV + zV ) / 4.0   ! Apply the standard filter at the terminal point

  END SUBROUTINE ElasticUp

  !**********************************************************************!

  SUBROUTINE ElasticDn( x, yV, iPower, Medium )

    ! Propagates through an elastic layer using compound matrix formulation

    INTEGER,          PARAMETER :: iPowerR = 5, iPowerF = -5
    REAL    (KIND=8), PARAMETER :: Roof = 1.0E5, Floor = 1.0E-5
    INTEGER,          INTENT( IN    ) :: Medium
    INTEGER,          INTENT( INOUT ) :: iPower
    COMPLEX (KIND=8), INTENT( IN    ) :: x                ! wavenumber, k^2
    INTEGER          :: ii, j
    REAL    (KIND=8) :: two_h
    COMPLEX (KIND=8) :: xV( 5 ), yV( 5 ), zV( 5 )   ! solution of differential equation at 3 successive steps
    COMPLEX (KIND=8) :: two_x, xB3, four_h_x

    ! Euler's method for first step

    two_x    = 2.0 * x
    two_h    = 2.0 * h( Medium )
    four_h_x = 4.0 * h( Medium ) * x
    j        = Loc( Medium ) + 1
    xB3      = x * B3( j ) - rho( j )

    zV( 1 ) = yV( 1 ) + 0.5 * (   B1( j ) * yV( 4 ) - B2( j ) * yV( 5 ) )
    zV( 2 ) = yV( 2 ) + 0.5 * ( -rho( j ) * yV( 4 ) -     xB3 * yV( 5 ) )
    zV( 3 ) = yV( 3 ) + 0.5 * (     two_h * yV( 4 ) + B4( j ) * yV( 5 ) )
    zV( 4 ) = yV( 4 ) + 0.5 * (       xB3 * yV( 1 ) + B2( j ) * yV( 2 ) - two_x * B4( j ) * yV( 3 ) )
    zV( 5 ) = yV( 5 ) + 0.5 * (  rho( j ) * yV( 1 ) - B1( j ) * yV( 2 ) -        four_h_x * yV( 3 ) )

    ! Modified midpoint method
    Step: DO ii = 1, N( Medium )
       j = j + 1

       xV = yV
       yV = zV

       xB3 = x * B3( j ) - rho( j )

       zV( 1 ) = xV( 1 ) + (   B1( j ) * yV( 4 ) - B2( j ) * yV( 5 ) )
       zV( 2 ) = xV( 2 ) + ( -rho( j ) * yV( 4 ) -     xB3 * yV( 5 ) )
       zV( 3 ) = xV( 3 ) + (     two_h * yV( 4 ) + B4( j ) * yV( 5 ) )
       zV( 4 ) = xV( 4 ) + (       xB3 * yV( 1 ) + B2( j ) * yV( 2 ) - two_x * B4( j ) * yV( 3 ) )
       zV( 5 ) = xV( 5 ) + (  rho( j ) * yV( 1 ) - B1( j ) * yV( 2 ) -        four_h_x * yV( 3 ) )

       ! Scale if necessary
       IF ( ii /= N( Medium ) ) THEN
          IF     ( ABS( DBLE( zV( 2 ) ) ) < Floor ) THEN
             zV     = Roof * zV
             yV     = Roof * yV
             iPower = iPower - iPowerR
          ELSE IF ( ABS( DBLE( zV( 2 ) ) ) > Roof ) THEN
             zV     = Floor * zV
             yV     = Floor * yV
             iPower = iPower - iPowerF
          ENDIF
       ENDIF
    END DO Step

    yV = ( xV + 2.0 * yV + zV ) / 4.0   ! Apply the standard filter at the terminal point

  END SUBROUTINE ElasticDn

  !**********************************************************************!

  SUBROUTINE CalculateKernel( NPoints, k, Green, NTotal1, ifreq )

    ! Solve system for a sequence of k-values

    USE calculateweights

    INTEGER, INTENT( IN  ) :: NPoints, NTotal1, ifreq
    REAL,    INTENT( IN  ) :: k( Nk )
    COMPLEX, INTENT( OUT ) :: Green( Pos%NSz, Pos%NRz, Nk )
    INTEGER          :: ii, ik, is, ir, j, l, Medium
    REAL             :: z( NTotal1 ), rhoElement( NPoints )
    REAL    (KIND=8) :: rhoh
    COMPLEX (KIND=8) :: BElement, DF( NTotal1 ), EF( NTotal1 ), x

    ! Tabulate z coordinates
    z( 1 ) = REAL( SSP%Depth( FirstAcoustic ) )
    j      = 2

    DO Medium = FirstAcoustic, LastAcoustic
       ! z( j : j + N( Medium ) - 1 ) = REAL( SSP%Depth( Medium ) + [ ( ii * h( Medium ), ii = 1, N( Medium ) ) ] )
       ! gfortran generated erroneous code for the above so we rewrite as:
       z( j : j + N( Medium ) - 1 ) = REAL( [ ( ii * h( Medium ), ii = 1, N( Medium ) ) ] )
       z( j : j + N( Medium ) - 1 ) = REAL( SSP%Depth( Medium ) ) + z( j : j + N( Medium ) - 1 )
       j = j + N( Medium )
    END DO

    ! Compute weights for source/rcvr depth interpolation
    CALL WEIGHT( z, NTotal1, Pos%sz, Pos%NSz, Pos%ws, Pos%isz )
    CALL WEIGHT( z, NTotal1, Pos%rz, Pos%Nrz, Pos%wr, Pos%irz )

    ! Assemble matrix
    j       = 1
    l       = Loc( FirstAcoustic ) + 1
    DF( 1 ) = 0.0

    MediumLoop: DO Medium = FirstAcoustic, LastAcoustic
       DO ii = 1, N( Medium )
          rhoElement( l ) = REAL( rho( l ) + rho( l + 1 ) ) / 2.0
          rhoH            = rhoElement( l ) * h( Medium )
          BElement        = h( Medium ) * ( ( B1( l ) + B1( l + 1 ) ) / 2.0 ) / ( 12.0 * rhoElement( l ) )

          DF( j     ) = DF( j ) - 1.0 / rhoH + 5.0 * BElement
          DF( j + 1 ) =         - 1.0 / rhoH + 5.0 * BElement
          EF( j + 1 ) =           1.0 / rhoH +       BElement

          j = j + 1
          l = l + 1
       END DO
       l = l + 1
    END DO MediumLoop

    DO ik = 1, Nk   ! Step through each point in k-space
       x = ( k( Ik ) + i * Atten ) ** 2
       CALL Solve( NTotal1, x, Green, Ik, DF, EF, rhoElement )  ! Solve for G(k)
    END DO

    ! Write Green's function to file
    SourceDepth: DO is = 1, Pos%NSz
       RcvrDepth: DO ir = 1, Pos%Nrz
          WRITE( GRNFile, REC = 10 + ( ifreq - 1 )  * Pos%NSz * Pos%Nrz + ( is - 1 ) * Pos%Nrz + ir ) Green( is, ir, : )
       END DO RcvrDepth
    END DO SourceDepth

  END SUBROUTINE CalculateKernel

  !**********************************************************************!

  SUBROUTINE Solve( NTotal1, x, Green, Ik, DF, EF, rhoElement )

    ! Set up the linear system and solve

    USE factor_Mod
    USE backsub_Mod
    INTEGER,           INTENT( IN  ) :: NTotal1, ik
    REAL,              INTENT( IN  ) :: rhoElement( * )
    COMPLEX  (KIND=8), INTENT( IN  ) :: DF( * ), EF( * ), x
    COMPLEX,           INTENT( OUT ) :: Green( Pos%NSz, Pos%Nrz, Nk )
    INTEGER           :: j, elt, Medium, ii, is, iPower
    REAL     (KIND=8) :: rhoSz
    COMPLEX  (KIND=8) :: d( NTotal1 ), e( NTotal1 ), RV1( NTotal1 ), RV2( NTotal1 ), RV4( NTotal1 )
    COMPLEX  (KIND=8) :: BElement, xT, f, g

    ! Complete assembly of matrix by adding in x
    j   = 1
    elt = Loc( FirstAcoustic ) + 1
    d( 1 ) = DF( 1 )

    MediumLoop: DO Medium = FirstAcoustic, LastAcoustic
       xT = -h( Medium ) * x / 12.0

       DO ii = 1, N( Medium )
          BElement = xT / rhoElement( elt )

          d( j     ) = d(  j     ) + 5.0 * BElement
          d( j + 1 ) = DF( j + 1 ) + 5.0 * BElement
          e( j + 1 ) = EF( j + 1 ) +       BElement

          j   = j + 1
          elt = elt + 1
       END DO

       elt = elt + 1
    END DO MediumLoop

    ! Corner elt requires top impedance

    CALL BCImpedance( x, 'TOP', HSTop, f, g, iPower )
    IF ( g == 0.0 ) THEN
       d( 1 ) = 1.0D0
       e( 2 ) = 0.0D0
    ELSE
       d( 1 ) = d( 1 ) +  f / g
    ENDIF

    ! Corner elt requires bottom impedance

    CALL BCImpedance( x, 'BOT', HSBot, f, g, iPower )
    IF ( g == 0.0 ) THEN
       d( NTotal1 ) = 1.0D0
       e( NTotal1 ) = 0.0D0
    ELSE
       d( NTotal1 ) =  d( NTotal1 ) - f / g
    ENDIF

    CALL Factor( NTotal1, d, e, RV1, RV2, RV4 )   !     * Do LU decomposition *

    SourceDepth: DO is = 1, Pos%NSz

       ! Set up RHS in D (previously used for diagonal)
       d           = 0.0
       ii          = Pos%isz( is )

       ! we need to get the density at the source
!!!! need some slightly more sophisticated logic to get the actual element number for the source
!!!! will be OK if the source is always in the first medium
       elt         = Loc( FirstAcoustic ) + ii   ! this is not generally the correct index
       rhosz       = rhoElement( elt )
       d( ii     ) = 2.0 * ( 1.0 - Pos%ws( is ) ) / rhosz
       d( ii + 1 ) = 2.0 *     Pos%ws( is )       / rhosz

       CALL BackSub( NTotal1, RV1, RV2, RV4, d )    ! Solve the system

       Green( is, :, Ik ) = CMPLX( d( Pos%irz ) + Pos%wr * ( d( Pos%irz + 1 ) - d( Pos%irz ) ) )   ! extract the solution at the rcvr depths
    END DO SourceDepth

  END SUBROUTINE Solve
END PROGRAM SCOOTER


SUBROUTINE p114(input_file,output_file)
!-------------------------------------------------------------------------
! Program 11.4 Forced vibration analysis of an elastic solid in plane
!              strain using rectangular 8-node quadrilaterals. Lumped or
!              consistent mass. Mesh numbered in x- or y-direction.
!              Implicit time integration using Wilson's method.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::i,j,iel,k,loaded_nodes,ndim=2,ndof=16,nels,neq,nip=9,nlen,nn,   &
   nod=8,nodof=2,npri,nprops=3,np_types,nr,nres,nst=3,nstep,nxe,nye
 REAL(iwp)::area,c1,c2,c3,c4,det,dtim,d6=6.0_iwp,fk,fm,one=1.0_iwp,       &
   pt5=0.5_iwp,theta,time,two=2.0_iwp,zero=0.0_iwp
 CHARACTER(LEN=15)::argv,element='quadrilateral'
 LOGICAL::consistent=.FALSE.
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),kdiag(:),nf(:,:), &
   node(:),num(:)
 REAL(iwp),ALLOCATABLE::bee(:,:),coord(:,:),dee(:,:),der(:,:),deriv(:,:), &
   d1x0(:),d1x1(:),d2x0(:),d2x1(:),ecm(:,:),fun(:),f1(:),g_coord(:,:),    &
   jac(:,:),km(:,:),kv(:),loads(:),mm(:,:),mv(:),points(:,:),prop(:,:),   &
   val(:,:),weights(:),x0(:),x1(:),x_coords(:),y_coords(:)
!-----------------------input and initialisation--------------------------
 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nxe,nye,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 ALLOCATE(nf(nodof,nn),points(nip,ndim),g(ndof),g_coord(ndim,nn),         &
   dee(nst,nst),coord(nod,ndim),jac(ndim,ndim),weights(nip),der(ndim,nod),&
   deriv(ndim,nod),bee(nst,ndof),km(ndof,ndof),num(nod),g_num(nod,nels),  &
   g_g(ndof,nels),mm(ndof,ndof),ecm(ndof,ndof),fun(nod),etype(nels),      &
   prop(nprops,np_types),x_coords(nxe+1),y_coords(nye+1))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)x_coords,y_coords,dtim,nstep,theta,npri,nres,fm,fk
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(x0(0:neq),d1x0(0:neq),x1(0:neq),d2x0(0:neq),loads(0:neq),       &
   d1x1(0:neq),d2x1(0:neq),kdiag(neq))
 READ(10,*)loaded_nodes
 ALLOCATE(node(loaded_nodes),val(loaded_nodes,ndim))
 READ(10,*)(node(i),val(i,:),i=1,loaded_nodes)
 CALL sample(element,points,weights)
 kdiag=0
!-----------------------loop the elements to find global array sizes------
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,'y')
   CALL num_to_g(num,nf,g)
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   g_g(:,iel)=g
   CALL fkdiag(kdiag,g)
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)),mv(kdiag(neq)),f1(kdiag(neq)))
 WRITE(11,'(2(A,I5))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
 kv=zero
 mv=zero
!-----------------------global stiffness and mass matrix assembly---------
 elements_2: DO iel=1,nels
   CALL deemat(dee,prop(1,etype(iel)),prop(2,etype(iel)))
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   km=zero
   mm=zero
   area=zero
   gauss_pts_1: DO i=1,nip
     CALL shape_der(der,points,i)
     CALL shape_fun(fun,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     CALL beemat(bee,deriv)
     km=km+MATMUL(MATMUL(TRANSPOSE(bee),dee),bee)*det*weights(i)
     area=area+det*weights(i)
     IF(consistent)THEN
       CALL ecmat(ecm,fun,ndof,nodof)
       mm=mm+ecm*det*weights(i)*prop(3,etype(iel))
     END IF
   END DO gauss_pts_1
   IF(.NOT.consistent)CALL elmat(area,prop(3,etype(iel)),mm)
   CALL fsparv(kv,km,g,kdiag)
   CALL fsparv(mv,mm,g,kdiag)
 END DO elements_2
!-----------------------initial conditions and factorise equations--------
 x0=zero
 d1x0=zero
 d2x0=zero
 c1=d6/(theta*dtim)**2
 c2=c1*theta*dtim
 c3=dtim**2/d6
 c4=pt5*theta*dtim
 f1=(c1+pt5*c2*fm)*mv+(one+pt5*c2*fk)*kv
 CALL sparin(f1,kdiag)
 time=zero
!-----------------------time stepping loop--------------------------------
 WRITE(11,'(/A,I5)')" Result at node",nres
 WRITE(11,'(A)')"    time        load        x-disp      y-disp"
 WRITE(11,'(4E12.4)')time,load(time),x0(nf(:,nres))
 timesteps: DO j=1,nstep
   time=time+dtim
   loads=zero
   x1=(c1+pt5*c2*fm)*x0+(c2+two*fm)*d1x0+(two+c4*fm)*d2x0
   DO i=1,loaded_nodes
     loads(nf(:,node(i)))=                                                &
       val(i,:)*(theta*load(time)+(one-theta)*load(time-dtim))
   END DO
   CALL linmul_sky(mv,x1,d1x1,kdiag)
   d1x1=loads+d1x1
   loads=pt5*c2*fk*x0+two*fk*d1x0+c4*fk*d2x0
   CALL linmul_sky(kv,loads,x1,kdiag)
   x1=x1+d1x1
   CALL spabac(f1,x1,kdiag)
   d2x1=d2x0+((x1-x0)*c1-d1x0*c2-d2x0*two-d2x0)/theta
   d1x1=d1x0+pt5*dtim*(d2x1+d2x0)
   x0=x0+dtim*d1x0+two*c3*d2x0+d2x1*c3
   d1x0=d1x1
   d2x0=d2x1
   IF(j/npri*npri==j)WRITE(11,'(4E12.4)')time,load(time),x0(nf(:,nres))
 END DO timesteps

CONTAINS
FUNCTION load(t) RESULT(load_result)
!-----------------------Load-time function--------------------------------
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::t
 REAL(iwp)::load_result
 load_result=COS(0.3_iwp*t)
RETURN
END FUNCTION load
END SUBROUTINE p114


c $Id: siglookup.f,v 1.4 1999/01/18 09:57:15 ernst Exp $
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      real*8 function SIGLOOKUP(iline,sqrts)
c
c     Revision : 1.0
c
cinput iline : line\# for information in {\tt sigmainf} array
cinput sqrts : $\sqrt{s}$ of collision
c
c output : returns tabulated cross section value
c
c     This function returns the cross section stored in line ISIGLINE of
c     the SIGMAS array at the respective value of sqrt(s) (SQRTS)
c     Optional scaling according to SIGMASCAL is performed.
C
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      implicit none

      real*8 sqrts,xpt,x1,y1in,y2in,slin,tlow,tblstp,thigh
      integer isigline,index,iline
c
c later, sigtab.f should only be included into main.f and all relevant tables
c should be accessed via common blocks
      include 'comres.f'
c
c line for sigmas(line,*) array
      isigline=sigmainf(iline,1)
c
c log of lowest sqrt(s) entry in the table
      tlow=log(sigmascal(iline,2))

c
c exp(tblstp) is Delta(sqrts) for table
      tblstp=sigmascal(iline,3)
c
c maximum log of sqrt(s) enty in the table
      thigh=itblsz*tblstp+tlow
c
c table-lookup sequence (modified IQMD/RQMD)
c first generate x-coordinate from sqrt(s) for the table
      XPT=LOG(sqrts)
c check if sqrt(s) is below lower boundary
      IF(XPT.LT.TLOW) THEN
         siglookup=0.d0
         return
      END IF
c now get index (which is the column in sigtab)
      INDEX=INT((XPT-TLOW)/TBLSTP) + 1
c check if sqrt(s) is above upper boundary
      IF(INDEX.GE.ITBLSZ) THEN
c also this solution is not clean...
         INDEX=ITBLSZ-1
         xpt=thigh
      END IF
C FIND SLOPES AND CROSSECTIONS
c now make a straighforward interpolation
c in the sigtab array
c bracket for sqrt(s) value (between X1 and XPT)
      X1=(INDEX-1)*TBLSTP + TLOW
c sigmas(isigline,INDEX) is the c.s. array, the wanted c.s. is stored
c in line isigline
      Y1IN=sigmas(isigline,INDEX)
      Y2IN=sigmas(isigline,INDEX+1)
c get the slope
      SLIN=(Y2IN-Y1IN)/TBLSTP
c get the cross section and store it in SIGLOOKUP
      SIGLOOKUP=SLIN*(XPT-X1) + Y1IN
c scale the cross section
      siglookup=sigmascal(iline,1)*siglookup
      return
      end


!*==dlaed0.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DLAED0 used by sstedc. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmetric tridiagonal matrix using the divide and conquer method.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLAED0 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS,
!                          WORK, IWORK, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            ICOMPQ, INFO, LDQ, LDQS, N, QSIZ
!       ..
!       .. Array Arguments ..
!       INTEGER            IWORK( * )
!       DOUBLE PRECISION   D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),
!      $                   WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DLAED0 computes all eigenvalues and corresponding eigenvectors of a
!> symmetric tridiagonal matrix using the divide and conquer method.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] ICOMPQ
!> \verbatim
!>          ICOMPQ is INTEGER
!>          = 0:  Compute eigenvalues only.
!>          = 1:  Compute eigenvectors of original dense symmetric matrix
!>                also.  On entry, Q contains the orthogonal matrix used
!>                to reduce the original matrix to tridiagonal form.
!>          = 2:  Compute eigenvalues and eigenvectors of tridiagonal
!>                matrix.
!> \endverbatim
!>
!> \param[in] QSIZ
!> \verbatim
!>          QSIZ is INTEGER
!>         The dimension of the orthogonal matrix used to reduce
!>         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] D
!> \verbatim
!>          D is DOUBLE PRECISION array, dimension (N)
!>         On entry, the main diagonal of the tridiagonal matrix.
!>         On exit, its eigenvalues.
!> \endverbatim
!>
!> \param[in] E
!> \verbatim
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>         The off-diagonal elements of the tridiagonal matrix.
!>         On exit, E has been destroyed.
!> \endverbatim
!>
!> \param[in,out] Q
!> \verbatim
!>          Q is DOUBLE PRECISION array, dimension (LDQ, N)
!>         On entry, Q must contain an N-by-N orthogonal matrix.
!>         If ICOMPQ = 0    Q is not referenced.
!>         If ICOMPQ = 1    On entry, Q is a subset of the columns of the
!>                          orthogonal matrix used to reduce the full
!>                          matrix to tridiagonal form corresponding to
!>                          the subset of the full matrix which is being
!>                          decomposed at this time.
!>         If ICOMPQ = 2    On entry, Q will be the identity matrix.
!>                          On exit, Q contains the eigenvectors of the
!>                          tridiagonal matrix.
!> \endverbatim
!>
!> \param[in] LDQ
!> \verbatim
!>          LDQ is INTEGER
!>         The leading dimension of the array Q.  If eigenvectors are
!>         desired, then  LDQ >= max(1,N).  In any case,  LDQ >= 1.
!> \endverbatim
!>
!> \param[out] QSTORE
!> \verbatim
!>          QSTORE is DOUBLE PRECISION array, dimension (LDQS, N)
!>         Referenced only when ICOMPQ = 1.  Used to store parts of
!>         the eigenvector matrix when the updating matrix multiplies
!>         take place.
!> \endverbatim
!>
!> \param[in] LDQS
!> \verbatim
!>          LDQS is INTEGER
!>         The leading dimension of the array QSTORE.  If ICOMPQ = 1,
!>         then  LDQS >= max(1,N).  In any case,  LDQS >= 1.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is DOUBLE PRECISION array,
!>         If ICOMPQ = 0 or 1, the dimension of WORK must be at least
!>                     1 + 3*N + 2*N*lg N + 3*N**2
!>                     ( lg( N ) = smallest integer k
!>                                 such that 2^k >= N )
!>         If ICOMPQ = 2, the dimension of WORK must be at least
!>                     4*N + N**2.
!> \endverbatim
!>
!> \param[out] IWORK
!> \verbatim
!>          IWORK is INTEGER array,
!>         If ICOMPQ = 0 or 1, the dimension of IWORK must be at least
!>                        6 + 6*N + 5*N*lg N.
!>                        ( lg( N ) = smallest integer k
!>                                    such that 2^k >= N )
!>         If ICOMPQ = 2, the dimension of IWORK must be at least
!>                        3 + 5*N.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  The algorithm failed to compute an eigenvalue while
!>                working on the submatrix lying in rows and columns
!>                INFO/(N+1) through mod(INFO,N+1).
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup auxOTHERcomputational
!
!> \par Contributors:
!  ==================
!>
!> Jeff Rutter, Computer Science Division, University of California
!> at Berkeley, USA
!
!  =====================================================================
      SUBROUTINE DLAED0(Icompq,Qsiz,N,D,E,Q,Ldq,Qstore,Ldqs,Work,Iwork, &
     &                  Info)
      IMPLICIT NONE
!*--DLAED0176
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Icompq , Info , Ldq , Ldqs , N , Qsiz
!     ..
!     .. Array Arguments ..
      INTEGER Iwork(*)
      DOUBLE PRECISION D(*) , E(*) , Q(Ldq,*) , Qstore(Ldqs,*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE , TWO
      PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0)
!     ..
!     .. Local Scalars ..
      INTEGER curlvl , curprb , curr , i , igivcl , igivnm , igivpt ,   &
     &        indxq , iperm , iprmpt , iq , iqptr , iwrem , j , k ,     &
     &        lgn , matsiz , msd2 , smlsiz , smm1 , spm1 , spm2 ,       &
     &        submat , subpbs , tlvls
      DOUBLE PRECISION temp
!     ..
!     .. External Subroutines ..
      EXTERNAL DCOPY , DGEMM , DLACPY , DLAED1 , DLAED7 , DSTEQR ,      &
     &         XERBLA
!     ..
!     .. External Functions ..
      INTEGER ILAENV
      EXTERNAL ILAENV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , DBLE , INT , LOG , MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      Info = 0
!
      IF ( Icompq<0 .OR. Icompq>2 ) THEN
         Info = -1
      ELSEIF ( (Icompq==1) .AND. (Qsiz<MAX(0,N)) ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Ldq<MAX(1,N) ) THEN
         Info = -7
      ELSEIF ( Ldqs<MAX(1,N) ) THEN
         Info = -9
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('DLAED0',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) RETURN
!
      smlsiz = ILAENV(9,'DLAED0',' ',0,0,0,0)
!
!     Determine the size and placement of the submatrices, and save in
!     the leading elements of IWORK.
!
      Iwork(1) = N
      subpbs = 1
      tlvls = 0
      DO
         IF ( Iwork(subpbs)>smlsiz ) THEN
            DO j = subpbs , 1 , -1
               Iwork(2*j) = (Iwork(j)+1)/2
               Iwork(2*j-1) = Iwork(j)/2
            ENDDO
            tlvls = tlvls + 1
            subpbs = 2*subpbs
            CYCLE
         ENDIF
         DO j = 2 , subpbs
            Iwork(j) = Iwork(j) + Iwork(j-1)
         ENDDO
!
!     Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
!     using rank-1 modifications (cuts).
!
         spm1 = subpbs - 1
         DO i = 1 , spm1
            submat = Iwork(i) + 1
            smm1 = submat - 1
            D(smm1) = D(smm1) - ABS(E(smm1))
            D(submat) = D(submat) - ABS(E(smm1))
         ENDDO
!
         indxq = 4*N + 3
         IF ( Icompq/=2 ) THEN
!
!        Set up workspaces for eigenvalues only/accumulate new vectors
!        routine
!
            temp = LOG(DBLE(N))/LOG(TWO)
            lgn = INT(temp)
            IF ( 2**lgn<N ) lgn = lgn + 1
            IF ( 2**lgn<N ) lgn = lgn + 1
            iprmpt = indxq + N + 1
            iperm = iprmpt + N*lgn
            iqptr = iperm + N*lgn
            igivpt = iqptr + N + 2
            igivcl = igivpt + N*lgn
!
            igivnm = 1
            iq = igivnm + 2*N*lgn
            iwrem = iq + N**2 + 1
!
!        Initialize pointers
!
            DO i = 0 , subpbs
               Iwork(iprmpt+i) = 1
               Iwork(igivpt+i) = 1
            ENDDO
            Iwork(iqptr) = 1
         ENDIF
!
!     Solve each submatrix eigenproblem at the bottom of the divide and
!     conquer tree.
!
         curr = 0
         DO i = 0 , spm1
            IF ( i==0 ) THEN
               submat = 1
               matsiz = Iwork(1)
            ELSE
               submat = Iwork(i) + 1
               matsiz = Iwork(i+1) - Iwork(i)
            ENDIF
            IF ( Icompq==2 ) THEN
               CALL DSTEQR('I',matsiz,D(submat),E(submat),              &
     &                     Q(submat,submat),Ldq,Work,Info)
               IF ( Info/=0 ) GOTO 100
            ELSE
               CALL DSTEQR('I',matsiz,D(submat),E(submat),              &
     &                     Work(iq-1+Iwork(iqptr+curr)),matsiz,Work,    &
     &                     Info)
               IF ( Info/=0 ) GOTO 100
               IF ( Icompq==1 ) CALL DGEMM('N','N',Qsiz,matsiz,matsiz,  &
     &              ONE,Q(1,submat),Ldq,Work(iq-1+Iwork(iqptr+curr)),   &
     &              matsiz,ZERO,Qstore(1,submat),Ldqs)
               Iwork(iqptr+curr+1) = Iwork(iqptr+curr) + matsiz**2
               curr = curr + 1
            ENDIF
            k = 1
            DO j = submat , Iwork(i+1)
               Iwork(indxq+j) = k
               k = k + 1
            ENDDO
         ENDDO
!
!     Successively merge eigensystems of adjacent submatrices
!     into eigensystem for the corresponding larger matrix.
!
!     while ( SUBPBS > 1 )
!
         curlvl = 1
         EXIT
      ENDDO
      DO
         IF ( subpbs>1 ) THEN
            spm2 = subpbs - 2
            DO i = 0 , spm2 , 2
               IF ( i==0 ) THEN
                  submat = 1
                  matsiz = Iwork(2)
                  msd2 = Iwork(1)
                  curprb = 0
               ELSE
                  submat = Iwork(i) + 1
                  matsiz = Iwork(i+2) - Iwork(i)
                  msd2 = matsiz/2
                  curprb = curprb + 1
               ENDIF
!
!     Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
!     into an eigensystem of size MATSIZ.
!     DLAED1 is used only for the full eigensystem of a tridiagonal
!     matrix.
!     DLAED7 handles the cases in which eigenvalues only or eigenvalues
!     and eigenvectors of a full symmetric matrix (which was reduced to
!     tridiagonal form) are desired.
!
               IF ( Icompq==2 ) THEN
                  CALL DLAED1(matsiz,D(submat),Q(submat,submat),Ldq,    &
     &                        Iwork(indxq+submat),E(submat+msd2-1),msd2,&
     &                        Work,Iwork(subpbs+1),Info)
               ELSE
                  CALL DLAED7(Icompq,matsiz,Qsiz,tlvls,curlvl,curprb,   &
     &                        D(submat),Qstore(1,submat),Ldqs,          &
     &                        Iwork(indxq+submat),E(submat+msd2-1),msd2,&
     &                        Work(iq),Iwork(iqptr),Iwork(iprmpt),      &
     &                        Iwork(iperm),Iwork(igivpt),Iwork(igivcl), &
     &                        Work(igivnm),Work(iwrem),Iwork(subpbs+1), &
     &                        Info)
               ENDIF
               IF ( Info/=0 ) GOTO 100
               Iwork(i/2+1) = Iwork(i+2)
            ENDDO
            subpbs = subpbs/2
            curlvl = curlvl + 1
            CYCLE
         ENDIF
!
!     end while
!
!     Re-merge the eigenvalues/vectors which were deflated at the final
!     merge step.
!
         IF ( Icompq==1 ) THEN
            DO i = 1 , N
               j = Iwork(indxq+i)
               Work(i) = D(j)
               CALL DCOPY(Qsiz,Qstore(1,j),1,Q(1,i),1)
            ENDDO
            CALL DCOPY(N,Work,1,D,1)
         ELSEIF ( Icompq==2 ) THEN
            DO i = 1 , N
               j = Iwork(indxq+i)
               Work(i) = D(j)
               CALL DCOPY(N,Q(1,j),1,Work(N*i+1),1)
            ENDDO
            CALL DCOPY(N,Work,1,D,1)
            CALL DLACPY('A',N,N,Work(N+1),N,Q,Ldq)
         ELSE
            DO i = 1 , N
               j = Iwork(indxq+i)
               Work(i) = D(j)
            ENDDO
            CALL DCOPY(N,Work,1,D,1)
         ENDIF
         GOTO 99999
      ENDDO
!
 100  Info = submat*(N+1) + submat + matsiz - 1
!
!
!     End of DLAED0
!
99999 END SUBROUTINE DLAED0


      subroutine runY_i1i2(i,j,i1,i2,f,Xtwiddle,Gtt,Gtwiddle,Shat3,
     . Czero2,N0)
      implicit none
C---  Expression for Eq. 5.59
      include 'TRconstants.f'
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,i,j,i1,i2,n,m,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np),f(np),
     . Gtt(np,np,np,np)
      double complex Shat3(np,z2max,-2:0),Czero2(z2max,-2:0),
     . bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gtt(i,n,j,m)*f(n)
     . *(Shat3(m,z2(i1,i2),ep)
     . -2d0*delta(m,i1)*Dv(dzzi(i2)+N0,ep)
     . -2d0*delta(m,i2)*Dv(dzzi(i1)+N0,ep))
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=-4*Dv(dzzii(z2(i1,i2))+N0,ep-1)

      Dv(dii(z2(i1,i2))+N0,ep)=
     .  (Gtwiddle(i,j)
     . *(6d0*Dv(dzzii(z2(i1,i2))+N0,ep)+pole-Czero2(z2(i1,i2),ep))
     . +bit+Xtwiddle(0,j)*Dv(diii(z3(i,i1,i2))+N0,ep))/Xtwiddle(i,j)

      enddo
      return
      end


      real*8 function wtune(zbuf,zwork,lsp)
      implicit none
      integer*4 lsp,i,im,im1,im2
      real*8 a,am,a1,a2
      complex*16 zbuf(lsp),zwork(lsp)
      call tmov(zbuf,zwork,lsp*2)
      call tcftr(zwork,lsp,.false.)
      im=0
      am=0.d0
      do 10 i=1,lsp
        a=dble(zwork(i))**2+imag(zwork(i))**2
        if(a .gt. am)then
          im=i
          am=a
        endif
10    continue
      im1=mod(im+lsp-2,lsp)+1
      im2=mod(im,lsp)+1
      a1=dble(zwork(im1))**2+imag(zwork(im1))**2
      a2=dble(zwork(im2))**2+imag(zwork(im2))**2
      wtune=(im-1+(a2-a1)/2.d0/(am*2.d0-a1-a2))/lsp
      if(wtune .gt. .5d0)then
        wtune=wtune-1.d0
      endif
      return
      end


*     SB02OD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          NMAX2M, NMAX2
      PARAMETER        ( NMAX2M = 2*NMAX+MMAX, NMAX2 = 2*NMAX )
      INTEGER          LDA, LDB, LDL, LDQ, LDR, LDS, LDT, LDU, LDX
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDL = NMAX,
     $                   LDQ = MAX(NMAX,PMAX), LDR = MAX(MMAX,PMAX),
     $                   LDS = NMAX2M, LDT = NMAX2M, LDU = NMAX2,
     $                   LDX = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX(MMAX,NMAX2) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX(14*NMAX+23,16*NMAX) )
      INTEGER          LBWORK
      PARAMETER        ( LBWORK = NMAX2 )
*     .. Local Scalars ..
      DOUBLE PRECISION RCOND, TOL
      INTEGER          I, INFO, J, M, N, P
      CHARACTER*1      DICO, FACT, JOBB, JOBL, SORT, UPLO
      LOGICAL          LJOBB
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), ALFAI(NMAX2), ALFAR(NMAX2),
     $                 B(LDB,MMAX), BETA(NMAX2), DWORK(LDWORK),
     $                 L(LDL,MMAX), Q(LDQ,NMAX), R(LDR,MMAX),
     $                 S(LDS,NMAX2M), T(LDT,NMAX2), U(LDU,NMAX2),
     $                 X(LDX,NMAX)
      INTEGER          IWORK(LIWORK)
      LOGICAL          BWORK(LBWORK)
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
*     .. External Subroutines ..
      EXTERNAL         SB02OD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, DICO, JOBB, FACT, UPLO, JOBL,
     $                      SORT
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99994 ) M
         ELSE
            LJOBB = LSAME( JOBB, 'B' )
            IF ( LJOBB ) THEN
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            ELSE
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,N )
            END IF
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99993 ) P
            ELSE
               IF ( LSAME( FACT, 'N' ) .OR. LSAME( FACT, 'D' ) ) THEN
                  READ ( NIN, FMT = * )
     $                                 ( ( Q(I,J), J = 1,N ), I = 1,N )
               ELSE
                  READ ( NIN, FMT = * )
     $                                 ( ( Q(I,J), J = 1,N ), I = 1,P )
               END IF
               IF ( LJOBB ) THEN
                  IF ( LSAME( FACT, 'N' ) .OR. LSAME( FACT, 'C' ) ) THEN
                      READ ( NIN, FMT = * )
     $                                  ( ( R(I,J), J = 1,M ), I = 1,M )
                  ELSE
                      READ ( NIN, FMT = * )
     $                                  ( ( R(I,J), J = 1,M ), I = 1,P )
                  END IF
                  IF ( LSAME( JOBL, 'N' ) )
     $                READ ( NIN, FMT = * )
     $                                  ( ( L(I,J), J = 1,M ), I = 1,N )
               END IF
*              Find the solution matrix X.
               CALL SB02OD( DICO, JOBB, FACT, UPLO, JOBL, SORT, N, M, P,
     $                      A, LDA, B, LDB, Q, LDQ, R, LDR, L, LDL,
     $                      RCOND, X, LDX, ALFAR, ALFAI, BETA, S, LDS,
     $                      T, LDT, U, LDU, TOL, IWORK, DWORK, LDWORK,
     $                      BWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 )
                  DO 20 I = 1, N
                     WRITE ( NOUT, FMT = 99996 ) ( X(I,J), J = 1,N )
   20             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB02OD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB02OD = ',I2)
99997 FORMAT (' The solution matrix X is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
99994 FORMAT (/' M is out of range.',/' M = ',I5)
99993 FORMAT (/' P is out of range.',/' P = ',I5)
      END


program center
  implicit none

  integer i, j, imax, jmax
  parameter (imax = 3, jmax = 3)
  logical flag

  real a(0:imax,0:jmax), b(0:imax,0:jmax), x

  do i = 1, (imax-1)
     do j = 1, (jmax-1)
        != stencil readOnce, pointed(dim=1)*centered(depth=1, dim=2) + centered(depth=1, dim=1)*pointed(dim=2) :: a
        b(i,j) = a(i,j) + a(i+1,j) + a(i-1,j) + a(i,j+1) + a(i,j-1)
     end do
  end do

end program center


C$Procedure      NPSGPT ( Nearest point on line segment )

      SUBROUTINE NPSGPT ( EP1, EP2, POINT, PNEAR, DIST )

C$ Abstract
C
C     Find the nearest point on a line segment to a given point.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     GEOMETRY
C     MATH
C
C$ Declarations

      IMPLICIT NONE

      DOUBLE PRECISION      EP1   ( 3 )
      DOUBLE PRECISION      EP2   ( 3 )
      DOUBLE PRECISION      POINT ( 3 )
      DOUBLE PRECISION      PNEAR ( 3 )
      DOUBLE PRECISION      DIST

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     EP1,
C     EP2        I   Endpoints of a line segment.
C     POINT      I   A point in 3-dimensional space.
C     PNEAR      O   Nearest point on the line segment to POINT.
C     DIST       O   Distance between PNEAR and POINT.
C
C$ Detailed_Input
C
C     EP1,
C     EP2        are the endpoints of a line segment in 3-dimensional
C                space. EP1 and EP2 need not be distinct.
C
C     POINT      is an arbitrary point in 3-dimensional space.
C
C$ Detailed_Output
C
C     PNEAR      is the closest point on the line segment to POINT.
C
C     DIST       is the distance between POINT and PNEAR.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) The input segment is allowed to be degenerate: it may be
C        a single point.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     None.
C
C$ Examples
C
C     The numerical results shown for these examples may differ across
C     platforms. The results depend on the SPICE kernels used as input
C     (if any), the compiler and supporting libraries, and the machine
C     specific arithmetic implementation.
C
C     1) Compute the nearest point on a line segment to a given
C        point in a simple case for which the results can easily be
C        checked.
C
C
C        Example code begins here.
C
C
C              PROGRAM EX1
C              IMPLICIT NONE
C        C
C        C     Local parameters
C        C
C              CHARACTER*(*)         FMT1
C              PARAMETER           ( FMT1 = '(A,3F13.8)' )
C        C
C        C     Local variables
C        C
C              DOUBLE PRECISION      DIST
C              DOUBLE PRECISION      ENDPT1 ( 3 )
C              DOUBLE PRECISION      ENDPT2 ( 3 )
C              DOUBLE PRECISION      PNEAR  ( 3 )
C              DOUBLE PRECISION      POINT  ( 3 )
C
C        C
C        C     Initialize the line segment's endpoints.
C        C
C              CALL VPACK ( 1.D0, -2.D0, 3.D0, ENDPT1 )
C              CALL VPACK ( 1.D0,  2.D0, 3.D0, ENDPT2 )
C        C
C        C     Set the input point.
C        C
C              CALL VPACK ( 1.D0,  0.D0, 0.D0, POINT )
C        C
C        C     Find the near point on the segment.
C        C
C              CALL NPSGPT ( ENDPT1, ENDPT2, POINT, PNEAR, DIST )
C
C              WRITE (*,*) ' '
C              WRITE (*,FMT1) 'Endpoint 1:  ', ENDPT1
C              WRITE (*,FMT1) 'Endpoint 2:  ', ENDPT2
C              WRITE (*,FMT1) 'Point:       ', POINT
C              WRITE (*,*) ' '
C              WRITE (*,FMT1) 'Near point:  ', PNEAR
C              WRITE (*,FMT1) 'Distance:    ', DIST
C              WRITE (*,*) ' '
C
C              END
C
C
C     When this program was executed on a PC/Linux/gfortran/64-bit
C     platform, the output was:
C
C
C        Endpoint 1:     1.00000000  -2.00000000   3.00000000
C        Endpoint 2:     1.00000000   2.00000000   3.00000000
C        Point:          1.00000000   0.00000000   0.00000000
C
C        Near point:     1.00000000   0.00000000   3.00000000
C        Distance:       3.00000000
C
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 02-FEB-MAR-2016 (NJB)
C
C        Updated from DSKLIB Version 1.0.0, 20-MAR-2015 (NJB)
C
C-&

C$ Index_Entries
C
C     nearest point on line segment
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      VDIST
      DOUBLE PRECISION      VDOT

      LOGICAL               FAILED
      LOGICAL               RETURN
      LOGICAL               VZERO

C
C     Local variables
C
      DOUBLE PRECISION      SEG    ( 3 )
      DOUBLE PRECISION      SEGDOT
      DOUBLE PRECISION      LNEAR  ( 3 )
      DOUBLE PRECISION      OFFSET ( 3 )
      DOUBLE PRECISION      OFFDOT

C
C     Use discovery check-in.
C
      IF ( RETURN() ) THEN
         RETURN
      END IF

C
C     Find a direction vector defined by the endpoints.
C
      CALL VSUB ( EP2, EP1, SEG )

      IF ( VZERO(SEG) ) THEN
C
C        The endpoints coincide, and both coincide with the
C        near point.
C
         CALL VEQU ( EP1, PNEAR )

         DIST = VDIST( EP1, POINT )

         RETURN

      END IF

C
C     Find the nearest point to POINT on the line defined by
C     EP1 and SEG.
C
      CALL NPLNPT ( EP1, SEG, POINT, LNEAR, DIST )

      IF ( FAILED() ) THEN
         RETURN
      END IF

C
C     Determine whether LNEAR is on the segment, "before" EP1, or
C     "after" EP2, where SEG points in the "increasing" direction.
C
      CALL VSUB ( LNEAR, EP1, OFFSET )

      OFFDOT = VDOT( OFFSET, SEG )

      IF ( OFFDOT .LT. 0.D0 ) THEN
C
C        The nearest point on the line precedes the first endpoint.
C        The closest point on the segment is the first endpoint.
C
         CALL VEQU ( EP1, PNEAR )

         DIST = VDIST ( EP1, POINT )

      ELSE
C
C        See whether OFFSET is past the second endpoint. Compare
C        the dot product of OFFSET with SEG to that of SEG with
C        itself, since SEG is the offset of EP2 from EP1.
C
         SEGDOT = VDOT( SEG, SEG )

         IF ( OFFDOT .GT. SEGDOT ) THEN
C
C           The nearest point on the line follows the last endpoint.
C           The closest point on the segment is the last endpoint.
C
            CALL VEQU ( EP2, PNEAR )

            DIST = VDIST ( EP2, POINT )

         ELSE
C
C           The near point is on the segment. LNEAR is actually the
C           solution.
C
            CALL VEQU ( LNEAR, PNEAR )

C
C           DIST was correctly set by the call to NPLNPT.
C
         END IF

      END IF

      RETURN
      END


module hifuku
	implicit none
	integer, parameter :: imax=1000,jmax=1000
	real, parameter :: dx=10.0,dy=10.0,pie=3.1415927
	integer,dimension(imax,jmax) :: VAL,VISIT
	real,dimension(imax,jmax) :: DEM

contains
    subroutine over_view(is,js,ie0,je0,ie1,je1)
	integer is,js,ie0,je0,ie1,je1,iend,jend
	integer x,y,xs,xe,ys,ye
	integer inc,check
	real xx,yy
	real zs,ze0,ze1,za,zb
	real a,b,c

	zs=DEM(is,js) ; ze0=DEM(ie0,je0) ; ze1=DEM(ie1,je1)
	a=((zs-ze0)*(js-je1)-(zs-ze1)*(js-je0))/((is-ie0)*(js-je1)-(is-ie1)*(js-je0))
	b=((zs-ze0)*(is-ie1)-(zs-ze1)*(is-ie0))/((js-je0)*(is-ie1)-(js-je1)*(is-ie0))
	c=zs-a*is-b*js
	if (je0 .eq. je1) then
		if (js .lt. je0) then
			inc=1 ; jend=jmax
		else
			inc=-1 ; jend=1
		endif
		do y=je0+inc,jend,inc
			yy=real(y)
			if (ie0.lt.ie1) then
				xs=is+(ie0-is)*(yy-js)/(je0-js)+1.0
				xe=is+(ie1-is)*(yy-js)/(je1-js)
			else
				xe=is+(ie0-is)*(yy-js)/(je0-js)
				xs=is+(ie1-is)*(yy-js)/(je1-js)+1.0
			endif
			if(xs.gt.imax) exit
			if(xe.lt.1) exit
			if(xe.gt.imax) xe=imax
			if(xs.lt.1) xs=1
			check=1
			do x=xs,xe
				za=DEM(x,y)
				zb=a*x+b*y+c
				if (zb .ge. za) then
					VAL(x,y)=0 ; check=0
				endif
			enddo
			if(check.eq.1) exit
		enddo
	endif
	if (ie0 .eq. ie1) then
		if (is .lt. ie0) then
			inc=1 ; iend=imax
		else
			inc=-1 ; iend=1
		endif
		do x=ie0+inc,iend,inc
			xx=real(x)
			if(je0.lt.je1) then
				ys=js+(je0-js)*(xx-is)/(ie0-is)+1.0
				ye=js+(je1-js)*(xx-is)/(ie1-is)
			else
				ye=js+(je0-js)*(xx-is)/(ie0-is)
				ys=js+(je1-js)*(xx-is)/(ie1-is)+1.0
			endif
			if(ys.gt.jmax) exit
			if(ye.lt.1) exit
			if(ye.gt.jmax) ye=jmax
			if(ys.lt.1) ys=1
			check=1
			do y=ys,ye
				za=DEM(x,y)
				zb=a*x+b*y+c
				if (zb .ge. za) then
					VAL(x,y)=0 ; check=0
				endif
			enddo
			if(check.eq.1) exit
		enddo
	endif
	return
    end subroutine over_view

    subroutine view(is,js)
	integer is,js
	integer xe,ye,xe0,ye0
	integer dir,count

	VISIT=0 ; VAL=1
	VISIT(is,js)=1
	xe=is+1 ; ye=is
	xe0=is+1 ; ye0=js ; VISIT(xe0,ye0)=1
	dir=1 ; count=2
	do while(count.le.((imax-4)*(jmax-4)-1))
	    xe=xe0 ; ye=ye0
	    select case(dir)
	      case(0)
	        xe=xe0+1
	      case(1)
	        ye=ye0+1
	      case(2)
	        xe=xe0-1
	      case(3)
	        ye=ye0-1
            end select
	    if (VISIT(xe,ye).eq.1) then
		xe=xe0 ; ye=ye0
		dir=mod(dir+3,4)
	    	select case(dir)
	   	   case(0)
	   	     xe=xe0+1
	 	   case(1)
	 	     ye=ye0+1
	 	   case(2)
	   	     xe=xe0-1
	   	   case(3)
	   	     ye=ye0-1
            	end select
	    endif
	    if ((xe.gt.2).and.(xe.lt.(imax-1)).and.(ye.gt.2).and.(ye.lt.(jmax-1))) then
		if ((VAL(xe0,ye0).eq.1).or.(VAL(xe,ye).eq.1)) call over_view(is,js,xe0,ye0,xe,ye)
	    	VISIT(xe,ye)=1
	    	count=count+1
	    endif
	    xe0=xe ; ye0=ye
	    dir=mod(dir+1,4)
	end do
    end subroutine view
end module hifuku


*> \brief \b SSVDCH
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SSVDCH( N, S, E, SVD, TOL, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, N
*       REAL               TOL
*       ..
*       .. Array Arguments ..
*       REAL               E( * ), S( * ), SVD( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SSVDCH checks to see if SVD(1) ,..., SVD(N) are accurate singular
*> values of the bidiagonal matrix B with diagonal entries
*> S(1) ,..., S(N) and superdiagonal entries E(1) ,..., E(N-1)).
*> It does this by expanding each SVD(I) into an interval
*> [SVD(I) * (1-EPS) , SVD(I) * (1+EPS)], merging overlapping intervals
*> if any, and using Sturm sequences to count and verify whether each
*> resulting interval has the correct number of singular values (using
*> SSVDCT). Here EPS=TOL*MAX(N/10,1)*MACHEP, where MACHEP is the
*> machine precision. The routine assumes the singular values are sorted
*> with SVD(1) the largest and SVD(N) smallest.  If each interval
*> contains the correct number of singular values, INFO = 0 is returned,
*> otherwise INFO is the index of the first singular value in the first
*> bad interval.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The dimension of the bidiagonal matrix B.
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*>          S is REAL array, dimension (N)
*>          The diagonal entries of the bidiagonal matrix B.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*>          E is REAL array, dimension (N-1)
*>          The superdiagonal entries of the bidiagonal matrix B.
*> \endverbatim
*>
*> \param[in] SVD
*> \verbatim
*>          SVD is REAL array, dimension (N)
*>          The computed singular values to be checked.
*> \endverbatim
*>
*> \param[in] TOL
*> \verbatim
*>          TOL is REAL
*>          Error tolerance for checking, a multiplier of the
*>          machine precision.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          =0 if the singular values are all correct (to within
*>             1 +- TOL*MACHEPS)
*>          >0 if the interval containing the INFO-th singular value
*>             contains the incorrect number of singular values.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup single_eig
*
*  =====================================================================
      SUBROUTINE SSVDCH( N, S, E, SVD, TOL, INFO )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            INFO, N
      REAL               TOL
*     ..
*     .. Array Arguments ..
      REAL               E( * ), S( * ), SVD( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE
      PARAMETER          ( ONE = 1.0E0 )
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E0 )
*     ..
*     .. Local Scalars ..
      INTEGER            BPNT, COUNT, NUML, NUMU, TPNT
      REAL               EPS, LOWER, OVFL, TUPPR, UNFL, UNFLEP, UPPER
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           SSVDCT
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, SQRT
*     ..
*     .. Executable Statements ..
*
*     Get machine constants
*
      INFO = 0
      IF( N.LE.0 )
     $   RETURN
      UNFL = SLAMCH( 'Safe minimum' )
      OVFL = SLAMCH( 'Overflow' )
      EPS = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
*
*     UNFLEP is chosen so that when an eigenvalue is multiplied by the
*     scale factor sqrt(OVFL)*sqrt(sqrt(UNFL))/MX in SSVDCT, it exceeds
*     sqrt(UNFL), which is the lower limit for SSVDCT.
*
      UNFLEP = ( SQRT( SQRT( UNFL ) ) / SQRT( OVFL ) )*SVD( 1 ) +
     $         UNFL / EPS
*
*     The value of EPS works best when TOL .GE. 10.
*
      EPS = TOL*MAX( N / 10, 1 )*EPS
*
*     TPNT points to singular value at right endpoint of interval
*     BPNT points to singular value at left  endpoint of interval
*
      TPNT = 1
      BPNT = 1
*
*     Begin loop over all intervals
*
   10 CONTINUE
      UPPER = ( ONE+EPS )*SVD( TPNT ) + UNFLEP
      LOWER = ( ONE-EPS )*SVD( BPNT ) - UNFLEP
      IF( LOWER.LE.UNFLEP )
     $   LOWER = -UPPER
*
*     Begin loop merging overlapping intervals
*
   20 CONTINUE
      IF( BPNT.EQ.N )
     $   GO TO 30
      TUPPR = ( ONE+EPS )*SVD( BPNT+1 ) + UNFLEP
      IF( TUPPR.LT.LOWER )
     $   GO TO 30
*
*     Merge
*
      BPNT = BPNT + 1
      LOWER = ( ONE-EPS )*SVD( BPNT ) - UNFLEP
      IF( LOWER.LE.UNFLEP )
     $   LOWER = -UPPER
      GO TO 20
   30 CONTINUE
*
*     Count singular values in interval [ LOWER, UPPER ]
*
      CALL SSVDCT( N, S, E, LOWER, NUML )
      CALL SSVDCT( N, S, E, UPPER, NUMU )
      COUNT = NUMU - NUML
      IF( LOWER.LT.ZERO )
     $   COUNT = COUNT / 2
      IF( COUNT.NE.BPNT-TPNT+1 ) THEN
*
*        Wrong number of singular values in interval
*
         INFO = TPNT
         GO TO 40
      END IF
      TPNT = BPNT + 1
      BPNT = TPNT
      IF( TPNT.LE.N )
     $   GO TO 10
   40 CONTINUE
      RETURN
*
*     End of SSVDCH
*
      END