      SUBROUTINE AB09HY( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
     $                   SCALEC, SCALEO, S, LDS, R, LDR, IWORK,
     $                   DWORK, LDWORK, BWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the Cholesky factors Su and Ru of the controllability
C     Grammian P = Su*Su' and observability Grammian Q = Ru'*Ru,
C     respectively, satisfying
C
C            A*P  + P*A' +  scalec^2*B*B'   = 0,       (1)
C
C            A'*Q + Q*A  +  scaleo^2*Cw'*Cw = 0,       (2)
C
C     where
C            Cw = Hw - Bw'*X,
C            Hw = inv(Dw)*C,
C            Bw = (B*D' + P*C')*inv(Dw'),
C            D*D' = Dw*Dw' (Dw upper triangular),
C
C     and, with Aw = A - Bw*Hw, X is the stabilizing solution of the
C     Riccati equation
C
C            Aw'*X + X*Aw + Hw'*Hw + X*Bw*Bw'*X = 0.   (3)
C
C     The P-by-M matrix D must have full row rank. Matrix A must be
C     stable and in a real Schur form.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of state-space representation, i.e.,
C             the order of the matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  M >= P >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             stable state dynamics matrix A in a real Schur canonical
C             form.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain the
C             input/state matrix B, corresponding to the Schur matrix A.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading P-by-N part of this array must contain the
C             state/output matrix C, corresponding to the Schur
C             matrix A.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M)
C             The leading P-by-M part of this array must
C             contain the full row rank input/output matrix D.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,P).
C
C     SCALEC  (output) DOUBLE PRECISION
C             Scaling factor for the controllability Grammian in (1).
C
C     SCALEO  (output) DOUBLE PRECISION
C             Scaling factor for the observability Grammian in (2).
C
C     S       (output) DOUBLE PRECISION array, dimension (LDS,N)
C             The leading N-by-N upper triangular part of this array
C             contains the Cholesky factor Su of the cotrollability
C             Grammian P = Su*Su' satisfying (1).
C
C     LDS     INTEGER
C             The leading dimension of array S.  LDS >= MAX(1,N).
C
C     R       (output) DOUBLE PRECISION array, dimension (LDR,N)
C             The leading N-by-N upper triangular part of this array
C             contains the Cholesky factor Ru of the observability
C             Grammian Q = Ru'*Ru satisfying (2).
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,N).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (2*N)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK and DWORK(2) contains RCOND, the reciprocal
C             condition number of the U11 matrix from the expression
C             used to compute X = U21*inv(U11). A small value RCOND
C             indicates possible ill-conditioning of the Riccati
C             equation (3).
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX( 2, N*(MAX(N,M,P)+5),
C                            2*N*P+MAX(P*(M+2),10*N*(N+1) ) ).
C             For optimum performance LDWORK should be larger.
C
C     BWORK   LOGICAL array, dimension 2*N
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the state matrix A is not stable or is not in a
C                   real Schur form;
C             = 2:  the reduction of Hamiltonian matrix to real Schur
C                   form failed;
C             = 3:  the reordering of the real Schur form of the
C                   Hamiltonian matrix failed;
C             = 4:  the Hamiltonian matrix has less than N stable
C                   eigenvalues;
C             = 5:  the coefficient matrix U11 in the linear system
C                   X*U11 = U21, used to determine X, is singular to
C                   working precision;
C             = 6:  the feedthrough matrix D has not a full row rank P.
C
C     CONTRIBUTORS
C
C     A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2000.
C     D. Sima, University of Bucharest, May 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, May 2000.
C     Based on the RASP routines SRGRO and SRGRO1, by A. Varga, 1992.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001.
C
C     KEYWORDS
C
C     Minimal realization, model reduction, multivariable system,
C     state-space model, state-space representation,
C     stochastic balancing.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE, TWO
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
C     .. Scalar Arguments ..
      INTEGER          INFO, LDA, LDB, LDC, LDD, LDR, LDS, LDWORK, M, N,
     $                 P
      DOUBLE PRECISION SCALEC, SCALEO
C     .. Array Arguments ..
      INTEGER          IWORK(*)
      DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                 DWORK(*), R(LDR,*), S(LDS,*)
      LOGICAL          BWORK(*)
C     .. Local Scalars ..
      INTEGER          I, IERR, KBW, KCW, KD, KDW, KG, KQ, KS, KTAU, KU,
     $                 KW, KWI, KWR, LW, N2, WRKOPT
      DOUBLE PRECISION RCOND, RTOL
C     .. External Functions ..
      DOUBLE PRECISION DLANGE, DLAMCH
      EXTERNAL         DLANGE, DLAMCH
C     .. External Subroutines ..
      EXTERNAL         DGEMM, DGERQF, DLACPY, DORGRQ, DSYRK, DTRMM,
     $                 DTRSM, SB02MD, SB03OU, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC        ABS, DBLE, INT, MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
      LW   = MAX( 2, N*( MAX( N, M, P ) + 5 ),
     $            2*N*P + MAX( P*(M + 2), 10*N*(N + 1) ) )
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 .OR. P.GT.M ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -9
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -11
      ELSE IF( LDS.LT.MAX( 1, N ) ) THEN
         INFO = -15
      ELSE IF( LDR.LT.MAX( 1, N ) ) THEN
         INFO = -17
      ELSE IF( LDWORK.LT.LW ) THEN
         INFO = -20
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB09HY', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      SCALEC = ONE
      SCALEO = ONE
      IF( MIN( N, M, P ).EQ.0 ) THEN
         DWORK(1) = TWO
         DWORK(2) = ONE
         RETURN
      END IF
C
C     Solve for Su the Lyapunov equation
C                                      2
C     A*(Su*Su') + (Su*Su')*A' + scalec *B*B' = 0 .
C
C     Workspace:  need   N*(MAX(N,M) + 5);
C                 prefer larger.
C
      KU   = 1
      KTAU = KU + N*MAX( N, M )
      KW   = KTAU + N
C
      CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N )
      CALL SB03OU( .FALSE., .TRUE., N, M, A, LDA, DWORK(KU), N,
     $             DWORK(KTAU), S, LDS, SCALEC, DWORK(KW),
     $             LDWORK - KW + 1, IERR )
      IF( IERR.NE.0 ) THEN
         INFO = 1
         RETURN
      ENDIF
      WRKOPT = INT( DWORK(KW) ) + KW - 1
C
C     Allocate workspace for Bw' (P*N), Cw (P*N), Q2 (P*M),
C     where Q2 = inv(Dw)*D.
C     Workspace:  need   2*N*P + P*M.
C
      KBW  = 1
      KCW  = KBW  + P*N
      KD   = KCW  + P*N
      KDW  = KD   + P*(M - P)
      KTAU = KD   + P*M
      KW   = KTAU + P
C
C     Compute an upper-triangular Dw such that D*D' = Dw*Dw', using
C     the RQ-decomposition of D: D = [0 Dw]*( Q1 ).
C                                           ( Q2 )
C     Additional workspace:  need 2*P; prefer P + P*NB.
C
      CALL DLACPY( 'F', P, M, D, LDD, DWORK(KD), P )
      CALL DGERQF( P, M, DWORK(KD), P, DWORK(KTAU), DWORK(KW),
     $             LDWORK-KW+1, IERR )
      WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C
C     Check the full row rank of D.
C
      RTOL = DBLE( M ) * DLAMCH( 'E' ) *
     $       DLANGE( '1', P, M, D, LDD, DWORK )
      DO 10 I = KDW, KDW+P*P-1, P+1
         IF( ABS( DWORK(I) ).LE.RTOL ) THEN
            INFO = 6
            RETURN
         END IF
   10 CONTINUE
C                    -1
C     Compute Hw = Dw  *C.
C
      CALL DLACPY( 'F', P, N, C, LDC, DWORK(KCW), P )
      CALL DTRSM( 'Left', 'Upper', 'No-transpose', 'Non-unit', P, N,
     $            ONE, DWORK(KDW), P, DWORK(KCW), P )
C
C     Compute Bw' = inv(Dw)*(D*B' + C*Su*Su').
C
C     Compute first Hw*Su*Su' in Bw'.
C
      CALL DLACPY( 'F', P, N, DWORK(KCW), P, DWORK(KBW), P )
      CALL DTRMM( 'Right', 'Upper', 'No-transpose', 'Non-unit', P, N,
     $            ONE, S, LDS, DWORK(KBW), P )
      CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', P, N,
     $            ONE, S, LDS, DWORK(KBW), P )
C
C     Compute Q2 = inv(Dw)*D, as the last P lines of the orthogonal
C     matrix ( Q1 ) from the RQ decomposition of D.
C            ( Q2 )
C     Additional workspace:  need P; prefer P*NB.
C
      CALL DORGRQ( P, M, P, DWORK(KD), P, DWORK(KTAU), DWORK(KW),
     $             LDWORK-KW+1, IERR )
      WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C
C     Compute Bw' <- Bw' + Q2*B'.
C
      CALL DGEMM( 'No-transpose', 'Transpose', P, N, M, ONE,
     $            DWORK(KD), P, B, LDB, ONE, DWORK(KBW), P )
C
C     Compute Aw = A - Bw*Hw in R.
C
      CALL DLACPY( 'F', N, N, A, LDA, R, LDR )
      CALL DGEMM( 'Transpose', 'No-transpose', N, N, P, -ONE,
     $            DWORK(KBW), P, DWORK(KCW), P, ONE, R, LDR )
C
C     Allocate storage to solve the Riccati equation (3) for
C     G(N*N), Q(N*N), WR(2N), WI(2N), S(2N*2N), U(2N*2N).
C
      N2  = N + N
      KG  = KD
      KQ  = KG  + N*N
      KWR = KQ  + N*N
      KWI = KWR + N2
      KS  = KWI + N2
      KU  = KS  + N2*N2
      KW  = KU  + N2*N2
C
C     Compute G = -Bw*Bw'.
C
      CALL DSYRK( 'Upper', 'Transpose', N, P, -ONE, DWORK(KBW), P, ZERO,
     $            DWORK(KG), N )
C
C     Compute Q = Hw'*Hw.
C
      CALL DSYRK( 'Upper', 'Transpose', N, P, ONE, DWORK(KCW), P, ZERO,
     $            DWORK(KQ), N )
C
C     Solve
C
C        Aw'*X + X*Aw + Q - X*G*X = 0,
C
C     with Q =  Hw'*Hw  and  G = -Bw*Bw'.
C     Additional workspace: need   6*N;
C                           prefer larger.
C
      CALL SB02MD( 'Continuous', 'None', 'Upper', 'General', 'Stable',
     $             N, R, LDR, DWORK(KG), N, DWORK(KQ), N, RCOND,
     $             DWORK(KWR), DWORK(KWI), DWORK(KS), N2,
     $             DWORK(KU), N2, IWORK, DWORK(KW), LDWORK-KW+1,
     $             BWORK, INFO )
      IF( INFO.NE.0 )
     $   RETURN
      WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C
C     Compute Cw = Hw - Bw'*X.
C
      CALL DGEMM ( 'No-transpose', 'No-transpose', P, N, N, -ONE,
     $              DWORK(KBW), P, DWORK(KQ), N, ONE, DWORK(KCW), P )
C
C     Solve for Ru the Lyapunov equation
C                                      2
C     A'*(Ru'*Ru) + (Ru'*Ru)*A + scaleo  * Cw'*Cw = 0 .
C
C     Workspace:  need   N*(MAX(N,P) + 5);
C                 prefer larger.
C
      KTAU = KCW  + N*MAX( N, P )
      KW   = KTAU + N
C
      CALL SB03OU( .FALSE., .FALSE., N, P, A, LDA, DWORK(KCW), P,
     $             DWORK(KTAU), R, LDR, SCALEO, DWORK(KW),
     $             LDWORK - KW + 1, IERR )
      WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C
C     Save optimal workspace and RCOND.
C
      DWORK(1) = WRKOPT
      DWORK(2) = RCOND
C
      RETURN
C *** Last line of AB09HY ***
      END


      SUBROUTINE W3FA03V(PRESS,HEIGHT,TEMP,THETA,N)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    W3FA03V     COMPUTE STANDARD HEIGHT, TEMP, AND POT TEMP
C   PRGMMR: KEYSER           ORG: W/NMC22    DATE: 92-06-29
C
C ABSTRACT: COMPUTES THE STANDARD HEIGHT, TEMPERATURE, AND POTENTIAL
C   TEMPERATURE GIVEN THE PRESSURE IN MILLIBARS ( > 8.68 MB ).  FOR
C   HEIGHT AND TEMPERATURE THE RESULTS DUPLICATE THE VALUES IN THE
C   U.S. STANDARD ATMOSPHERE (L962), WHICH IS THE ICAO STANDARD
C   ATMOSPHERE TO 54.7487 MB (20 KM) AND THE PROPOSED EXTENSION TO
C   8.68 MB (32 KM).  FOR POTENTIAL TEMPERATURE A VALUE OF  2/7  IS
C   USED FOR  RD/CP.
C
C PROGRAM HISTORY LOG:
C   74-06-01  J. MCDONELL W345     -- ORIGINAL AUTHOR
C   84-06-01  R.E.JONES W342       -- CHANGE TO IBM VS FORTRAN
C   92-06-29  D. A. KEYSER W/NMC22 -- CONVERT TO CRAY CFT77 FORTRAN
C   94-09-13  R.E.JONES            -- VECTORIZED VERSION TO DO ARRAY
C                                     INSTEAD OF ONE WORD
C
C USAGE:    CALL W3FA03V(PRESS,HEIGHT,TEMP,THETA,N)
C   INPUT ARGUMENT LIST:
C     PRESS    - PRESSURE ARRAY IN MILLIBARS
C
C   OUTPUT ARGUMENT LIST:
C     HEIGHT   - HEIGHT ARRAY IN METERS
C     TEMP     - TEMPERATURE ARRAY IN DEGREES KELVIN
C     THETA    - POTENTIAL TEMPERATURE ARRAY IN DEGREES KELVIN
C     N        - NUMBER OF POINTS IN ARRAY PRESS
C
C   SUBPROGRAMS CALLED:
C     LIBRARY:
C       CRAY     - ALOG
C
C REMARKS: NOT VALID FOR PRESSURES LESS THAN 8.68 MILLIBARS, DECLARE
C   ALL PARAMETERS AS TYPE REAL.
C
C WARNING: HEIGHT, TEMP, THETA ARE NOW ALL ARRAYS, YOU MUST
C          HAVE ARRAYS OF SIZE N OR YOU WILL WIPE OUT MEMORY.
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY C916/128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
      REAL  M0
      REAL  HEIGHT(*)
      REAL  PRESS(*)
      REAL  TEMP(*)
      REAL  THETA(*)
C
      SAVE
C
      DATA  G/9.80665/,RSTAR/8314.32/,M0/28.9644/,PISO/54.7487/,
     $ ZISO/20000./,SALP/-.0010/,PZERO/1013.25/,T0/288.15/,ALP/.0065/,
     $ PTROP/226.321/,TSTR/216.65/
C
      ROVCP = 2.0/7.0
      R     = RSTAR/M0
      ROVG  = R/G
      FKT   = ROVG * TSTR
      AR    = ALP  * ROVG
      PP0   = PZERO**AR
      AR1   = SALP * ROVG
      PP01  = PISO**AR1
C
      DO J = 1,N
      IF (PRESS(J).LT.PISO) THEN
C
C     COMPUTE LAPSE RATE = -.0010 CASES
C
        HEIGHT(J) = ((TSTR/(PP01 * SALP )) * (PP01-(PRESS(J) ** AR1)))
     &              + ZISO
        TEMP(J)   = TSTR - ((HEIGHT(J) - ZISO) * SALP)
C
      ELSE IF (PRESS(J).GT.PTROP) THEN
C
        HEIGHT(J) = (T0/(PP0 * ALP)) * (PP0 - (PRESS(J) ** AR))
        TEMP(J)   = T0 - (HEIGHT(J) * ALP)
C
      ELSE
C
C     COMPUTE ISOTHERMAL CASES
C
        HEIGHT(J) = 11000.0 + (FKT * ALOG(PTROP/PRESS(J)))
        TEMP(J)   = TSTR
C
      END IF
        THETA(J)  = TEMP(J) * ((1000./PRESS(J))**ROVCP)
      END DO
C
      RETURN
      END


module test_mod
    use, intrinsic :: iso_fortran_env, only: i1 => int8, i2 => int16, i4 => int32, &
                                           r4 => real32
    implicit none
contains
    elemental function square(x) result(res)
        implicit none
        real(r4), intent(in) :: x
        real(r4) :: res
        res = x*x
    end function
end module

program functional_test
    use test_mod

    implicit none
    real(r4), dimension(3) :: x = (/ 1.0, 2.0, 3.0 /)
    real(r4), dimension(3) :: y = [1.0, 2.0, 3.0]
    character(len = 30) :: s = "ComplicatedPhenomenon"
    integer(i4) :: c(3,3)= reshape([0,3,2,4,3,2,5,1,2], shape(c))
    integer(i4) :: cc(8)=-1

    !print *, x(1:3)(1)
    print *, square(x)
    print *, square(y)
    print *, y(2:)
    print *, s(1:)

    write(*,'(3i3)') c        ! writes 0 3 2
                             !        4 3 2
                             !        5 1 2
    write(*,*) pack(c,mask=(c > 2))
                             ! writes 3 4 3 5
    write(*,*) pack(c,mask=(c > 2),vector=cc)
                             ! writes 3 4 3 5 -1 -1 -1 -1 -1
    write(*,*) pack(c,.true.) ! writes 0 3 2 4 3 2 5 1 2

end program functional_test


! This file is part of fortran_tester
! Copyright 2018 Pierre de Buyl
! License: BSD

program test_tester_6
  use tester
  implicit none

  integer, parameter :: rk = selected_real_kind(15)
  real(kind=rk), parameter :: pi = 4*atan(1._rk)
  type(tester_t) :: test

  call test%init()

  call test%assert_close(sin(2*pi), 0._rk)

  call test%assert_close(sin(2*3.1415927), 0.)

  call test%print()

end program test_tester_6


program mode_test
  use Qsort_Module only Qsort => sort
  implicit none

  integer, parameter    :: S = 10
  integer, dimension(S) :: a1 = (/ -1, 7, 7, 2, 2, 2, -1, 7, -3, -3 /)
  integer, dimension(S) :: a2 = (/  1, 1, 1, 1, 1, 0, 2, 2, 2, 2 /)
  integer, dimension(S) :: a3 = (/  0, 0, -1, -1, 9, 9, 3, 3, 7, 7 /)

  integer, dimension(S) :: o
  integer               :: l, trash

  print *, stat_mode(a1)

  trash = stat_mode(a1, o, l)
  print *, o(1:l)
  trash = stat_mode(a2, o, l)
  print *, o(1:l)
  trash = stat_mode(a3, o, l)
  print *, o(1:l)

contains

  ! stat_mode returns the lowest (if not unique) mode
  ! others can hold other modes, if the mode is not unique
  ! if others is provided, otherslen should be provided too, and
  ! it says how many other modes are there.
  ! ok can be used to know if the return value has a meaning
  ! or the mode can't be found (void arrays)
  integer function stat_mode(a, others, otherslen, ok)
    integer, dimension(:), intent(in) :: a
    logical, optional, intent(out)    :: ok
    integer, dimension(size(a,1)), optional, intent(out) :: others
    integer, optional, intent(out)    :: otherslen

    ! ta is a copy of a, we sort ta modifying it, freq
    ! holds the frequencies and idx the index (for ta) so that
    ! the value appearing freq(i)-time is ta(idx(i))
    integer, dimension(size(a, 1)) :: ta, freq, idx
    integer                        :: rs, i, tm, ml, tf

    if ( present(ok) ) ok = .false.

    select case ( size(a, 1) )
    case (0)  ! no mode... ok is false
       return
    case (1)
       if ( present(ok) ) ok = .true.
       stat_mode = a(1)
       return
    case default
       if ( present(ok) ) ok = .true.
       ta = a         ! copy the array
       call sort(ta)  ! sort it in place (cfr. sort algos on RC)
       freq = 1
       idx = 0
       rs = 1         ! rs will be the number of different values

       do i = 2, size(ta, 1)
          if ( ta(i-1) == ta(i) ) then
             freq(rs) = freq(rs) + 1
          else
             idx(rs) = i-1
             rs = rs + 1
          end if
       end do
       idx(rs) = i-1

       ml = maxloc(freq(1:rs), 1)  ! index of the max value of freq
       tf = freq(ml)               ! the max frequency
       tm = ta(idx(ml))            ! the value with that freq

       ! if we want all the possible modes, we provide others
       if ( present(others) ) then
          i = 1
          others(1) = tm
          do
             freq(ml) = 0
             ml = maxloc(freq(1:rs), 1)
             if ( tf == freq(ml) ) then ! the same freq
                i = i + 1               ! as the max one
                others(i) = ta(idx(ml))
             else
                exit
             end if
          end do

          if ( present(otherslen) ) then
             otherslen = i
          end if

       end if
       stat_mode = tm
    end select

  end function stat_mode

end program mode_test


!This subroutine generates a vector of auto-correlations of elements
!in a vector v. Each element in the autocorrelation vector corresponds
!to a particular delta (in the index) between successive elements of the vector
!for which the autocorrelation is computed. The auto_correlation is computed,
!beginning with delta = delta_min and ending with delta = delta_max

subroutine auto_correlation_vector(v, N, delta_min, delta_max, auto_vector)
   use params, only: dp

   !Input variables
   real(dp) v(N)
   integer N
   integer delta_min
   integer delta_max

   !Intermediate variables

   integer Ndelta
   integer delta
   real(dp) auto

   !output variables

   real(dp) auto_vector(delta_max - delta_min + 1)

   Ndelta = delta_max - delta_min + 1

   do I = 0, Ndelta - 1
      delta = delta_min + I
      CALL auto_correlation(v, N, delta, auto)
      auto_vector(I + 1) = auto
   ENDdo

   RETURN

ENDsubroutine


program test_ewald5

! This test compares lattice energy 'eew' calculated from the Ewald summation
! against the energy calculated using the Madelung constant for various lattice
! constants L. The agreement is essentially to machine precision.
! It also compares forces and stresses.

! Similar to test_ewald, but here the diagonal Na atom is moved by [3,1,2] / 16
! towards the Cl atom.

use types, only: dp
use constants, only: ang2bohr, kJmol2Ha
use ewald_sums, only: ewald, ewald2, fred2fcart
use utils, only: assert, init_random
implicit none

integer :: natom, ntypat
! Various NaCl lattice constants in A
real(dp), parameter :: Llist(5) = [5.6402_dp, 5.5_dp, 4.5_dp, 6.5_dp, 10._dp]
! Madelung constant for this system
real(dp), parameter :: alpha = 1.9352066351335044_dp
! Components of the correct force (multiplied by L^2)
real(dp), parameter :: fcorrect0(3) = [3.3701600314233184_dp, &
    -0.48348071944082838_dp, -0.18734923455100549_dp]
! Components of the correct stress tensor (multiplied by L)
real(dp), parameter :: stress0(6) = [-7.6571091389140866_dp, &
    -2.9686706092940662_dp, -4.8558733328598898_dp, 0.35671778132537890_dp, &
     3.9045478316555458_dp, 1.5739340118629772_dp]

real(dp) :: ucvol
integer, allocatable :: typat(:)
real(dp) :: gmet(3, 3), rmet(3, 3), rprim(3, 3), gprim(3, 3), stress(6)
real(dp) :: eew
real(dp), allocatable :: xred(:, :), zion(:), grewtn(:, :), fcart(:, :)
real(dp) :: L, E_ewald, E_madelung
integer :: i, j

! Conventional cell:
natom = 8
ntypat = 2
allocate(xred(3, natom), zion(ntypat), grewtn(3, natom), typat(natom), &
    fcart(3, natom))
! Cl^-
xred(:, 1) = [0, 0, 0]
xred(:, 2) = [1, 1, 0] / 2._dp
xred(:, 3) = [1, 0, 1] / 2._dp
xred(:, 4) = [0, 1, 1] / 2._dp
! Na^+
xred(:, 5) = [1, 1, 1] / 2._dp
xred(:, 6) = [1, 0, 0] / 2._dp
xred(:, 7) = [0, 1, 0] / 2._dp
xred(:, 8) = [0, 0, 1] / 2._dp

xred(:, 5:8) = xred(:, 5:8) - spread([3, 1, 2] / 16._dp, 2, 4)
xred(:, 6:8) = xred(:, 6:8) - floor(xred(:, 6:8))
call assert(all(abs(xred(:, 5) * 16 - [5, 7, 6]) < 1e-15_dp))
typat = [1, 1, 1, 1, 2, 2, 2, 2]
zion = [-1, +1]

do i = 1, size(Llist)
    L = Llist(i) * ang2bohr

    rmet = 0
    rmet(1, 1) = L**2
    rmet(2, 2) = L**2
    rmet(3, 3) = L**2

    ! gmet = inv(rmet)
    gmet = 0
    gmet(1, 1) = 1/L**2
    gmet(2, 2) = 1/L**2
    gmet(3, 3) = 1/L**2

    ! ucvol = sqrt(det(rmet))
    ucvol = L**3

    ! Reciprocal primitive vectors (without 2*pi) in cartesian coordinates.
    ! gmet = matmul(transpose(gprim), gprim)
    gprim = 0
    gprim(1, 1) = 1 / L
    gprim(2, 2) = 1 / L
    gprim(3, 3) = 1 / L

    ! Real space primitive vectors
    rprim = 0
    rprim(1, 1) = L
    rprim(2, 2) = L
    rprim(3, 3) = L

    call ewald(eew,gmet,grewtn,natom,ntypat,rmet,typat,ucvol,xred,zion)

    E_ewald = eew / (natom/ntypat)
    E_madelung = -2*alpha/L

    call ewald2(gmet,natom,ntypat,rmet,rprim,gprim,stress,typat,ucvol, &
                xred,zion)

    print *, "a =", L/ang2bohr*100, "pm"
    print *, "Madelung:", E_madelung / kJmol2Ha, "kJ/mol"
    print *, "Ewald:   ", E_ewald / kJmol2Ha, "kJ/mol"
    print *, "error:   ", abs(E_ewald - E_madelung), "a.u."
    call assert(abs(E_ewald - E_madelung) < 1e-14_dp)
    stress = -stress * ucvol
    call assert(all(abs(stress - stress0/L) < 1e-15_dp))

    call fred2fcart(fcart, grewtn, gprim)
    do j = 1, 4
        call assert(all(abs(fcart(:, j) - (-fcorrect0/L**2)) < 1e-15_dp))
    end do
    do j = 5, 8
        call assert(all(abs(fcart(:, j) - (+fcorrect0/L**2)) < 1e-15_dp))
    end do
end do
deallocate(xred, zion, grewtn, typat, fcart)

print *, "--------"

! Primitive cell (FCC lattice)
natom = 2
ntypat = 2
allocate(xred(3, natom), zion(ntypat), grewtn(3, natom), typat(natom), &
    fcart(3, natom))
! Cl^-
xred(:, 1) = [0, 0, 0]
! Na^+
xred(:, 2) = [2, 3, 4] / 8._dp
typat = [1, 2]
zion = [-1._dp, 1._dp]

do i = 1, size(Llist)
    L = Llist(i) * ang2bohr

    rmet(1, :) = [2, 1, 1]
    rmet(2, :) = [1, 2, 1]
    rmet(3, :) = [1, 1, 2]
    rmet = rmet * L**2 / 4

    ! gmet = inv(rmet)
    gmet(1, :) = [ 3, -1, -1]
    gmet(2, :) = [-1,  3, -1]
    gmet(3, :) = [-1, -1,  3]
    gmet = gmet / L**2

    ! ucvol = sqrt(det(rmet))
    ucvol = L**3 / 4

    ! Reciprocal primitive vectors (without 2*pi) in cartesian coordinates.
    ! gmet = matmul(transpose(gprim), gprim)
    gprim(:, 1) = [ 1, -1,  1] / L
    gprim(:, 2) = [ 1,  1, -1] / L
    gprim(:, 3) = [-1,  1,  1] / L

    ! gprim = transpose(inv(rprim))
    rprim(:, 1) = [1, 0, 1] * L / 2
    rprim(:, 2) = [1, 1, 0] * L / 2
    rprim(:, 3) = [0, 1, 1] * L / 2

    call ewald(eew,gmet,grewtn,natom,ntypat,rmet,typat,ucvol,xred,zion)

    E_ewald = eew / (natom/ntypat)
    E_madelung = -2*alpha/L

    call ewald2(gmet,natom,ntypat,rmet,rprim,gprim,stress,typat,ucvol, &
                xred,zion)

    print *, "a =", L/ang2bohr*100, "pm"
    print *, "Madelung:", E_madelung / kJmol2Ha, "kJ/mol"
    print *, "Ewald:   ", E_ewald / kJmol2Ha, "kJ/mol"
    print *, "error:   ", abs(E_ewald - E_madelung), "a.u."
    call assert(abs(E_ewald - E_madelung) < 1e-15_dp)
    call fred2fcart(fcart, grewtn, gprim)
    call assert(all(abs(fcart(:, 1) - (-fcorrect0/L**2)) < 1e-15_dp))
    call assert(all(abs(fcart(:, 2) - (+fcorrect0/L**2)) < 1e-15_dp))
    stress = -stress * L**3
    call assert(all(abs(stress - stress0/L) < 1e-15_dp))
    call fred2fcart(fcart, xred, rprim)
    call assert(all(abs(fcart(:, 1) / L * 16) < 1e-15_dp))
    ! Must agree with the xred(:, 5) test in the previous section, i.e. we are
    ! getting the correct cartesian coordinates.
    call assert(all(abs(fcart(:, 2) / L * 16 - [5, 7, 6]) < 1e-15_dp))
end do
deallocate(xred, zion, grewtn, typat, fcart)
end program


module type_volumeQuadrature
#include <messenger.h>
    use mod_kinds,              only: rk,ik
    use mod_constants,          only: NFACES,XI_MIN,XI_MAX,ETA_MIN,ETA_MAX,ZETA_MIN,ZETA_MAX, &
                                      XI_DIR,ETA_DIR,ZETA_DIR,ZERO, TWO_DIM, THREE_DIM, ONE

    use mod_gauss_legendre,      only: gl_nodes, gl_weights
    use mod_polynomial,         only: polynomial_val, dpolynomial_val
    use mod_quadrature_tools,   only: compute_nnodes1d_volume
    use type_point,             only: point_t

    implicit none
    private

    !> Type defining volume quadrature
    !!      - Contains nodes, weights, and matrices for Gauss-quadrature. Used for
    !!        integration and projection routines. An instance is defined for a specified
    !!        number of quadrature nodes and specified number of terms in a polynomial expansion
    !!
    !!  @author Nathan A. Wukie
    !!
    !----------------------------------------------------------------------------------------
    type, public :: volumeQuadrature_t
        integer(ik)                 :: nnodes       !< Number of volume quadrature nodes
        integer(ik)                 :: nterms       !< Number of terms in the polynomial
                                                    !< expansion

        type(point_t),  allocatable :: nodes(:)     !< Array of quadrature node points
        real(rk),       allocatable :: weights(:)   !< Array of quadrature node weights

        real(rk),       allocatable :: val(:,:)     !< Mat to interp expansion to quad nodes
        real(rk),       allocatable :: ddxi(:,:)    !< Mat to interp deriv(ddxi)   to quad nodes
        real(rk),       allocatable :: ddeta(:,:)   !< Mat to interp deriv(ddeta)  to quad nodes
        real(rk),       allocatable :: ddzeta(:,:)  !< Mat to interp deriv(ddzeta) to quad nodes

        real(rk),       allocatable :: mass(:,:)    !< Mass matrix for the reference element
        real(rk),       allocatable :: dmass(:)     !< Diag of the mass matrix the ref element

    contains

        procedure :: init

    end type volumeQuadrature_t
    !****************************************************************************************

contains

    !> Initialization routine for volumeQuadrature_t instance.
    !!      - Allocates storage for member data. Initializes ndoes, weights, and
    !!        interpolation matrices.
    !!
    !!  @author Nathan A. Wukie
    !!  @param[in]  nnodes  Number of nodes used for Gauss-quadrature
    !!  @param[in]  nterms  Number of terms in the associated polynomial expansion
    !!
    !!
    !!  TODO: TEST SPACEDIM
    !!
    !----------------------------------------------------------------------------------------
    subroutine init(self,spacedim,nnodes,nterms)
        class(volumeQuadrature_t),  intent(inout)   :: self
        integer(ik),                intent(in)      :: spacedim
        integer(ik),                intent(in)      :: nnodes
        integer(ik),                intent(in)      :: nterms

        integer(ik)                                 :: ixi,ieta,izeta,inode,iterm,nnodes1d,ierr
        integer(ik)                                 :: nnodes_xi, nnodes_eta, nnodes_zeta
        real(rk)                                    :: xi,eta,zeta
        real(rk), dimension(:), allocatable         :: xi_vals,eta_vals,zeta_vals
        real(rk), dimension(:), allocatable         :: xi_weights,eta_weights,zeta_weights
        real(rk), dimension(nterms,nnodes)          :: temp
        type(point_t)                               :: node

        self%nnodes = nnodes
        self%nterms = nterms

        !
        ! allocate quadrature storage
        !
        allocate(self%nodes(nnodes),self%weights(nnodes),       &
                 self%val(   nnodes,nterms),                    &
                 self%ddxi(  nnodes,nterms),                    &
                 self%ddeta( nnodes,nterms),                    &
                 self%ddzeta(nnodes,nterms),                    &
                 self%mass(nterms,nterms),                      &
                 self%dmass(nterms), stat=ierr)
        if (ierr /= 0) call AllocationError

        !
        ! Initialize quadrature node coordinates for face sets
        !
        ! find number nodes in 1D polynomial
        nnodes1d = compute_nnodes1d_volume(spacedim,nnodes)

        allocate(xi_vals(nnodes1d),eta_vals(nnodes1d),zeta_vals(nnodes1d))
        allocate(xi_weights(nnodes1d),eta_weights(nnodes1d),zeta_weights(nnodes1d))

        xi_vals      = gl_nodes(nnodes1d)
        eta_vals     = gl_nodes(nnodes1d)
        zeta_vals    = gl_nodes(nnodes1d)
        xi_weights   = gl_weights(nnodes1d)
        eta_weights  = gl_weights(nnodes1d)
        zeta_weights = gl_weights(nnodes1d)

        !
        ! Specialize for 2D, 3D
        !
        if ( spacedim == THREE_DIM ) then
            nnodes_zeta = nnodes1d
        else if ( spacedim == TWO_DIM ) then
            nnodes_zeta  = 1
            zeta_weights = ONE
            zeta_vals    = ZERO
        end if

        !
        ! Volume node coordinates and weights
        !
        inode = 1
        do izeta = 1,nnodes_zeta        ! specialized for 2D/3D
            do ieta = 1,nnodes1d
                do ixi = 1,nnodes1d
                    xi   = xi_vals(  ixi)
                    eta  = eta_vals( ieta)
                    zeta = zeta_vals(izeta)

                    call self%nodes(inode)%set(xi,eta,zeta)
                    self%weights(inode) = xi_weights(ixi)*eta_weights(ieta)*zeta_weights(izeta)

                    inode = inode + 1
                end do
            end do
        end do

        !
        ! Initialize values and partial derivatives of each modal
        ! polynomial at each volume quadrature node
        !
        do iterm = 1,nterms
            do inode = 1,nnodes
                    node = self%nodes(inode)
                    self%val(   inode,iterm) =  polynomial_val(spacedim,nterms,iterm,[node%c1_,node%c2_,node%c3_])
                    self%ddxi(  inode,iterm) = dpolynomial_val(spacedim,nterms,iterm,[node%c1_,node%c2_,node%c3_],XI_DIR)
                    self%ddeta( inode,iterm) = dpolynomial_val(spacedim,nterms,iterm,[node%c1_,node%c2_,node%c3_],ETA_DIR)
                    self%ddzeta(inode,iterm) = dpolynomial_val(spacedim,nterms,iterm,[node%c1_,node%c2_,node%c3_],ZETA_DIR)
            end do
        end do

        !
        !   Initialize reference mass matrix
        !
        temp = transpose(self%val)
        do iterm = 1,nterms
            temp(iterm,:) = temp(iterm,:)*(self%weights)
        end do

        self%mass = matmul(temp,self%val)

        !
        ! Set reference mass diagonal
        !
        do iterm = 1,nterms
            self%dmass(iterm) = self%mass(iterm,iterm)
        end do

    end subroutine init
    !****************************************************************************************

end module type_volumeQuadrature


      double complex function A0phiggggpmmm(j1,j2,j3,j4,za,zb)
      implicit none
C----Expresssion of Eq. (3.8) of hep-th/0411092v2
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      integer j1,j2,j3,j4
      double complex zab2
      double precision s3
      s3(j1,j2,j3)=s(j1,j2)+s(j2,j3)+s(j3,j1)
      zab2(j1,j2,j3,j4)=za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)

      A0phiggggpmmm=
     .+(zab2(j3,j2,j4,j1)*za(j2,j4))**2/(s3(j1,j2,j4)*s(j1,j2)*s(j1,j4))
     .+(zab2(j4,j2,j3,j1)*za(j2,j3))**2/(s3(j1,j2,j3)*s(j1,j2)*s(j2,j3))
     .+(zab2(j2,j3,j4,j1)*za(j3,j4))**2/(s3(j1,j3,j4)*s(j1,j4)*s(j3,j4))
     .-za(j2,j4)/(za(j1,j2)*zb(j2,j3)*zb(j3,j4)*za(j4,j1))
     .*(-s(j2,j3)*zab2(j2,j3,j4,j1)/zb(j4,j1)
     .  -s(j3,j4)*zab2(j4,j2,j3,j1)/zb(j1,j2)
     .-s3(j2,j3,j4)*za(j2,j4))
      return
      end


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2015 Guido Dhondt
!
!     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(version 2);
!
!
!     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, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!     calculate the maximal admissible pressure ratio pt2/pt1
!
!     1) assuming M2=1 for adiabatic respectively M2=1/dsqrt(kappa) for isotherm pipe choking
!      M1 is calculated iteratively using a dichotomy scheme
!
!     2)the ratio of the critical pressure ratio  Qred_1/Qred_2crit=Pt2/Pt1
!     =D(M1)/D(M2_crit)is computed [D(M)=M*(1+0.5*(kappa-1)*M)**(-0.5*(kappa+1)/(kappa-1))]
!
!     author: Yannick Muller
!
      subroutine pt2zpt1_crit(pt2,pt1,Tt1,Tt2,lambda,kappa,r,l,d,A,
     &     iflag,inv,pt2zpt1_c,qred_crit,crit,qred_max1,icase)
!
      implicit none
!
      logical crit
!
      integer iflag,inv,icase,i
!
      real*8 pt2,pt1,lambda,kappa,l,d,M1,pt2zpt1,pt2zpt1_c,
     &     km1,kp1,km1zk,kp1zk,Tt1,Tt2,r,A,
     &     xflow_crit,qred_crit,f1,f2,f3,m1_ac,m1_min,m1_max,
     &     expon1,qred_max1,lld
!
!     useful variables and constants
!
      km1=kappa-1.d0
      kp1=kappa+1.d0
      km1zk=km1/kappa
      kp1zk=kp1/kappa
      lld=lambda*l/d
      expon1=-0.5d0*kp1/km1
!
!     adiabatic case
!
      if(icase.eq.0) then
!
!     computing M1 using dichotomy method
!
         i=1
          m1_max=1
          m1_min=0.001d0
          do
             i=i+1
             m1_ac=(m1_min+m1_max)*0.5d0
!
             f1=(1.d0-M1_min**2)*(kappa*M1_min**2)**(-1)
     &            +0.5d0*kp1zk*log((0.5d0*kp1)*M1_min**2
     &            *(1+0.5d0*km1*M1_min**2)**(-1))-lld
!
             f2=(1.d0-M1_ac**2)*(kappa*M1_ac**2)**(-1)
     &            +0.5d0*kp1zk*log((0.5d0*kp1)*M1_ac**2
     &            *(1+0.5d0*km1*M1_ac**2)**(-1))-lld
!
             f3=(1.d0-M1_max**2)*(kappa*M1_max**2)**(-1)
     &            +0.5d0*kp1zk*log((0.5d0*kp1)*M1_max**2
     &            *(1+0.5d0*km1*M1_max**2)**(-1))-lld
!
             if(abs(f2).le.1E-6) then
                M1=m1_ac
                exit
             endif
             if(i.gt.50) then
                M1=M1_ac
                exit
             endif
!
             if((f3.gt.f2).and.(f2.ge.f1)) then
                if((f1.lt.0d0).and.(f2.lt.0d0)) then
                   m1_min=m1_ac
                else
                   m1_max=m1_ac
                endif
             elseif((f3.lt.f2).and.(f2.le.f1)) then
                if((f3.lt.0d0).and.(f2.lt.0d0) )then
                   m1_max=m1_ac
                else
                   m1_min=m1_ac
                endif
             endif
          enddo
!
          Pt2zpt1_c=M1*(0.5d0*kp1)**(0.5*kp1/km1)
     &         *(1+0.5d0*km1*M1**2)**(-0.5d0*kp1/km1)
!
!     isotherm case
!
       elseif (icase.eq.1) then
!
!     computing M1 using dichotomy method for choked conditions M2=1/dsqrt(kappa)
!     (1.d0-kappa*M1**2)/(kappa*M1**2)+log(kappa*M1**2)-lambda*l/d=0
!
          m1_max=1/dsqrt(kappa)
          m1_min=0.1d0
          i=1
          do
             i=i+1
             m1_ac=(m1_min+m1_max)*0.5d0
!
             f1=(1.d0-kappa*M1_min**2)/(kappa*M1_min**2)
     &            +log(kappa*M1_min**2)-lambda*l/d
!
             f2=(1.d0-kappa*M1_ac**2)/(kappa*M1_ac**2)
     &            +log(kappa*M1_ac**2)-lambda*l/d
!
             f3=(1.d0-kappa*M1_max**2)/(kappa*M1_max**2)
     &            +log(kappa*M1_max**2)-lambda*l/d
!
             if((abs(f2).le.1E-5).or.(i.ge.50)) then
                M1=m1_ac
                exit
             endif
!
             if((f3.gt.f2).and.(f2.ge.f1)) then
                if((f1.lt.0d0).and.(f2.lt.0d0)) then
                   m1_min=m1_ac
                else
                   m1_max=m1_ac
                endif
             elseif((f3.lt.f2).and.(f2.le.f1)) then
                if((f3.lt.0d0).and.(f2.lt.0d0) )then
                   m1_max=m1_ac
                else
                   m1_min=m1_ac
                endif
             endif
          enddo
!
!        computing the critical pressure ratio in the isothermal case
!     pt=A*dsqrt(kappa)/(xflow*dsqrt(kappa Tt))*M*(1+0.5d0*(kappa-1)M**2)**(-0.5d0*(kappa+1)/(kappa-1))
!     and forming the pressure ratio between inlet and outlet(choked)
!
          Pt2zPt1_c=dsqrt(Tt2/Tt1)*M1*dsqrt(kappa)*((1+0.5d0*km1/kappa)
     &         /(1+0.5d0*km1*M1**2))**(0.5d0*(kappa+1)/km1)
!
       endif
!
       pt2zpt1=pt2/pt1
       if(Pt2zPt1.le.Pt2zPt1_c) then
          crit=.true.
       endif
!
       if (iflag.eq.1) then
          xflow_crit=inv*M1*Pt1*A/dsqrt(Tt1)*dsqrt(kappa/r)
     &         *(1+0.5d0*km1*M1**2)**(-0.5d0*kp1/km1)
       elseif(iflag.eq.2) then
             qred_max1=M1*dsqrt(kappa/r)
     &            *(1+0.5d0*km1*M1**2)**(-0.5d0*kp1/km1)
       endif
!
       Qred_crit=M1*dsqrt(kappa/r)
     &      *(1+0.5d0*km1*M1**2)**(-0.5d0*kp1/km1)
!
      return
      end


!===============================================================================
program test_spherical_splines
!===============================================================================
!  Create an array of knots, supply some function, then re-express that using
!  the spherical_splines module

   use spherical_splines
   use spherical_geometry, only: sphere_sample

   real(8),parameter :: pi = atan2(1._8,1._8)*4._8

   real(8) :: dd=5. ! approx distance between knot points
   real(8) :: sigma=0.2  ! Gives half-width of 10 degrees
   real(8),allocatable,dimension(:) :: lon,lat
   integer :: n  ! number of points
   real(8),dimension(1) :: val,vlon,vcolat
   real(8) :: half_width
   type(sph_splines_set) :: s
   character(len=KERNEL_NAME_LEN) :: kernel
   character(len=20) :: arg

!  Default to B-splines kernel
   kernel = 'B'

!  If requested, get the kernel name
   if (command_argument_count() == 1) call get_command_argument(1,kernel)
   s%kernel = kernel

!  If requested, we can determine the desired kernel width from the command line,
!  otherwise set it to the spacing of the knots
   half_width = dd
   if (command_argument_count() == 2) then
      call get_command_argument(2,arg)
      read(arg,*) half_width
      write(0,'(a,f0.3,a)') 'test_spherical_splines: Using kernel half-width of ',&
         half_width,' deg.'
   endif

!  Create the knot points
   call sphere_sample(dd,lon,lat,n)

!  Create the knot points on a regular lon,lat grid
!   n = 360*(180-int(dd))/int(dd**2) + 1
!   allocate(lon(n), lat(n))
!   lon(1) = 0.  ;  lat(1) = 90.
!   vlon(1) = -180.
!   do while(vlon(1) < 180.)
!      vcolat(1) = 90. - dd
!      do while (vcolat(1) > -90.)
!         i = i + 1
!         lon(i) = vlon(1)
!         lat(i) = vcolat(1)
!         vcolat(1) = vcolat(1) - dd
!      enddo
!      vlon(1) = vlon(1) + dd
!   enddo
!   i = i + 1
!   lon(i) = 0.  ;  lat(i) = -90.
!
!   if (i /= n) then
!      write(0,'(2(a,i0))') 'i /= n !!    i = ',i,' /= n = ',n
!      stop
!   endif

!  Make room for the values at each knot
   allocate(s%phi(n),s%theta(n),s%a(n),s%c(n))
   s%phi = lon
   s%theta = 90._8 - lat
   s%n = n

!  Fill the points with a bulge at the equator, width controlled by sigma
   s%c = exp((-(s%phi*pi/180._8)**2 - (pi/2._8 - (s%theta*pi/180._8))**2)/sigma**2)
   s%degrees = .true.

!  Alternatively, create a checkerboard
!   s%c = sign(1._8,cos(4._8*s%phi*pi/180._8)*cos(4._8*s%theta*pi/180._8))

!  Make the shape sharp sided
   where (s%c > 0.5)
      s%c = 1.
   elsewhere
      s%c = 0.
   endwhere

!  Fit the splines to the data
   if (s%kernel == 'B')  call sph_splines_fit(s)
   if (s%kernel == 'AP') call sph_splines_fit_AP(s,half_width=half_width)

   write(0,'(a)') 'test_spherical_splines: Evaluating spline-interpolated surface.'

!  Write out points on a regular lon,lat grid
outer:   do j=45,135,1
      do i=-45,45,1
         vlon(1) = real(i)
         vcolat(1) = real(j)
         call sph_splines_eval(vlon,vcolat,s,val,degrees=.true.)
         write(*,*) i,90-j,val(1)
      enddo
   enddo outer

!  Write out the spline points
   open(10,file='knot_points_' // trim(s%kernel) // '.xy')
   write(10,'(2(f0.5,x)/)') (lon(i),lat(i),i=1,n)
   close(10)

end program


      double precision function psi(xd,yd,zd,t)
      implicit none

      double precision xd, yd, zd, t
      double precision l, th, lp, Tfinal, kappa, pi

      common /compi/ pi

      call get_wind_parms(kappa,tfinal)

      call map2polar(xd,yd,zd,l,th)

      lp = l - 2*pi*t/tfinal

      psi = kappa*sin(lp)**2*cos(th)**2*cos(pi*t/Tfinal) -
     &      2*pi*sin(th)/Tfinal

c     # Sign difference from Benchmark problem
      psi = -psi

      end

      subroutine get_psi_vel(xd1,xd2,ds,vn,t)
      implicit none

      double precision xd1(3),xd2(3), ds, vn, psi,t

      vn = (psi(xd1(1),xd1(2),xd1(3),t) -
     &      psi(xd2(1),xd2(2),xd2(3),t))/ds

      end

      subroutine map2polar(x,y,z,lambda,th)
      implicit none

      double precision x,y,z,th,lambda
      double precision r, pi

      common /compi/ pi

      r = sqrt(x**2 + y**2 + z**2)
      th = asin(z/r)

      lambda = atan2(y,x)
      if (lambda .lt. 0) then
         lambda = lambda + 2*pi
      endif

      end

      subroutine set_wind_parms(kappa,tfinal)
      implicit none

      double precision kappa,tfinal
      double precision init_kappa_com, tfinal_com
      common /comwind/ init_kappa_com, tfinal_com

      init_kappa_com = kappa
c     tfinal_com = tfinal
      tfinal_com = 5.0

      end

      subroutine get_wind_parms(kappa,tfinal)
      implicit none

      double precision kappa,tfinal
      double precision init_kappa_com, tfinal_com
      common /comwind/ init_kappa_com, tfinal_com

      kappa = init_kappa_com
      tfinal = tfinal_com

      end


c RWG 20141212
c    m (= nx)	number of points in the model in the horizontal direction
c    n (= nz)	number of points in the model in the vertical discretion
c    is		grid index of the source location in the horizontal direction
c    js		grid index of the source location in the vertical direction
c    h		grid step size (in km?)
c    ns		radius to compute tt analytically around source, up to 5 seems good
c    t		2D array for travel times
c
c Changed to pass arrays slwns, ttime, ti and jm from calling routine, so memory can
c be allocated/freed outside of this routine
c
c..............................................................................
      subroutine wfront2d(m,n,is,js,h,ns,ttime,slwns,ntot,ti,jm)
      IMPLICIT REAL*8 (A-H,O-Z)
      dimension slwns(ntot),ttime(ntot),ti(ntot),jm(ntot)

c      print *,m,n,is,js
c      print *,h,ns,ntot,ttime(1),slwns(1)

      eps = 1e-5
c

c RWG 20160920
c   Added explicit initialation of ttime() to zero; error caught by Scott C. when called multiple
c   times by rupture generator

        do i=1,ntot
          ttime(i) = 0.0
        enddo

      ttime(IS + m*(JS-1)) = 0.0
      IF(IS.LT.M) ttime(IS+1 + m*(JS-1)) = ttime(IS + m*(JS-1)) + 0.5*h*(slwns(IS+1 + m*(JS-1))+slwns(IS + m*(JS-1)))
      IF(JS.LT.N) ttime(IS + m*((JS-1)+1)) = ttime(IS + m*(JS-1)) + 0.5*h*(slwns(IS + m*((JS-1)+1))+slwns(IS + m*(JS-1)))
      IF(IS.GT.1) ttime(IS-1 + m*(JS-1)) = ttime(IS + m*(JS-1)) + 0.5*h*(slwns(IS-1 + m*(JS-1))+slwns(IS + m*(JS-1)))
      IF(JS.GT.1) ttime(IS + m*((JS-1)-1)) = ttime(IS + m*(JS-1)) + 0.5*h*(slwns(IS + m*((JS-1)-1))+slwns(IS + m*(JS-1)))
C
C TRAVEL TIME FOR R = 1
C
      nc = 0
      T0 = ttime(IS + m*(JS-1))
      S0 = slwns(IS + m*(JS-1))
      IF(JS.LT.N.AND.IS.GT.1) THEN
        T1 = ttime(IS + m*((JS-1)+1))
        T2 = ttime(IS-1 + m*(JS-1))
        slo = savg(m,n,slwns,is-1,js)
        slo1= slo
        if((js+2).le.n) slo1 = savg(m,n,slwns,is-1,js+1)
        slo2= slo
        if((is-2).ge.1) slo2 = savg(m,n,slwns,is-2,js)
        CALL ROOTS(ns,nc,1,T0,T1,T2,SLO,slo1,slo2,H,T3,index)
        ttime(IS-1 + m*(JS)) = T3
      END IF
      IF(JS.GT.1.AND.IS.GT.1) THEN
      S0 = slwns(IS + m*(JS-1))
        T1 = ttime(IS + m*(JS-2))
        T2 = ttime(IS-1 + m*(JS-1))
        slo = savg(m,n,slwns,is-1,js-1)
        slo1= slo
        if((js-2).ge.1) slo1 = savg(m,n,slwns,is-1,js-2)
        slo2= slo
        if((is-2).ge.1) slo2 = savg(m,n,slwns,is-2,js-1)
        CALL ROOTS(ns,nc,1,T0,T1,T2,SLO,slo1,slo2,H,T3,index)
        ttime(IS-1 + m*(JS-2)) = T3
      END IF
      IF(JS.GT.1.AND.IS.LT.M) THEN
      S0 = slwns(IS + m*(JS-1))
        T1 = ttime(IS + m*(JS-2))
        T2 = ttime(IS+1 + m*(JS-1))
        slo = savg(m,n,slwns,is,js-1)
        slo1= slo
        if((js-2).ge.1) slo1 = savg(m,n,slwns,is,js-2)
        slo2= slo
        if((is+2).le.m) slo2 = savg(m,n,slwns,is+1,js-1)
        CALL ROOTS(ns,nc,1,T0,T1,T2,SLO,slo1,slo2,H,T3,index)
        ttime(IS+1 + m*(JS-2)) = T3
      END IF
      IF(JS.LT.N.AND.IS.LT.M) THEN
      S0 = slwns(IS + m*(JS-1))
        T1 = ttime(IS + m*(JS))
        T2 = ttime(IS+1 + m*(JS-1))
        slo = savg(m,n,slwns,is,js)
        slo1= slo
        if((js+2).le.n) slo1 = savg(m,n,slwns,is,js+1)
        slo2= slo
        if((is+2).le.m) slo2 = savg(m,n,slwns,is+1,js)
        CALL ROOTS(ns,nc,1,T0,T1,T2,SLO,slo1,slo2,H,T3,index)
        ttime(IS+1 + m*(JS)) = T3
      END IF
      nc = 0

c      print *,'source done'
C
C  TRAVEL TIME FOR R > 1
C
      IR = IS-1
      IF((M-IS).GT.IR) IR = M-IS
      IF((N-JS).GT.IR) IR = N-JS
      IF((JS-1).GT.IR) IR = JS-1
C

c      print *,'starting, IR= ',IR

      DO 90 I=2,IR
C
C                    R I G H T   P A R T
C

        JPOS = JS+I
        IF(JPOS.GT.N) GO TO 2
        JB = IS+I-1
        IF(JB.GT.M) JB = M
        JU = IS-I+1
        IF(JU.LT.1) JU = 1

c      print *,'starting right, JPOS= ',JPOS,'JB= ',JB,'JU= ',JU

        DO J=JU,JB
          TI(J) = ttime(J + m*(JPOS-2))
          JM(J) = J
        enddo
        call sort(ju,jb,ti,jm)
        do 30 j=ju,jb
c
         index = 0
         if(jm(j).eq.m) then
          slo = savg(m,n,slwns,jm(j)-1,jpos-1)
          if(ttime(jm(j)-1 + m*(jpos-1)).eq.0.0) then
            call fd1(ttime(jm(j) + m*(jpos-2)),ttime(jm(j)-1 + m*(jpos-2)),ttime(jm(j)-1 + m*(jpos-2)),slo,slo,h,t3)
          else
            slo1= slo
            if((jpos+1).le.n) slo1 = savg(m,n,slwns,jm(j)-1,jpos)
            call roots(ns,ncode,i,ttime(jm(j)-1 + m*(jpos-2)),ttime(jm(j)-1 + m*(jpos-1)),ttime(jm(j) + m*(jpos-2)),slo,slo1,slo,h,t3,index)
            if(index.eq.1) id =  1
            if(index.eq.2) id = -1
          endif
          ttime(jm(j) + m*(jpos-1)) = t3
          goto 35
         endif
c
         if(jm(j).eq.1) then
          slo = savg(m,n,slwns,jm(j),jpos-1)
          if(ttime(jm(j)+1 + m*(jpos-1)).eq.0.0) then
            call fd1(ttime(jm(j) + m*(jpos-2)),ttime(jm(j)+1 + m*(jpos-2)),ttime(jm(j)+1 + m*(jpos-2)),slo,slo,h,t3)
          else
            slo1 = slo
            if((jpos+1).le.n) slo1 = savg(m,n,slwns,jm(j),jpos)
            call roots(ns,ncode,i,ttime(jm(j)+1 + m*(jpos-2)),ttime(jm(j)+1 + m*(jpos-1)),ttime(jm(j) + m*(jpos-2)),slo,slo1,slo,h,t3,index)
            if(index.eq.1) id = -1
            if(index.eq.2) id =  1
          endif
          ttime(jm(j) + m*(jpos-1)) = t3
          goto 35
         endif
c
         if(ttime(jm(j)+1 + m*(jpos-1)).eq.0.0.and.ttime(jm(j)-1 + m*(jpos-1)).eq.0.0)then
          slo1 = savg(m,n,slwns,jm(j)-1,jpos-1)
          slo2 = savg(m,n,slwns,jm(j)  ,jpos-1)
          call fd1(ttime(jm(j) + m*(jpos-2)),ttime(jm(j)-1 + m*(jpos-2)),ttime(jm(j)+1 + m*(jpos-2)),slo1,slo2,h,t3)
          ttime(jm(j) + m*(jpos-1)) = t3
          goto 30
         endif
c
         t3 = 1e+10
         if(ttime(jm(j)+1 + m*(jpos-1)).gt.0.0)then
          slo = savg(m,n,slwns,jm(j),jpos-1)
          slo1 = slo
          if((jpos+1).le.n) slo1 = savg(m,n,slwns,jm(j),jpos)
          slo2 = savg(m,n,slwns,jm(j)-1,jpos-1)
          call roots(ns,ncode,i,ttime(jm(j)+1 + m*(jpos-2)),ttime(jm(j)+1 + m*(jpos-1)),ttime(jm(j) + m*(jpos-2)),slo,slo1,slo2,h,tsem,inde)
          if(tsem.lt.t3) then
            t3 = tsem
            index = inde
            if(index.eq.1) id= -1
            if(index.eq.2) id=  1
          endif
         endif
         if(ttime(jm(j)-1 + m*(jpos-1)).gt.0.0)then
          slo = savg(m,n,slwns,jm(j)-1,jpos-1)
          slo1 = slo
          if((jpos+1).le.n) slo1 = savg(m,n,slwns,jm(j)-1,jpos)
          slo2 = savg(m,n,slwns,jm(j),jpos-1)
          call roots(ns,ncode,i,ttime(jm(j)-1 + m*(jpos-2)),ttime(jm(j)-1 + m*(jpos-1)),ttime(jm(j) + m*(jpos-2)),slo,slo1,slo2,h,tsem,inde)
          if(tsem.lt.t3) then
            t3 = tsem
            index = inde
            if(index.eq.1) id =  1
            if(index.eq.2) id = -1
          endif
         endif
         ttime(jm(j) + m*(jpos-1)) = t3
35         if(index.eq.2) then
           if(id.eq. 1) nb=jb
           if(id.eq.-1) nb=ju
           do k=jm(j)+id,nb,id
             slo = 0.25*(slwns(k + m*(jpos-1))+slwns(k-id + m*(jpos-1))+slwns(k + m*(jpos-2))+slwns(k-id + m*(jpos-2)))
             call fd2(inde,ttime(k-id + m*(jpos-2)),ttime(k + m*(jpos-2)),ttime(k-id + m*(jpos-1)),slo,slo,slo,h,t3)
             if(t3.lt.ttime(k + m*(jpos-1))) then
               ttime(k + m*(jpos-1)) = t3
             else
               index = 0
               goto 30
             endif
           enddo
         endif
         if(index.eq.1) then
           do k=jpos-1,1,-1
             slo = 0.25*(slwns(jm(j) + m*(k-1))+slwns(jm(j)-id + m*(k-1))+ slwns(jm(j) + m*(k))+slwns(jm(j)-id + m*(k)))
             call fd2(inde,ttime(jm(j)-id + m*(k)),ttime(jm(j) + m*(k)),ttime(jm(j)-id + m*(k-1)),slo,slo,slo,h,t3)
             if(t3.lt.ttime(jm(j) + m*(k-1))) then
               ttime(jm(j) + m*(k-1))=t3
             else
               index = 0
               goto 30
             endif
           enddo
         endif
c
   30    continue

c      print *,'right done'

C
C                 A B O V E    P A R T
C
    2   IPOS = IS-I
        IF(IPOS.LT.1) GO TO 3

c      print *,'starting top'

        JR = JS+I
        IF(JR.GT.N) JR = N
        JL = JS-I+1
        IF(JL.LT.1) JL = 1
        DO 41 J=JL,JR
          TI(J) = ttime(IPOS+1 + m*(J-1))
          JM(J) = J
   41   CONTINUE
        call sort(jl,jr,ti,jm)
        do 40 j=jl,jr
c
         index = 0
         if(jm(j).eq.n) then
          slo = savg(m,n,slwns,ipos,jm(j)-1)
          if(ttime(ipos + m*(jm(j)-2)).eq.0.0) then
            call fd1(ttime(ipos+1 + m*(jm(j)-1)),ttime(ipos+1 + m*(jm(j)-2)),ttime(ipos+1 + m*(jm(j)-2)),slo,slo,h,t3)
          else
            slo2 = slo
            if((ipos-1).ge.1) slo2 = savg(m,n,slwns,ipos-1,jm(j)-1)
            call roots(ns,ncode,i,ttime(ipos+1 + m*(jm(j)-2)),ttime(ipos+1 + m*(jm(j)-1)),ttime(ipos + m*(jm(j)-2)),slo,slo,slo2,h,t3,index)
            if(index.eq.1) id = -1
            if(index.eq.2) id =  1
          endif
          ttime(ipos + m*(jm(j)-1)) = t3
          goto 43
         endif
c
         if(jm(j).eq.1) then
          slo = savg(m,n,slwns,ipos,jm(j))
          if(ttime(ipos + m*(jm(j))).eq.0.0) then
            call fd1(ttime(ipos+1 + m*(jm(j)-1)),ttime(ipos+1 + m*(jm(j))),ttime(ipos+1 + m*(jm(j))),slo,slo,h,t3)
          else
            slo2 = slo
            if((ipos-1).ge.1) slo2 = savg(m,n,slwns,ipos-1,jm(j))
            call roots(ns,ncode,i,ttime(ipos+1 + m*(jm(j))),ttime(ipos+1 + m*(jm(j)-1)),ttime(ipos + m*(jm(j))),slo,slo,slo2,h,t3,index)
            if(index.eq.1) id =  1
            if(index.eq.2) id = -1
          endif
          ttime(ipos + m*(jm(j)-1)) = t3
          goto 43
         endif
c
         if(ttime(ipos + m*(jm(j))).eq.0.0.and.ttime(ipos + m*(jm(j)-2)).eq.0.0)then
          slo1 = savg(m,n,slwns,ipos,jm(j)-1)
          slo2 = savg(m,n,slwns,ipos,jm(j))
          call fd1(ttime(ipos+1 + m*(jm(j)-1)),ttime(ipos+1 + m*(jm(j)-2)),ttime(ipos+1 + m*(jm(j))),slo1,slo2,h,t3)
          ttime(ipos + m*(jm(j)-1)) = t3
          goto 40
         endif
c
         t3 = 1e+10
         if(ttime(ipos + m*(jm(j))).gt.0.0)then
          slo  = savg(m,n,slwns,ipos,jm(j))
          slo1 = savg(m,n,slwns,ipos,jm(j)-1)
          slo2 = slo
          if((ipos-1).ge.1) slo2 = savg(m,n,slwns,ipos-1,jm(j))
          call roots(ns,ncode,i,ttime(ipos+1 + m*(jm(j))),ttime(ipos+1 + m*(jm(j)-1)),ttime(ipos + m*(jm(j))),slo,slo1,slo2,h,tsem,inde)
          if(tsem.lt.t3) then
            t3 = tsem
            index = inde
            if(index.eq.1) id =  1
            if(index.eq.2) id = -1
          endif
         endif
         if(ttime(ipos + m*(jm(j)-2)).gt.0.0)then
          slo  = savg(m,n,slwns,ipos,jm(j)-1)
          slo1 = savg(m,n,slwns,ipos,jm(j))
          slo2 = slo
          if((ipos-1).ge.1) slo2 = savg(m,n,slwns,ipos-1,jm(j)-1)
          call roots(ns,ncode,i,ttime(ipos+1 + m*(jm(j)-2)),ttime(ipos+1 + m*(jm(j)-1)),ttime(ipos + m*(jm(j)-2)),slo,slo1,slo2,h,tsem,inde)
          if(tsem.lt.t3) then
            t3=tsem
            index = inde
            if(index.eq.1) id = -1
            if(index.eq.2) id =  1
          endif
         endif
         ttime(ipos + m*(jm(j)-1)) = t3
   43    if(index.eq.1) then
           if(id.eq. 1) nb=jr
           if(id.eq.-1) nb=jl
           do k=jm(j)+id,nb,id
             slo = 0.25*(slwns(ipos   + m*(k-1))+slwns(ipos   + m*(k-id-1))+slwns(ipos+1 + m*(k-1))+slwns(ipos+1 + m*(k-id-1)))
             call fd2(inde,ttime(ipos+1 + m*(k-id-1)),ttime(ipos+1 + m*(k-1)),ttime(ipos + m*(k-id-1)),slo,slo,slo,h,t3)
             if(t3.lt.ttime(ipos + m*(k-1))) then
               ttime(ipos + m*(k-1)) = t3
             else
               goto 40
             endif
           enddo
         endif
         if(index.eq.2) then
           do k=ipos+1,m
             slo = 0.25*(slwns(k   + m*(jm(j)-1))+slwns(k   + m*(jm(j)-id-1))+slwns(k-1 + m*(jm(j)-1))+slwns(k-1 + m*(jm(j)-id-1)))
             call fd2(inde,ttime(k-1 + m*(jm(j)-id-1)),ttime(k-1 + m*(jm(j)-1)),ttime(k + m*(jm(j)-id-1)),slo,slo,slo,h,t3)
             if(t3.lt.ttime(k + m*(jm(j)-1))) then
               ttime(k + m*(jm(j)-1))=t3
             else
               goto 40
             endif
           enddo
         endif
c
   40   continue

c      print *,'top done'

C
C                   L E F T   P A R T
C
   3    JPOS = JS-I
        IF(JPOS.LT.1) GO TO 4

c      print *,'starting left'

        JB = IS+I-1
        IF(JB.GT.M) JB = M
        JU = IS-I
        IF(JU.LT.1) JU = 1
        DO J=JU,JB
          TI(J) = ttime(J + m*(JPOS))
          JM(J) = J
        enddo
        call sort(ju,jb,ti,jm)
        do 50 j=ju,jb
c
         index =0
         if(jm(j).eq.m) then
          slo = savg(m,n,slwns,jm(j)-1,jpos)
          if(ttime(jm(j)-1 + m*(jpos-1)).eq.0.0) then
            call fd1(ttime(jm(j) + m*(jpos)),ttime(jm(j)-1 + m*(jpos)),ttime(jm(j)-1 + m*(jpos)),slo,slo,h,t3)
          else
            slo1= slo
            if((jpos-1).ge.1) slo1 = savg(m,n,slwns,jm(j)-1,jpos-1)
            call roots(ns,ncode,i,ttime(jm(j)-1 + m*(jpos)),ttime(jm(j)-1 + m*(jpos-1)),ttime(jm(j) + m*(jpos)),slo,slo1,slo,h,t3,index)
            if(index.eq.1) id =  1
            if(index.eq.2) id = -1
          endif
          ttime(jm(j) + m*(jpos-1)) = t3
          goto 55
         endif
c
         if(jm(j).eq.1) then
          slo = savg(m,n,slwns,jm(j),jpos)
          if(ttime(jm(j)+1 + m*(jpos-1)).eq.0.0) then
            call fd1(ttime(jm(j) + m*(jpos)),ttime(jm(j)+1 + m*(jpos)),ttime(jm(j)+1 + m*(jpos)),slo,slo,h,t3)
          else
            slo1 = slo
            if((jpos-1).ge.1) slo1 = savg(m,n,slwns,jm(j),jpos-1)
            call roots(ns,ncode,i,ttime(jm(j)+1 + m*(jpos)),ttime(jm(j)+1 + m*(jpos-1)),ttime(jm(j) + m*(jpos)),slo,slo1,slo,h,t3,index)
            if(index.eq.1) id = -1
            if(index.eq.2) id =  1
          endif
          ttime(jm(j) + m*(jpos-1)) = t3
          goto 55
         endif
c
         if(ttime(jm(j)+1 + m*(jpos-1)).eq.0.0.and.ttime(jm(j)-1 + m*(jpos-1)).eq.0.0)then
          slo1 = savg(m,n,slwns,jm(j)-1,jpos)
          slo2 = savg(m,n,slwns,jm(j),jpos)
          call fd1(ttime(jm(j) + m*(jpos)),ttime(jm(j)-1 + m*(jpos)),ttime(jm(j)+1 + m*(jpos)),slo1,slo2,h,t3)
          ttime(jm(j) + m*(jpos-1)) = t3
          goto 50
         endif
c
         t3 = 1e+10
         if(ttime(jm(j)+1 + m*(jpos-1)).gt.0.0)then
          slo  = savg(m,n,slwns,jm(j),jpos)
          slo1 = slo
          if((jpos-1).ge.1) slo1 = savg(m,n,slwns,jm(j),jpos-1)
          slo2 = savg(m,n,slwns,jm(j)-1,jpos)
          call roots(ns,ncode,i,ttime(jm(j)+1 + m*(jpos)),ttime(jm(j)+1 + m*(jpos-1)),ttime(jm(j) + m*(jpos)),slo,slo1,slo2,h,tsem,inde)
          if(tsem.lt.t3) then
            t3 = tsem
            index = inde
            if(index.eq.1) id = -1
            if(index.eq.2) id =  1
          endif
         endif
         if(ttime(jm(j)-1 + m*(jpos-1)).gt.0.0) then
          slo  = savg(m,n,slwns,jm(j)-1,jpos)
          slo1 = slo
          if((jpos-1).ge.1) slo1 = savg(m,n,slwns,jm(j)-1,jpos-1)
          slo2 = savg(m,n,slwns,jm(j),jpos)
          call roots(ns,ncode,i,ttime(jm(j)-1 + m*(jpos)),ttime(jm(j)-1 + m*(jpos-1)),ttime(jm(j) + m*(jpos)),slo,slo1,slo2,h,tsem,inde)
          if(tsem.lt.t3) then
            t3 = tsem
            index = inde
            if(index.eq.1) id =  1
            if(index.eq.2) id = -1
          endif
         endif
         ttime(jm(j) + m*(jpos-1)) = t3
   55    if(index.eq.2) then
           if(id.eq. 1) nb=jb
           if(id.eq.-1) nb=ju
           do k=jm(j)+id,nb,id
             slo = 0.25*(slwns(k + m*(jpos-1))+slwns(k-id + m*(jpos-1))+slwns(k + m*(jpos))+slwns(k-id + m*(jpos)))
             call fd2(inde,ttime(k-id + m*(jpos)),ttime(k + m*(jpos)),ttime(k-id + m*(jpos-1)),slo,slo,slo,h,t3)
             if(t3.lt.ttime(k + m*(jpos-1))) then
               ttime(k + m*(jpos-1)) = t3
             else
               index = 0
               goto 50
             endif
           enddo
         endif
         if(index.eq.1) then
           do k=jpos+1,n
             slo = 0.25*(slwns(jm(j) + m*(k-1))+slwns(jm(j)-id + m*(k-1))+slwns(jm(j) + m*(k-2))+slwns(jm(j)-id + m*(k-2)))
             call fd2(inde,ttime(jm(j)-id + m*(k-2)),ttime(jm(j) + m*(k-2)),ttime(jm(j)-id + m*(k-1)),slo,slo,slo,h,t3)
             if(t3.lt.ttime(jm(j) + m*(k-1))) then
               ttime(jm(j) + m*(k-1))=t3
             else
               index = 0
               goto 50
             endif
           enddo
         endif
c
   50   continue

c      print *,'left done'

C
C                 B E L O W   P A R T
C
   4    IPOS = IS+I
        IF(IPOS.GT.M) GO TO 90
        JL = JS-I
        IF(JL.LT.1) JL = 1
        JR = JS+I
        IF(JR.GT.N) JR = N

c      print *,'starting bottom, IPOS= ',IPOS,'JL= ',JL,'JR= ',JR

        DO 61 J=JL,JR
          TI(J) = ttime(IPOS-1 + m*(J-1))
          JM(J) = J
   61   CONTINUE
        call sort(jl,jr,ti,jm)
        do 60 j=jl,jr
         index = 0
         if(jm(j).eq.n) then
          slo = savg(m,n,slwns,ipos-1,jm(j)-1)
            if(ttime(ipos + m*(jm(j)-2)).eq.0.0) then
            call fd1(ttime(ipos-1 + m*(jm(j)-1)),ttime(ipos-1 + m*(jm(j)-2)),ttime(ipos-1 + m*(jm(j)-2)),slo,slo,h,t3)
          else
            slo2 = slo
            if((ipos+1).le.m) slo2 = savg(m,n,slwns,ipos,jm(j)-1)
            call roots(ns,ncode,i,ttime(ipos-1 + m*(jm(j)-2)),ttime(ipos-1 + m*(jm(j)-1)),ttime(ipos + m*(jm(j)-2)),slo,slo,slo2,h,t3,index)
            if(index.eq.1) id = -1
            if(index.eq.2) id =  1
          endif
          ttime(ipos + m*(jm(j)-1)) = t3
          goto 63
         endif
c
         if(jm(j).eq.1) then
          slo = savg(m,n,slwns,ipos-1,jm(j))
          if(ttime(ipos + m*(jm(j))).eq.0.0) then
            call fd1(ttime(ipos-1 + m*(jm(j)-1)),ttime(ipos-1 + m*(jm(j))),ttime(ipos-1 + m*(jm(j))),slo,slo,h,t3)
          else
            slo2 = slo
            if((ipos+1).le.m) slo2 = savg(m,n,slwns,ipos,jm(j))
            call roots(ns,ncode,i,ttime(ipos-1 + m*(jm(j))),ttime(ipos-1 + m*(jm(j)-1)),ttime(ipos + m*(jm(j))),slo,slo,slo2,h,t3,index)
            if(index.eq.1) id =  1
            if(index.eq.2) id = -1
          endif
          ttime(ipos + m*(jm(j)-1)) = t3
          goto 63
         endif
c
         if(ttime(ipos + m*(jm(j))).eq.0.0.and.ttime(ipos + m*(jm(j)-2)).eq.0.0)then
          slo1 = savg(m,n,slwns,ipos-1,jm(j)-1)
          slo2 = savg(m,n,slwns,ipos-1,jm(j))
          call fd1(ttime(ipos-1 + m*(jm(j)-1)),ttime(ipos-1 + m*(jm(j)-2)),ttime(ipos-1 + m*(jm(j))),slo1,slo2,h,t3)
          ttime(ipos + m*(jm(j)-1)) = t3
          goto 60
         endif
c
         t3 = 1e+10
         if(ttime(ipos + m*(jm(j))).gt.0.0)then
          slo  = savg(m,n,slwns,ipos-1,jm(j))
          slo1 = savg(m,n,slwns,ipos-1,jm(j)-1)
          slo2 = slo
          if((ipos+1).le.m) slo2 = savg(m,n,slwns,ipos,jm(j))
          call roots(ns,ncode,i,ttime(ipos-1 + m*(jm(j))),ttime(ipos-1 + m*(jm(j)-1)),ttime(ipos + m*(jm(j))),slo,slo1,slo2,h,tsem,inde)
          if(tsem.lt.t3) then
            t3 = tsem
            index = inde
            if(index.eq.1) id =  1
            if(index.eq.2) id = -1
          endif
         endif
c
         if(ttime(ipos + m*(jm(j)-2)).gt.0.0)then
          slo  = savg(m,n,slwns,ipos-1,jm(j)-1)
          slo1 = savg(m,n,slwns,ipos-1,jm(j))
          slo2 = slo
          if((ipos+1).le.m) slo2 = savg(m,n,slwns,ipos,jm(j)-1)
          call roots(ns,ncode,i,ttime(ipos-1 + m*(jm(j)-2)),ttime(ipos-1 + m*(jm(j)-1)),ttime(ipos + m*(jm(j)-2)),slo,slo1,slo2,h,tsem,inde)

          if(tsem.lt.t3) then
            t3 = tsem
            index = inde
            if(index.eq.1) id = -1
            if(index.eq.2) id =  1
          endif
         endif
         ttime(ipos + m*(jm(j)-1)) = t3
c         goto 60
   63    if(index.eq.1) then
           if(id.eq. 1) nb=jr
           if(id.eq.-1) nb=jl
           do k=jm(j)+id,nb,id
             slo = 0.25*(slwns(ipos   + m*(k-1))+slwns(ipos   + m*(k-id-1))+slwns(ipos-1 + m*(k-1))+slwns(ipos-1 + m*(k-id-1)))
             call fd2(inde,ttime(ipos-1 + m*(k-id-1)),ttime(ipos-1 + m*(k-1)),ttime(ipos + m*(k-id-1)),slo,slo,slo,h,t3)
             if(t3.lt.ttime(ipos + m*(k-1))) then
               ttime(ipos + m*(k-1)) = t3
             else
               index = 0
               goto 60
             endif
           enddo
         endif
         if(index.eq.2) then
           do k=ipos-1,1,-1
             slo = 0.25*(slwns(k   + m*(jm(j)-1))+slwns(k   + m*(jm(j)-id-1))+slwns(k+1 + m*(jm(j)-1))+slwns(k+1 + m*(jm(j)-id-1)))
             call fd2(inde,ttime(k+1 + m*(jm(j)-id-1)),ttime(k+1 + m*(jm(j)-1)),ttime(k + m*(jm(j)-id-1)),slo,slo,slo,h,t3)
             if(t3.lt.ttime(k + m*(jm(j)-1))) then
               ttime(k + m*(jm(j)-1))=t3
             else
               index = 0
               goto 60
             endif
           enddo
         endif
c
   60  continue

c      print *,'bottom done'

C
   90 CONTINUE
      return
      end
c
      function savg(m,n,slwns,i,j)
      implicit real*8 (a-h,o-z)
      dimension slwns(1000)
      savg = 0.25*(slwns(i+m*(j-1))+slwns(i+1+m*(j-1))+slwns(i+m*(j))+slwns(i+1+m*(j)))
      return
      end
c
      SUBROUTINE SORT(MIN,MAX,TI,JM)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION TI(400), JM(400)
C
      do 10 i=min,max-1
      do j = i+1,max
       if(ti(j).lt.ti(i)) then
        se    = ti(i)
        ti(i) = ti(j)
        ti(j) = se
        ise   = jm(i)
        jm(i) = jm(j)
        jm(j) = ise
       endif
      enddo
   10 continue
      return
      end
c
      SUBROUTINE ROOTS(ns,ncode,ii,T0,T1,T2,SLO,slo1,slo2,H,T3,index)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMPLEX Z1,Z2
C
      if(ii.gt.ns) then
        call fd2(index,t0,t1,t2,slo,slo1,slo2,h,t3)
        return
      endif
      BC1 = 2.0*(T0/slo**2.0 - T1/slo**2.0)
      BC2 = 2.0*(T0/slo**2.0 - T2/slo**2.0)
      CC1 = (T1/slo)**2.0 - (T0/slo)**2.0 - H**2.0
      CC2 = (T2/slo)**2.0 - (T0/slo)**2.0 - H**2.0
      C = BC1*BC1+BC2*BC2-(2.0*H/slo)**2
      D = 2.0*(BC1*CC1+BC2*CC2)+8.0*T0*(H/slo)**2
      E = CC1*CC1+CC2*CC2 - (2.0*H*T0/slo)**2
      if(abs(c).lt.1e-05) then
        call fd2(index,t0,t1,t2,slo,slo1,slo2,h,t3)
        return
      endif
      CALL QUADRATIC(E,D,C,Z1,Z2)
      ts1 = real(z1)
      if(abs(ts1).lt.1e-04) ts1=0.0
      ts2 = real(z2)
      if(abs(ts2).lt.1e-04) ts2=0.0
      if(abs(aimag(z1)).gt.1e-4.or.abs(aimag(z2)).gt.1e-4)then
c        write(*,*)'complex roots'
        call fd2(index,t0,t1,t2,slo,slo1,slo2,h,t3)
        return
      endif
      if(abs(ts2).lt.abs(ts1)) then
        ts  = ts1
        ts1 = ts2
        ts2 = ts
      endif
      T3 = (T2-TS1)*(T2-TS1)/(slo**2)+(T1-TS1)*(T1-TS1)/(slo**2)
      T3 = TS1+slo*sqrt(T3 -(T0-TS1)*(T0-TS1)/(Slo**2))
      xs =(t1-ts1)*(t1-ts1)/(slo**2)-(t0-ts1)*(t0-ts1)/(slo**2)
      xs = (xs-h*h)/(2.0*h)
      if(abs(xs).lt.1e-05) xs = 0.0
      zs =(t2-ts1)*(t2-ts1)/(slo**2)-(t0-ts1)*(t0-ts1)/(slo**2)
      zs = (zs-h*h)/(2.0*h)
      if(abs(zs).lt.1e-05) zs = 0.0
      if(xs.lt.0.0.or.zs.lt.0.0.or.ts1.lt.0.0) then
        call fd2(index,t0,t1,t2,slo,slo1,slo2,h,t3)
c        ncode = 1
      end if
      RETURN
      END
C
C THE ROOTS OF 2TH ORDER POLYNOMIAL
C
      SUBROUTINE QUADRATIC(C,B,A,Z1,Z2)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMPLEX Z1,Z2,D1
c
      D2  = B*B-4.0*A*C
      IF(dABS(D2).LT.1E-05) D2 = 0.0
      IF(D2.LT.0.0) D1 = CMPLX(0.0,(-D2)**0.5)
      IF(D2.GE.0.0) D1 = CMPLX(D2**0.5,0.0)
      Z1 = (-B+D1)/(2.0*A)
      Z2 = (-B-D1)/(2.0*A)
      RETURN
      END
c
c  FINITE DIFFERENCE EQUATION FOR CALCULATING TRAVELTIME
c  AFTER RELATIVE MINIMUM POINT (EQ. 6 )
c
      subroutine fd1(t0,t1,t2,slo1,slo2,h,t3)
      IMPLICIT REAL*8 (A-H,O-Z)
      slo = 0.5*(slo1+slo2)
      t3 = h*h*slo*slo-0.25*(t2-t1)*(t2-t1)
      if(t3.lt.0.0) then
c        write(*,*) 'fd1',t3
        t3 = 1e+10
      else
      t3 = t0 + sqrt(t3)
      endif
c      t3 = 1e+10
      delt = t0-t1
      if(delt.ge.0.0.and.delt.le.(h*slo1/sqrt(2.))) then
        tsem = h*h*slo1*slo1-delt*delt
c        if(tsem.lt.0.0) write(*,*)tsem
        tsem=t0+sqrt(tsem)
        if(tsem.lt.t3) t3 = tsem
      endif
      delt = t0-t2
      if(delt.ge.0.0.and.delt.le.(h*slo2/sqrt(2.))) then
        tsem = h*h*slo2*slo2-delt*delt
c        if(tsem.lt.0.0) write(*,*)tsem
        tsem=t0+sqrt(tsem)
        if(tsem.lt.t3) t3 = tsem
      endif
      delt = t3-t0
      if(delt.gt.h*slo1) then
        tsem = t0+h*slo1
        if(tsem.lt.t3) then
          t3 = tsem
c          write(*,*)'halo11'
        endif
      endif
      if(delt.gt.h*slo2) then
        tsem = t0+h*slo2
        if(tsem.lt.t3) then
          t3 = tsem
c          write(*,*)'halo12'
        endif
      endif
      return
      end
c
c  FINITE DIFFERENCE EQUATION FOR CALCULATING TRAVELTIME
c  IF THERE ARE 3 CALCULATED POINTS
c
      subroutine fd2(index,t0,t1,t2,slo,slo1,slo2,h,t3)
      IMPLICIT REAL*8 (A-H,O-Z)
      index = 0
      eps = 1e-5
      t3 = 1e+10
      t3 = 2.0*h*h*slo*slo-(t2-t1)*(t2-t1)
c      write(*,*)h,slo,t0,t1,t2,t3
c      if(abs(t3).lt.1e-10) t3 = 0.0
      if(t2.lt.t0.or.t1.lt.t0) t3=1e+10
      if(t3.lt.0.0) then
c        write(*,*) 'fd2',t3
        t3 = 1e+10
      else
      t3 = t0 + sqrt(t3)
      index=4
      endif
c PODVIN & LECOMTE'S STENSIL
c      ts = t0 + h*slo*sqrt(2.0)
c      if(ts.lt.t3) t3 = ts
      delt = (t1-t0)
      if(delt.ge.0.0.and.delt.le.(h*slo/sqrt(2.))) then
        ts = h*h*slo*slo-delt*delt
c        if(abs(ts).lt.1e-10) ts=0.0
        if(ts.lt.0.0) ts=1e+10
        ts=t1+sqrt(ts)
        if(ts.lt.t3) then
          t3 = ts
        endif
      endif
      delt = (t2-t0)
      if(delt.ge.0.0.and.delt.le.(h*slo/sqrt(2.))) then
        ts = h*h*slo*slo-delt*delt
c        if(abs(ts).lt.1e-10) ts=0.0
        if(ts.lt.0.0) ts=1e+10
        ts=t2+sqrt(ts)
        if(ts.lt.t3) then
          t3 = ts
        endif
      endif
      delt = t3-t1
      if(delt.gt.h*slo1) then
        ts = t1+h*slo1
        if(ts.lt.t3) then
          index = 1
          t3 = ts
        endif
      endif
      if(delt.gt.h*slo) then
        ts = t1+h*slo
        if(ts.lt.t3) then
          index = 0
c          write(*,*)'1th'
          t3 = ts
        endif
      endif
      delt = t3-t2
      if(delt.gt.h*slo2) then
        ts = t2+h*slo2
        if(ts.lt.t3) then
          index = 2
          t3 = ts
        endif
      endif
      if(delt.gt.h*slo) then
        ts = t2+h*slo
        if(ts.lt.t3) then
          index = 0
c          write(*,*)'2th'
          t3 = ts
        endif
      endif
      ts = t0 + sqrt(2.)*h*slo
      if(ts.lt.t3) then
        t3 = ts
        index = 0
      endif
      ts = t0 + sqrt(2.)*h*slo1
      if(ts.lt.t3) then
        t3 = ts
        index = 3
c        write(*,*)index,slo1
      endif
      ts = t0 + sqrt(2.)*h*slo2
      if(ts.lt.t3) then
        t3 = ts
        index = 3
      endif
c      write(*,*)t3
      return
      end
c


! test case for invalid json being generated.

MODULE accelerate_kernel_loop82_mod
CONTAINS
SUBROUTINE accelerate_kernel_loop82(j,k,density0,dt,nodal_mass,stepbymass,volume,x_max,x_min,y_max,y_min)
INTEGER :: j
INTEGER :: k
REAL(kind=8) :: dt
REAL(kind=8) :: nodal_mass
INTEGER :: x_max
INTEGER :: x_min
INTEGER :: y_max
INTEGER :: y_min
REAL(kind=8), DIMENSION((x_min - 2):(x_max + 2),(y_min - 2):(y_max + 2)) :: density0
REAL(kind=8), DIMENSION((x_min - 2):(x_max + 3),(y_min - 2):(y_max + 3)) :: stepbymass
REAL(kind=8), DIMENSION((x_min - 2):(x_max + 2),(y_min - 2):(y_max + 2)) :: volume
DO k = y_min, y_max + 1
DO j = x_min, x_max + 1
nodal_mass = (density0(j - 1,k - 1) * volume(j - 1,k - 1) + density0(j,k - 1) * volume(j,k - 1) + density0(j,k) * volume(j,k) + density0(j - 1,k) * volume(j - 1,k)) * 0.25_8
stepbymass(j,k) = 0.5_8 * dt / nodal_mass
END DO
END DO
END SUBROUTINE

END MODULE accelerate_kernel_loop82_mod


*DECK BANDR
      SUBROUTINE BANDR (NM, N, MB, A, D, E, E2, MATZ, Z)
C***BEGIN PROLOGUE  BANDR
C***PURPOSE  Reduce a real symmetric band matrix to symmetric
C            tridiagonal matrix and, optionally, accumulate
C            orthogonal similarity transformations.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C1B1
C***TYPE      SINGLE PRECISION (BANDR-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure BANDRD,
C     NUM. MATH. 12, 231-241(1968) by Schwarz.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 273-283(1971).
C
C     This subroutine reduces a REAL SYMMETRIC BAND matrix
C     to a symmetric tridiagonal matrix using and optionally
C     accumulating orthogonal similarity transformations.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        MB is the (half) band width of the matrix, defined as the
C          number of adjacent diagonals, including the principal
C          diagonal, required to specify the non-zero portion of the
C          lower triangle of the matrix.  MB is less than or equal
C          to N.  MB is an INTEGER variable.
C
C        A contains the lower triangle of the real symmetric band
C          matrix.  Its lowest subdiagonal is stored in the last
C          N+1-MB  positions of the first column, its next subdiagonal
C          in the last  N+2-MB  positions of the second column, further
C          subdiagonals similarly, and finally its principal diagonal
C          in the  N  positions of the last column.  Contents of storage
C          locations not part of the matrix are arbitrary.  A is a
C          two-dimensional REAL array, dimensioned A(NM,MB).
C
C        MATZ should be set to .TRUE. if the transformation matrix is
C          to be accumulated, and to .FALSE. otherwise.  MATZ is a
C          LOGICAL variable.
C
C     On OUTPUT
C
C        A has been destroyed, except for its last two columns which
C          contain a copy of the tridiagonal matrix.
C
C        D contains the diagonal elements of the tridiagonal matrix.
C          D is a one-dimensional REAL array, dimensioned D(N).
C
C        E contains the subdiagonal elements of the tridiagonal
C          matrix in its last N-1 positions.  E(1) is set to zero.
C          E is a one-dimensional REAL array, dimensioned E(N).
C
C        E2 contains the squares of the corresponding elements of E.
C          E2 may coincide with E if the squares are not needed.
C          E2 is a one-dimensional REAL array, dimensioned E2(N).
C
C        Z contains the orthogonal transformation matrix produced in
C          the reduction if MATZ has been set to .TRUE.  Otherwise, Z
C          is not referenced.  Z is a two-dimensional REAL array,
C          dimensioned Z(NM,N).
C
C     Questions and comments should be directed to B. S. Garbow,
C     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BANDR
C
      INTEGER J,K,L,N,R,I1,I2,J1,J2,KR,MB,MR,M1,NM,N2,R1,UGL,MAXL,MAXR
      REAL A(NM,*),D(*),E(*),E2(*),Z(NM,*)
      REAL G,U,B1,B2,C2,F1,F2,S2,DMIN,DMINRT
      LOGICAL MATZ
C
C***FIRST EXECUTABLE STATEMENT  BANDR
      DMIN = 2.0E0**(-64)
      DMINRT = 2.0E0**(-32)
C     .......... INITIALIZE DIAGONAL SCALING MATRIX ..........
      DO 30 J = 1, N
   30 D(J) = 1.0E0
C
      IF (.NOT. MATZ) GO TO 60
C
      DO 50 J = 1, N
C
         DO 40 K = 1, N
   40    Z(J,K) = 0.0E0
C
         Z(J,J) = 1.0E0
   50 CONTINUE
C
   60 M1 = MB - 1
      IF (M1 - 1) 900, 800, 70
   70 N2 = N - 2
C
      DO 700 K = 1, N2
         MAXR = MIN(M1,N-K)
C     .......... FOR R=MAXR STEP -1 UNTIL 2 DO -- ..........
         DO 600 R1 = 2, MAXR
            R = MAXR + 2 - R1
            KR = K + R
            MR = MB - R
            G = A(KR,MR)
            A(KR-1,1) = A(KR-1,MR+1)
            UGL = K
C
            DO 500 J = KR, N, M1
               J1 = J - 1
               J2 = J1 - 1
               IF (G .EQ. 0.0E0) GO TO 600
               B1 = A(J1,1) / G
               B2 = B1 * D(J1) / D(J)
               S2 = 1.0E0 / (1.0E0 + B1 * B2)
               IF (S2 .GE. 0.5E0 ) GO TO 450
               B1 = G / A(J1,1)
               B2 = B1 * D(J) / D(J1)
               C2 = 1.0E0 - S2
               D(J1) = C2 * D(J1)
               D(J) = C2 * D(J)
               F1 = 2.0E0 * A(J,M1)
               F2 = B1 * A(J1,MB)
               A(J,M1) = -B2 * (B1 * A(J,M1) - A(J,MB)) - F2 + A(J,M1)
               A(J1,MB) = B2 * (B2 * A(J,MB) + F1) + A(J1,MB)
               A(J,MB) = B1 * (F2 - F1) + A(J,MB)
C
               DO 200 L = UGL, J2
                  I2 = MB - J + L
                  U = A(J1,I2+1) + B2 * A(J,I2)
                  A(J,I2) = -B1 * A(J1,I2+1) + A(J,I2)
                  A(J1,I2+1) = U
  200          CONTINUE
C
               UGL = J
               A(J1,1) = A(J1,1) + B2 * G
               IF (J .EQ. N) GO TO 350
               MAXL = MIN(M1,N-J1)
C
               DO 300 L = 2, MAXL
                  I1 = J1 + L
                  I2 = MB - L
                  U = A(I1,I2) + B2 * A(I1,I2+1)
                  A(I1,I2+1) = -B1 * A(I1,I2) + A(I1,I2+1)
                  A(I1,I2) = U
  300          CONTINUE
C
               I1 = J + M1
               IF (I1 .GT. N) GO TO 350
               G = B2 * A(I1,1)
  350          IF (.NOT. MATZ) GO TO 500
C
               DO 400 L = 1, N
                  U = Z(L,J1) + B2 * Z(L,J)
                  Z(L,J) = -B1 * Z(L,J1) + Z(L,J)
                  Z(L,J1) = U
  400          CONTINUE
C
               GO TO 500
C
  450          U = D(J1)
               D(J1) = S2 * D(J)
               D(J) = S2 * U
               F1 = 2.0E0 * A(J,M1)
               F2 = B1 * A(J,MB)
               U = B1 * (F2 - F1) + A(J1,MB)
               A(J,M1) = B2 * (B1 * A(J,M1) - A(J1,MB)) + F2 - A(J,M1)
               A(J1,MB) = B2 * (B2 * A(J1,MB) + F1) + A(J,MB)
               A(J,MB) = U
C
               DO 460 L = UGL, J2
                  I2 = MB - J + L
                  U = B2 * A(J1,I2+1) + A(J,I2)
                  A(J,I2) = -A(J1,I2+1) + B1 * A(J,I2)
                  A(J1,I2+1) = U
  460          CONTINUE
C
               UGL = J
               A(J1,1) = B2 * A(J1,1) + G
               IF (J .EQ. N) GO TO 480
               MAXL = MIN(M1,N-J1)
C
               DO 470 L = 2, MAXL
                  I1 = J1 + L
                  I2 = MB - L
                  U = B2 * A(I1,I2) + A(I1,I2+1)
                  A(I1,I2+1) = -A(I1,I2) + B1 * A(I1,I2+1)
                  A(I1,I2) = U
  470          CONTINUE
C
               I1 = J + M1
               IF (I1 .GT. N) GO TO 480
               G = A(I1,1)
               A(I1,1) = B1 * A(I1,1)
  480          IF (.NOT. MATZ) GO TO 500
C
               DO 490 L = 1, N
                  U = B2 * Z(L,J1) + Z(L,J)
                  Z(L,J) = -Z(L,J1) + B1 * Z(L,J)
                  Z(L,J1) = U
  490          CONTINUE
C
  500       CONTINUE
C
  600    CONTINUE
C
         IF (MOD(K,64) .NE. 0) GO TO 700
C     .......... RESCALE TO AVOID UNDERFLOW OR OVERFLOW ..........
         DO 650 J = K, N
            IF (D(J) .GE. DMIN) GO TO 650
            MAXL = MAX(1,MB+1-J)
C
            DO 610 L = MAXL, M1
  610       A(J,L) = DMINRT * A(J,L)
C
            IF (J .EQ. N) GO TO 630
            MAXL = MIN(M1,N-J)
C
            DO 620 L = 1, MAXL
               I1 = J + L
               I2 = MB - L
               A(I1,I2) = DMINRT * A(I1,I2)
  620       CONTINUE
C
  630       IF (.NOT. MATZ) GO TO 645
C
            DO 640 L = 1, N
  640       Z(L,J) = DMINRT * Z(L,J)
C
  645       A(J,MB) = DMIN * A(J,MB)
            D(J) = D(J) / DMIN
  650    CONTINUE
C
  700 CONTINUE
C     .......... FORM SQUARE ROOT OF SCALING MATRIX ..........
  800 DO 810 J = 2, N
  810 E(J) = SQRT(D(J))
C
      IF (.NOT. MATZ) GO TO 840
C
      DO 830 J = 1, N
C
         DO 820 K = 2, N
  820    Z(J,K) = E(K) * Z(J,K)
C
  830 CONTINUE
C
  840 U = 1.0E0
C
      DO 850 J = 2, N
         A(J,M1) = U * E(J) * A(J,M1)
         U = E(J)
         E2(J) = A(J,M1) ** 2
         A(J,MB) = D(J) * A(J,MB)
         D(J) = A(J,MB)
         E(J) = A(J,M1)
  850 CONTINUE
C
      D(1) = A(1,MB)
      E(1) = 0.0E0
      E2(1) = 0.0E0
      GO TO 1001
C
  900 DO 950 J = 1, N
         D(J) = A(J,MB)
         E(J) = 0.0E0
         E2(J) = 0.0E0
  950 CONTINUE
C
 1001 RETURN
      END


module local_routines
    !!
    !! NTHMP velocities Submerged Island benchmark
    !!
    use global_mod, only: dp, ip, charlen, pi
    use domain_mod, only: domain_type, STG, UH, VH, ELV

    implicit none

    !
    ! Parameters defining the domain geometry.
    !

    ! Length/width -- FULL
    real(dp), parameter :: global_lw(2) = [9.75_dp, 1.152_dp]
    real(dp), parameter :: global_ll(2) = [0.0_dp, 0.0_dp]

    ! Conical island details
    real(dp), parameter :: island_centre(2) = [5.0_dp, global_lw(2)/2.0_dp]
    real(dp), parameter :: island_radius_base = 0.75_dp / 2.0_dp
    real(dp), parameter :: island_radius_top = 0.05_dp / 2.0_dp
    real(dp), parameter :: island_max_height = 0.049_dp
    real(dp), parameter :: island_slope = island_max_height/(island_radius_base - island_radius_top)

    ! Manning friction
    real(dp), parameter :: friction_manning = 0.025_dp
    real(dp), parameter :: wall_friction_manning = 0.05_dp ! Option to change friction along the walls.

    ! The velocity (in the x direction) as specified in the experiment.
    real(dp), parameter :: target_velocity = 0.115_dp

    ! To get the right depth, we should have the downstream boundary stage lower than 0.0_dp
    ! This can be implemented by specifying the boundary_function for the flather boundary, or
    ! setting domain%msl_linear (which is used in the default boundary_function). The latter
    ! is simpler
    real(dp), parameter :: msl_linear = -0.011_dp ! with low-friction (0.01), can use -0.007_dp
    ! "Background Depth", so that MSL = 0.
    real(dp), parameter :: depth_ocean = 0.054_dp

    contains

    ! Main setup routine
    subroutine set_initial_conditions(domain)
        class(domain_type), target, intent(inout):: domain

        integer(ip):: i, j
        real(dp), allocatable:: x(:), y(:)
        real(dp) :: gauges_1_to_4_x_coord, dd
        real(dp) :: gauge_xy(3,2)

        ! Stage
        domain%U(:,:,STG) = 0.0e-0_dp

        ! Elevation (background)
        domain%U(:,:,ELV) = -depth_ocean

        !
        ! Setup conical island
        !
        allocate(x(domain%nx(1)), y(domain%nx(1)))
        x = domain%x
        do j = 1, domain%nx(2)
            y = domain%y(j)
            do i = 1, domain%nx(1)

                ! Add the island
                dd = sqrt( (x(i) - island_centre(1))**2 + (y(i) - island_centre(2))**2 )
                if(dd < island_radius_base) then
                    domain%U(i,j,ELV) = -depth_ocean + &
                        min( island_slope * (island_radius_base - dd), island_max_height)
                end if

            end do
        end do
        deallocate(x,y)

        ! Add a wall on 3 sides -- the right side will be an (outflow) boundary condition
        domain%U(1:2,   :, ELV) = 1.0_dp
        domain%U(:  , 1:2, ELV) = 1.0_dp
        domain%U(:  , domain%nx(2)-1:domain%nx(2), ELV) = 1.0_dp

        print*, 'Elevation range: ', minval(domain%U(:,:,ELV)), maxval(domain%U(:,:,ELV))

        ! Ensure stage >= elevation
        domain%U(:,:,STG) = max(domain%U(:,:,STG), domain%U(:,:,ELV) + 1.0e-07_dp)

        ! Manning friction
        domain%manning_squared = friction_manning*friction_manning
        ! with artificial "wall friction"
        domain%manning_squared(:, 3) = wall_friction_manning*wall_friction_manning
        domain%manning_squared(:, domain%nx(2) - 2) = wall_friction_manning*wall_friction_manning

        ! Gauges have fixed locations
        gauge_xy(1:3, 1) = [ island_centre(1) + island_radius_base + 1.0_dp, global_lw(2)/2.0_dp          , 1.0_dp]
        gauge_xy(1:3, 2) = [ island_centre(1) + island_radius_base + 1.0_dp, global_lw(2)/2.0_dp + 0.27_dp, 2.0_dp]
        call domain%setup_point_gauges(xy_coords = gauge_xy(1:2,:), gauge_ids=gauge_xy(3,:))

    end subroutine

    !
    ! This is the discharge source term
    !
    subroutine apply_discharge_forcing(domain, dt)
        type(domain_type), intent(inout) :: domain
        real(dp), intent(in) :: dt
        integer(ip) :: j

        ! Volume_in_per_unit_time * dt = dStage_in_a_timestep * cell_area = Discharge_in * dt
        !    and
        ! Discharge_in = target_velocity * target_depth * distance_left_edge
        !    so
        ! dStage = target_velocity * target_depth * distance_left_edge * dt / cell_area

        !$OMP PARALLEL DEFAULT(PRIVATE) SHARED(domain, dt)
        !$OMP DO SCHEDULE(STATIC)
        do j = 1, domain%nx(2)
            ! Add a volume so that the x-directed velocity = target_velocity
            domain%U(3, j, STG) = domain%U(3, j,STG) + &
                target_velocity * depth_ocean * domain%distance_left_edge(j) * dt / &
                    (domain%distance_bottom_edge(3)*domain%distance_left_edge(j))
        end do
        !$OMP END DO
        !$OMP END PARALLEL

    end subroutine

end module

!@!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program Submerged_Island
    !!
    !! NTHMP velocities Submerged Island benchmark
    !!

    use global_mod, only: ip, dp, minimum_allowed_depth, default_nonlinear_timestepping_method
    use domain_mod, only: domain_type
    use multidomain_mod, only: multidomain_type, setup_multidomain, test_multidomain_mod
    use boundary_mod, only: flather_boundary
    use timer_mod
    use logging_mod, only: log_output_unit
    use local_routines
    implicit none

    ! Useful misc variables
    integer(ip):: j, i, nd, forcing_case

    ! Type holding all domains
    type(multidomain_type) :: md

    type(timer_type) :: program_timer

    real(dp), parameter :: mesh_refine = 8.0_dp ! Increase resolution by this amount

    real(dp), parameter ::  global_dt = 0.06_dp / mesh_refine ! * 0.5_dp

    ! Approx timestep between outputs
    real(dp), parameter :: approximate_writeout_frequency = 5.0_dp ! 0.5_dp
    real(dp), parameter :: final_time = 1000._dp

    ! Use this to read command line arguments
    character(len=20) :: tempchar

    !
    ! Key geometric parameters are defined in the 'local routines' module
    !

    ! Grid size (number of x/y cells) in outer domain
    integer(ip), parameter:: global_nx(2) = int(global_lw*10, ip) * mesh_refine

    integer(ip), parameter :: write_grids_and_print_every_nth_step = ceiling(approximate_writeout_frequency/global_dt)

    call program_timer%timer_start('setup')

    ! nd domains in this model
    nd = 1
    allocate(md%domains(nd))

    !
    ! Setup basic metadata
    !

    ! Main domain
    md%domains(1)%lower_left =global_ll
    md%domains(1)%lw = global_lw
    md%domains(1)%nx = global_nx
    md%domains(1)%dx = md%domains(1)%lw/md%domains(1)%nx
    md%domains(1)%timestepping_refinement_factor = 1_ip
    md%domains(1)%dx_refinement_factor = 1.0_dp
    md%domains(1)%timestepping_method = default_nonlinear_timestepping_method
    md%domains(1)%cliffs_minimum_allowed_depth = 0.01_dp

    !md%domains(1)%eddy_visc_constants = [0.000_dp, 0.0_dp]
    !md%domains(1)%eddy_visc_constants = [0.000_dp, 0.5_dp]
    md%domains(1)%msl_linear = msl_linear

    ! Allocate domains and prepare comms
    call md%setup()

    ! Initial conditions
    do j = 1, size(md%domains)
        call set_initial_conditions(md%domains(j))
    end do

    ! Build boundary conditions
    md%domains(1)%boundary_subroutine => flather_boundary
    md%domains(1)%forcing_subroutine => apply_discharge_forcing

    call md%make_initial_conditions_consistent()

    ! For stability in 'null' regions, we set them to 'high land' that
    ! should be inactive.
    call md%set_null_regions_to_dry()

    ! Print the gravity-wave CFL limit, to guide timestepping
    do j = 1, size(md%domains)
        print*, 'domain: ', j, 'ts: ', &
            md%domains(j)%stationary_timestep_max()
    end do

    print*, 'End setup'
    call program_timer%timer_end('setup')
    call program_timer%timer_start('evolve')

    ! Evolve the code
    do while (.true.)

        ! Write gauges every time-step, but print and write grids less often
        call program_timer%timer_start('IO')
        call md%write_outputs_and_print_statistics(approximate_writeout_frequency=0.0_dp,&
            write_grids_less_often=write_grids_and_print_every_nth_step, &
            print_less_often = write_grids_and_print_every_nth_step,&
            write_gauges_less_often= 1_ip)
        call program_timer%timer_end('IO')

        if (md%domains(1)%time > final_time) exit

        call md%evolve_one_step(global_dt)

    end do

    call program_timer%timer_end('evolve')
    call md%finalise_and_print_timers

    print*, ''
    call program_timer%print(output_file_unit=log_output_unit)

end program