!> Testing SVD
!! \details
!! Invoke it with the following parameters:
!!
!!   # number of processor rows
!!   # number of processor columns
!!   # block size
!!   # file with the matrix to decompose
!!
!! The file with the matrix should contain two integer numbers (m,n) in its first line, indicating
!! the dimension of the problem. Then n lines with m entries should follow.
program test_diag
  use, intrinsic :: iso_fortran_env, stdout => output_unit
  use test_common_module
  use libscalapackfx_module
  implicit none

  call main()

contains

  subroutine main()
    type(blacsgrid) :: mygrid
    real(dp), allocatable :: matrix(:,:), U(:,:), sigma(:), vt(:,:)
    complex(dp), allocatable :: matrixcplx(:,:), Ucplx(:,:), vtcplx(:,:)
    integer :: matrixdesc(DLEN_), Udesc(DLEN_), vtdesc(DLEN_)
    integer :: mm, nn
    integer :: tsys1, tsys2, tcount
    real(dp) :: tcpu1, tcpu2
    character(100) :: matfile
    integer :: nprow, npcol, bsize
    integer :: iproc, nproc

    call getarguments(nprow, npcol, bsize, matfile)

    call blacsfx_pinfo(iproc, nproc)
    if (npcol * nprow /= nproc) then
      write(stdout, *) "Incorrect number of processors:", npcol, nprow,&
          & nproc
      call blacsfx_exit(keepmpi=.false.)
      stop
    end if
    call mygrid%initgrid(nprow, npcol)
    if (mygrid%lead) then
      write(stdout, "(A,2(1X,I0))") "# processor grid:", nprow, npcol
      write(stdout, "(A,1X,I0)") "# block size:", bsize
    end if

    call readfromfile(mygrid, matfile, bsize, bsize, matrix, matrixdesc)

    mm = matrixdesc(M_)
    nn = matrixdesc(N_)

    if (mygrid%lead) then
      write(stdout, "(A,2(1X,I0))") "# matrix size:", mm, nn
      write(stdout, "(A,1X,A)") "# singular value decomposition:", "standard"
      write(stdout, "(A,2(1X,I0))") "# matrix size on leader:",&
          & size(matrix, dim=1), size(matrix, dim=2)
    end if

    call system_clock(tsys1, tcount)
    call cpu_time(tcpu1)

    ! Allocate matrices
    call scalafx_creatematrix(mygrid, mm, mm, bsize, bsize, U, Udesc)
    call scalafx_creatematrix(mygrid, nn, nn, bsize, bsize, Vt, Vtdesc)
    allocate(sigma(min(mm,nn)))

    allocate(matrixcplx(size(matrix,dim=1),size(matrix,dim=2)))
    allocate(Ucplx(size(u,dim=1),size(u,dim=2)))
    allocate(vtcplx(size(vt,dim=1),size(vt,dim=2)))
    matrixcplx = 0.0_dp
    Ucplx = 0.0_dp
    vtcplx = 0.0_dp

    matrixcplx = ((1,1)/sqrt(2.0_dp)) * matrix

    call scalafx_pgesvd(matrix, matrixdesc, U, Udesc, sigma, vt, vtdesc)

    call cpu_time(tcpu2)
    call system_clock(tsys2)

    if (mygrid%lead) then
      write(stdout, "(A,F8.1)") "# cpu time on leader:", tcpu2 - tcpu1
      write(stdout, "(A,F8.1)") "# system time on leader:",&
          & real(tsys2 - tsys1, dp) / real(tcount, dp)
    end if

    ! Write singular values and vectors
    if (mygrid%lead) then
      open(12, file="singularvals.dat", form="formatted", status="replace")
      write(12,*)"Real"
      write(12, "(ES23.15)") sigma
      close(12)
      write(stdout, "(A,A,A)") "# Singular values written to '", "singularvals.dat", "'"
    end if
    call writetofile(mygrid, "singularU.dat", U, Udesc)
    call writetofile(mygrid, "singularVt.dat", vT, Vtdesc)
    if (mygrid%lead) then
      write(stdout, "(A,A,A)") "# Singular vectors written to '", "singularU/singularVt.dat", "'"
    end if

    call scalafx_pgesvd(matrixcplx, matrixdesc, Ucplx, Udesc, sigma, vtcplx, vtdesc)
    if (mygrid%lead) then
      open(12, file="singularvals.dat", form="formatted", status='old', position='append')
      write(12,*)"Complex"
      write(12, "(ES23.15)") sigma
      close(12)
      write(stdout, "(A,A,A)") "# Singular values written to '", "singularvals.dat", "'"
    end if

    ! Destroy blacs communication layer.
    call blacsfx_exit()

  end subroutine main

  !> Process command line arguments.
  subroutine getarguments(nprow, npcol, bsize, matfile)
    integer, intent(out) :: npcol, nprow, bsize
    character(*), intent(out) :: matfile

    integer :: narg
    character(128) :: buffer

    narg = command_argument_count()
    if (narg /= 4) then
      write(stdout, *) "Incorrect number of arguments"
      write(stdout, *) "Need: nprow npcol bsize matrix"
      stop
    end if
    call get_command_argument(1, buffer)
    read(buffer, *) nprow
    call get_command_argument(2, buffer)
    read(buffer, *) npcol
    call get_command_argument(3, buffer)
    read(buffer, *) bsize
    call get_command_argument(4, matfile)

  end subroutine getarguments

end program test_diag


!
! Copyright (c) 1998, NVIDIA CORPORATION.  All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
!  Module defining a user generic which resolves to a function returning
!  an array whose size is the SIZE of an array argument.
!
module square
interface square
    function square_s(x)		!"scalar" version
    integer, intent(in) :: x
    integer :: square_s
    end function square_s
    function square_v(x)		!"vector" version
    integer, dimension(:), intent(in) :: x
    integer, dimension(size(x)) :: square_v
    end function square_v
endinterface
integer result(10)
common/result/result
endmodule square

function square_s(x)		!"scalar" version
    integer, intent(in) :: x
    integer :: square_s
    square_s = x * x
end function square_s

function square_v(x)		!"vector" version
    integer, dimension(:), intent(in) :: x
    integer, dimension(size(x)) :: square_v
    square_v = x * x
end function square_v

subroutine test_v(x)
    use square
    implicit none
    integer, dimension(:), intent(in) :: x
    integer, dimension(size(x)) :: gam1
    gam1=square(x)
!    print *, gam1
    result(1:3) = gam1(1:3)
end subroutine test_v

subroutine test_s(x)
    use square
    implicit none
    integer :: x, gam1
    result(4) = square(x)
end subroutine test_s

program test
    interface
	subroutine test_v(x)
	integer, dimension(:), intent(in) :: x
	endsubroutine
    endinterface
    integer, dimension(3) :: inp = (/2,-3,4/)
    integer, dimension(4) :: expect = (/4,9,16,25/)
    integer result(10)
    common/result/result
    call test_v(inp)
    call test_s(-5)
!    print *, result(1:3), result(4)
    call check(result, expect, 4)
end


      subroutine twodinit( a, b, f, nx, sx, ex, sy, ey )
      integer nx, sx, ex, sy, ey
      double precision a(sx-1:ex+1, sy-1:ey+1), b(sx-1:ex+1, sy-1:ey+1), &
                       f(sx-1:ex+1, sy-1:ey+1)
!
      integer i, j
!
      do j=sy-1,ey+1
         do i=sx-1,ex+1
            a(i,j) = 0.0d0
            b(i,j) = 0.0d0
            f(i,j) = 0.0d0
         enddo
      enddo
!
!    Handle boundary conditions
!
      if (sx .eq. 1) then
         do j=sy,ey
            a(0,j) = 1.0d0
            b(0,j) = 1.0d0
         enddo
      endif
      if (ex .eq. nx) then
         do j=sy,ey
            a(nx+1,j) = 0.0d0
            b(nx+1,j) = 0.0d0
         enddo
      endif
      if (sy .eq. 1) then
         do i=sx,ex
            a(i,0) = 1.0d0
            b(i,0) = 1.0d0
         enddo
      endif
!
      return
      end


! RUN: bbc -emit-fir %s -o - | FileCheck %s

! CHECK-LABEL: func @_QPaint_test(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<f32>{{.*}}, %[[VAL_1:.*]]: !fir.ref<f32>{{.*}}) {
subroutine aint_test(a, b)
! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_0]] : !fir.ref<f32>
! CHECK: %[[VAL_3:.*]] = fir.call @llvm.trunc.f32(%[[VAL_2]]) : (f32) -> f32
! CHECK: fir.store %[[VAL_3]] to %[[VAL_1]] : !fir.ref<f32>
! CHECK: return
  real :: a, b
  b = aint(a)
end subroutine


C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 06.01.02/02                           *
C  *    TEST TITLE : Setting and inquiring global          *
C  *                 transformations                       *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

C  Declare program-specific variables

C Element type
      INTEGER     PEGMT3, PEGMT
      PARAMETER  (PEGMT3 = 59, PEGMT = 60)

C array sizes
      INTEGER    INLEN, RELEN, STLEN
      PARAMETER (INLEN = 20, RELEN = 20, STLEN = 20)

      INTEGER    CELTYP, STRID, INTLEN, RLLEN, STRLEN, ROW, COL, IX

      INTEGER    INTG, INTAR(INLEN), RL, STR, STRARL(STLEN)

      REAL       M3(3,3), M4(4,4), RLAR(RELEN)

      CHARACTER  STRAR(STLEN)

C              | 2.2 -33.33e33 9.9e-11 |
C  matrix m3 = | 4.4   5.5     6.6     |
C              | 0.0  -5.2     9.9     |

      DATA M3 /2.2, 4.4, 0.0, -33.33E33, 5.5, -5.2, 9.9E-11, 6.6, 9.9/

C              | 2.2 -33.33e33 9.9e-11   1.34 |
C  matrix m4 = | 4.4   5.5     6.6      12.4  |
C              | 0.0  -5.2     9.9     123.0  |
C              | 3.1   4.1     5.9265   66.66 |

      DATA M4 /2.2, 4.4, 0.0, 3.1, -33.33E33, 5.5, -5.2, 4.1,
     1         9.9E-11, 6.6, 9.9, 5.9265, 1.34, 12.4, 123.0, 66.66/

      CALL INITGL ('06.01.02/02')

C open PHIGS
      CALL XPOPPH (ERRFIL, MEMUN)

      STRID = 101
      CALL POPST (STRID)

C  Use <inquire current element type and size> thoughout to determine
C      current element type
C
C  Use <inquire current element content> throughout to determine
C      current element content

C  <Set global transformation 3> with m4
      CALL PSGMT3 (M4)

      CALL SETMSG ('9 10', '<Inquire current element type and size> ' //
     1             'should return set global transformation 3 as '    //
     2             'the type of the created element and the '         //
     3             'appropriate element size.')

C  <inquire current element type and size>
      CALL PQCETS (ERRIND, CELTYP, INTLEN, RLLEN, STRLEN)

      CALL IFPF ( ERRIND   .EQ.   0      .AND.
     1            CELTYP   .EQ.   PEGMT3 .AND.
     2            INTLEN   .EQ.   0      .AND.
     3            RLLEN    .EQ.  16      .AND.
     4            STRLEN   .EQ.   0)

      CALL SETMSG ('9 11', '<Inquire current element content> should '//
     1             'return the standard representation for set '      //
     2             'global transformation 3.')

C  <inquire current element content>
      CALL PQCECO (INLEN, RELEN, STLEN, ERRIND, INTG, INTAR,
     1             RL, RLAR, STR, STRARL, STRAR)

      IF (ERRIND   .EQ.  0      .AND.
     1    INTG     .EQ.  0      .AND.
     2    RL       .EQ. 16      .AND.
     3    STR      .EQ.  0)  THEN
C OK so far
      ELSE
         CALL FAIL
         CALL INMSG ('Array sizes are incorrect.')
         GOTO 190
      ENDIF

      IX = 0
      DO 100 COL = 1,4
      DO 110 ROW = 1,4
         IX = IX+1
         IF (M4(ROW, COL) .NE. RLAR(IX)) THEN
            CALL FAIL
            CALL INMSG ('Matrix values are incorrect.')
            GOTO 190
         ENDIF
110   CONTINUE
100   CONTINUE

      CALL PASS

190   CONTINUE

C  <Set global transformation> with m3
      CALL PSGMT (M3)

      CALL SETMSG ('12 13', '<Inquire current element type and '      //
     1             'size> should return set global transformation '   //
     2             'as the type of the created element and the '      //
     3             'appropriate element size.')

C  <inquire current element type and size>
      CALL PQCETS (ERRIND, CELTYP, INTLEN, RLLEN, STRLEN)

      CALL IFPF ( ERRIND   .EQ.   0      .AND.
     1            CELTYP   .EQ.   PEGMT  .AND.
     2            INTLEN   .EQ.   0      .AND.
     3            RLLEN    .EQ.   9      .AND.
     4            STRLEN   .EQ.   0)

      CALL SETMSG ('12 14', '<Inquire current element content> '      //
     1             'should return the standard representation for '   //
     2             'set global transformation.')

C  <inquire current element content>
      CALL PQCECO (INLEN, RELEN, STLEN, ERRIND, INTG, INTAR,
     1             RL, RLAR, STR, STRARL, STRAR)

      IF (ERRIND   .EQ.  0      .AND.
     1    INTG     .EQ.  0      .AND.
     2    RL       .EQ.  9      .AND.
     3    STR      .EQ.  0)  THEN
C OK so far
      ELSE
         CALL FAIL
         CALL INMSG ('Array sizes are incorrect.')
         GOTO 390
      ENDIF

      IX = 0
      DO 300 COL = 1,3
      DO 310 ROW = 1,3
         IX = IX+1
         IF (M3(ROW, COL) .NE. RLAR(IX)) THEN
            CALL FAIL
            CALL INMSG ('Matrix values are incorrect.')
            GOTO 390
         ENDIF
310   CONTINUE
300   CONTINUE

      CALL PASS

390   CONTINUE

666   CONTINUE
      CALL ENDIT
      END


!-------------------------------------------------------------------------------
! Copyright (c) 2021, Whitman T. Dailey
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
! 1. Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
! 3. Neither the name of the copyright holder nor the names of its
!    contributors may be used to endorse or promote products derived from
!    this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!-------------------------------------------------------------------------------
Module PRNGs
    Use Kinds, Only: il !Long integer (4-bytes)
    Use Kinds, Only: id !Double integer (8-bytes)
    Use Kinds, Only: dp
    Implicit None
    Private
    Public :: MT19937_Type
    Public :: MT19937x64_Type
    Public :: MT2203_Type
    Public :: ACORN_kp_Type
    Public :: ACORN_Type
    Public :: randos

!-------------------------------------------------------------------------------
! PARAMETERS AND TYPES FOR MERSENNE TWISTER PRNGS
!-------------------------------------------------------------------------------
    Integer(il), Parameter :: TOPBIT = ISHFT(1073741824_il,1)
    Integer(il), Parameter :: ALLBIT = IOR(2147483647_il,TOPBIT)
    !Parameters and type for MT19937 PRNG
    Integer(il), Parameter :: default_seed_19937 = 4357_il
    Integer(il), Parameter :: n19937 = 624_il
    Integer(il), Parameter :: m19937 = 397_il
    !the MT19937 state
    Type :: MT19937_Type
        Integer(il) :: mt(1:n19937)
        Integer(il) :: mti = HUGE(n19937) !mti>n+1 means mt[n] is not initialized
        Logical :: seeded = .FALSE.
    Contains
        Procedure, Pass :: seed => seed_rng_mt19937
        Procedure, Pass :: seeds => seed_ar_rng_mt19937
        Procedure, Pass :: i => rng_mt19937_i
        Procedure, Pass :: r => rng_mt19937_r
        Procedure, Pass :: save => save_rng_mt19937
        Procedure, Pass :: load => load_rng_mt19937
    End Type MT19937_type

    !Parameters and type for MT19937x64 PRNG
    Integer(id), Parameter :: default_seed_19937x64 = 4357_id
    Integer(il), Parameter :: n19937x64 = 312
    Integer(il), Parameter :: m19937x64 = 156
    !the MT19937x64 state
    Type :: MT19937x64_Type
        Integer(id) :: mt(1:n19937x64)
        Integer(il) :: mti = HUGE(n19937x64) !mti>n+1 means mt[n] is not initialized
        Logical :: seeded = .FALSE.
    Contains
        Procedure, Pass :: seed => seed_rng_mt19937x64
        Procedure, Pass :: i => rng_mt19937x64_i
        Procedure, Pass :: r => rng_mt19937x64_r
        Procedure, Pass :: save => save_rng_mt19937x64
        Procedure, Pass :: load => load_rng_mt19937x64
    End Type MT19937x64_type

    !Parameters and type for MT2203 PRNGs
    Integer(il), Parameter :: n2203 = 69
    Integer(il), Parameter :: m2203 = 34
    !the MT2203 state
    Type :: MT2203_Type
        Integer(il) :: aj,bj,cj !index specific tempering parameters
        Integer(il) :: mt(1:n2203)
        Integer(il) :: mti = HUGE(n2203) !mti>n+1 means mt[n] is not initialized
        Logical :: seeded = .FALSE.
    Contains
        Procedure, Pass :: seed => seed_rng_mt2203
        Procedure, Pass :: seeds => seed_ar_rng_mt2203
        Procedure, Pass :: i => rng_mt2203_i
        Procedure, Pass :: r => rng_mt2203_r
        Procedure, Pass :: save => save_rng_mt2203
        Procedure, Pass :: load => load_rng_mt2203
    End Type MT2203_type

!-------------------------------------------------------------------------------
! PARAMETERS AND TYPES FOR ACORN PRNGS
!-------------------------------------------------------------------------------
    Integer, Parameter :: aMp = 60
    Integer(id), Parameter :: aM = 2_id**aMp
    Integer(id), Parameter :: aMm1 = aM - 1_id
    !the ACORN state
    Type :: ACORN_kp_Type
        Integer :: k
        Integer :: p
        Integer(id), Allocatable :: Y(:,:)
        Logical :: seeded = .FALSE.
    Contains
        Procedure, Pass :: seed => seed_rng_ACORN_kp
        Procedure, Pass :: step => step_rng_ACORN_kp
        Procedure, Pass :: r => rng_ACORN_r_i0e1_kp
        Procedure, Pass :: ri => rng_ACORN_r_i0i1_kp
        Procedure, Pass :: re => rng_ACORN_r_e0e1_kp
        Procedure, Pass :: r0 => rng_ACORN_r_i0e1_kp
        Procedure, Pass :: r1 => rng_ACORN_r_e0i1_kp
        Procedure, Pass :: il => rng_ACORN_i32_kp
        Procedure, Pass :: id => rng_ACORN_i64_kp
        ! Procedure, Pass :: save => save_rng_ACORN
        ! Procedure, Pass :: load => load_rng_ACORN
    End Type ACORN_kp_Type
    !A faster ACORN config with pre-determined k and p instead of generalized implementation
    Integer, Parameter :: aK = 13
    Integer, Parameter :: aP = 2
    Type :: ACORN_Type
        Integer(id) :: Y(1:aP,0:aK)
        Logical :: seeded = .FALSE.
    Contains
        Procedure, Pass :: seed => seed_rng_ACORN
        Procedure, Pass :: step => step_rng_ACORN
        Procedure, Pass :: r => rng_ACORN_r_i0e1
        Procedure, Pass :: ri => rng_ACORN_r_i0i1
        Procedure, Pass :: re => rng_ACORN_r_e0e1
        Procedure, Pass :: r0 => rng_ACORN_r_i0e1
        Procedure, Pass :: r1 => rng_ACORN_r_e0i1
        Procedure, Pass :: il => rng_ACORN_i32
        Procedure, Pass :: id => rng_ACORN_i64
        Procedure, Pass :: save => save_rng_ACORN
        Procedure, Pass :: load => load_rng_ACORN
    End Type ACORN_Type

Contains
!-------------------------------------------------------------------------------
!    MERSENNE TWISTER PRNGS:
!        - MT19937 (32- and 64- bit versions)
!        - MT2203 (family of 6024 generators)
!-------------------------------------------------------------------------------
!   A C-program for MT19937: Integer and real number versions
!       Coded by Takuji Nishimura, considering the suggestions by
!       Topher Cooper and Marc Rieffel in July-Aug. 1997.
!       Copyright (C) 1997 Makoto Matsumoto and Takuji Nishimura.
!
!   A C-program for MT19937-64: 64-bit version of Mersenne Twister PRNG
!       Coded by Takuji Nishimura and Makoto Matsumoto.
!       Copyright (C) 2004, Makoto Matsumoto and Takuji Nishimura.
!
!   Redistribution and use in source and binary forms, with or without
!   modification, are permitted provided that the following conditions
!   are met:
!     1. Redistributions of source code must retain the above copyright
!        notice, this list of conditions and the following disclaimer.
!     2. Redistributions in binary form must reproduce the above copyright
!        notice, this list of conditions and the following disclaimer in the
!        documentation and/or other materials provided with the distribution.
!     3. The names of its contributors may not be used to endorse or promote
!        products derived from this software without specific prior written
!        permission.
!
!   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
!   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
!   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
!   OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
!   EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
!   PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
!   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
!   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
!   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
!   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!-------------------------------------------------------------------------------
!   Fortran Translation of MT19937
!
!   Original Fortran translation by Hiroshi Takano.  Jan. 13, 1999.
!   Fortran translation rewritten as an f90 module by Richard Woloshyn,
!       (rwww@triumf.ca). June 30, 1999
!   FORTRAN 77 translation with updates to MT seeding by Tsuyoshi TADA.
!       December 19, 2005
!   Revised Fortran translation by Whitman Dailey.  Jun 02, 2018.
!       Air Force Institute of Technology, Department of Engineering Physics
!-------------------------------------------------------------------------------
!   Fortran Translation of MT19937-64
!
!   Original Fortran translation by Rﾃｩmi Piatek.  Nov. 04, 2016.
!       The University of Copenhagen, Department of Economics
!       email: {first}.{last}@econ.ku.dk
!   Revised Fortran translation by Whitman Dailey.  Jun 02, 2018.
!       Air Force Institute of Technology, Department of Engineering Physics
!-------------------------------------------------------------------------------
!   Fortran Translation of MT2203
!
!   Fortran translation by Whitman Dailey.  Jun 02, 2018.
!       Air Force Institute of Technology, Department of Engineering Physics
!-------------------------------------------------------------------------------

Subroutine seed_rng_mt19937(RNG,seed,burn)
    Use Kinds, Only: il
    Implicit None
    Class(MT19937_Type), Intent(InOut) :: RNG
    Integer(il), Intent(In) :: seed
    Integer(il), Intent(In), Optional :: burn
    Integer(il) :: i
    Integer(il) :: k,burns

    RNG%mt(1) = IAND(seed,-1_il)
    Do i = 2_il,n19937
        RNG%mt(i) = IAND(1812433253_il * IEOR(RNG%mt(i-1_il),ISHFT(RNG%mt(i-1_il),-30)) + i,ALLBIT)
    End Do
    RNG%mti = n19937 + 1_il
    RNG%seeded = .TRUE.
    If (Present(burn)) Then
        Do k = 1_il,burn
            burns = RNG%i()
        End Do
    End If
End Subroutine seed_rng_mt19937

Subroutine seed_ar_rng_mt19937(RNG,seeds)
    Use Kinds, Only: il
    Implicit None
    Class(MT19937_Type), Intent(InOut) :: RNG
    Integer(il), Intent(In) :: seeds(:)
    Integer(il) :: i,j,k

    Call RNG%seed(19650218_il)
    i = 1_il
    j = 0_il
    Do k = 1_il,max(n19937,Size(seeds))
        RNG%mt(i+1_il) = IAND(IEOR(RNG%mt(i+1_il),IEOR(RNG%mt(i),ISHFT(RNG%mt(i),-30))*1664525_il)+seeds(j+1_il)+Int(j,il),ALLBIT)
        i = i + 1_il
        j = j + 1+il
        If (i .GT. n19937) Then
            RNG%mt(1) = RNG%mt(n19937)
            i = 1_il
        End If
        If (j .GE. Size(seeds)) j = 0_il
    End Do
    Do k = 1_il,n19937
        RNG%mt(i+1_il) = IAND(IEOR(RNG%mt(i+1_il),IEOR(RNG%mt(i),ISHFT(RNG%mt(i),-30))*1566083941_il)-Int(i,il),ALLBIT)
        i = i + 1_il
        If (i .GT. n19937) Then
            RNG%mt(1) = RNG%mt(n19937)
            i = 1_il
        End If
    End Do
    RNG%mt(1) = TOPBIT
End Subroutine seed_ar_rng_mt19937

Function rng_mt19937_i(RNG) Result(y)
    Use Kinds, Only: il
    Implicit None
    Integer(il) :: y
    Class(MT19937_Type), Intent(InOut) :: RNG
    Integer(il) :: i
    Integer(il), Parameter :: mag01(0:1) = (/ 0_il , -1727483681_il /) !constant vector a
    Integer(il), Parameter :: lm = 2147483647_il !least significant r bits
    Integer(il), Parameter :: um = ISHFT(1073741824_il,1) !-2147483647_il-1_il !most significant w-r bits
    Integer(il), Parameter :: tb = -1658038656_il !tempering parameters
    Integer(il), Parameter :: tc = -272236544_il !tempering parameters

    If (RNG%mti .GT. n19937) Then  !generate N words at one time
        If (RNG%seeded) Then  !needs new words
            Do  i = 1_il,n19937-m19937
                y = IOR(IAND(RNG%mt(i),um), IAND(RNG%mt(i+1_il),lm))
                RNG%mt(i) = IEOR(IEOR(RNG%mt(i+m19937), ISHFT(y,-1)),mag01(IAND(y,1_il)))
            End Do
            Do  i = n19937-m19937+1_il,n19937-1_il
                y = IOR(IAND(RNG%mt(i),um), IAND(RNG%mt(i+1_il),lm))
                RNG%mt(i) = IEOR(IEOR(RNG%mt(i+(m19937-n19937)), ISHFT(y,-1)),mag01(IAND(y,1_il)))
            End Do
            y = IOR(IAND(RNG%mt(n19937),um), IAND(RNG%mt(1),lm))
            RNG%mt(n19937) = IEOR(IEOR(RNG%mt(m19937), ISHFT(y,-1)),mag01(IAND(y,1_il)))
            RNG%mti = 1
        Else  !needs seeding
            Call RNG%seed(default_seed_19937)
        End If
    End If
    y = RNG%mt(RNG%mti)
    RNG%mti = RNG%mti + 1_il
    y = IEOR(y, ISHFT(y,-11))
    y = IEOR(y, IAND(ISHFT(y,7),tb))
    y = IEOR(y, IAND(ISHFT(y,15),tc))
    y = IEOR(y, ISHFT(y,-18))
End Function rng_mt19937_i

Function rng_mt19937_r(RNG) Result(x)
    Use Kinds, Only: dp
    Use Kinds, Only: il
    Implicit None
    Real(dp) :: x
    Class(MT19937_Type), Intent(InOut) :: RNG
    Integer(il) :: y
    Real(dp), Parameter :: two32 = 2._dp**32
    Real(dp), Parameter :: invtwo32 = 1._dp / two32

    y = RNG%i()
    If (y .LT. 0_il) Then
        x = (Real(y,dp) + two32) * invtwo32
    Else
        x = Real(y,dp) * invtwo32
    End If
End Function rng_mt19937_r

Function rng_mt19937_r53(RNG) Result(x)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: x
    Class(MT19937_Type), Intent(InOut) :: RNG
    Real(dp) :: a,b
    Real(dp), Parameter :: two32 = 2._dp**32
    Real(dp), Parameter :: two26 = 2._dp**26
    Real(dp), Parameter :: invtwo53 = 1._dp / (2._dp**53)

    a = Real(ISHFT(RNG%i(),-5),dp)
    b = Real(ISHFT(RNG%i(),-6),dp)
    If (a .LT. 0._dp) a = a + two32
    If (b .LT. 0._dp) b = b + two32
    x = (a * two26 + b) * invtwo53
End Function rng_mt19937_r53

Subroutine save_RNG_mt19937(RNG,fname)
    Use Kinds, Only: il
    Use FileIO_Utilities, Only: Var_to_file
    Implicit None
    Class(MT19937_Type), Intent(In) :: RNG
    Character(*), Intent(In) :: fname
    Integer(il) :: state(1:n19937+1)

    state(1:n19937) = RNG%mt
    state(n19937+1) = RNG%mti
    Call Var_to_File(state,fname)
End Subroutine save_RNG_mt19937

Subroutine load_RNG_mt19937(RNG,fname)
    Use Kinds, Only: il
    Use FileIO_Utilities, Only: Var_from_file
    Implicit None
    Class(MT19937_Type), Intent(InOut) :: RNG
    Character(*), Intent(In) :: fname
    Integer(il) :: state(1:n19937+1)

    Call Var_from_File(state,fname)
    RNG%mt = state(1:n19937)
    RNG%mti = state(n19937+1)
    RNG%seeded = .TRUE.
End Subroutine load_RNG_mt19937

Subroutine seed_rng_mt19937x64(RNG,seed,burn)
    Use Kinds, Only: id
    Implicit None
    Class(MT19937x64_Type), Intent(InOut) :: RNG
    Integer(id), Intent(In) :: seed
    Integer(id), Intent(In), Optional :: burn
    Integer(il) :: i
    Integer(id) :: k,burns

    RNG%mt(1) = seed
    Do i = 2_il,n19937x64
        RNG%mt(i) = 6364136223846793005_id * IEOR(RNG%mt(i-1_il), ISHFT(RNG%mt(i-1_il),-62)) + Int(i,id)
    End Do
    RNG%mti = n19937x64 + 1_il
    RNG%seeded = .TRUE.
    If (Present(burn)) Then
        Do k = 1_id,burn
            burns = RNG%i()
        End Do
    End If
End Subroutine seed_rng_mt19937x64

Subroutine seed_ar_rng_mt19937x64(RNG,seeds)
    Use Kinds, Only: id
    Implicit None
    Class(MT19937x64_Type), Intent(InOut) :: RNG
    Integer(id), Intent(In) :: seeds(:)
    Integer(il) :: i,j,k

    Call RNG%seed(19650218_id)
    i = 1_il
    j = 0_il
    Do k = 1_il,Max(n19937x64,Size(seeds))
        RNG%mt(i+1_il) = IEOR( RNG%mt(i+1_il) , &
                             & 3935559000370003845_id*IEOR(RNG%mt(i),ISHFT(RNG%mt(i),-62)) ) + seeds(j+1_il) + Int(j,id)
        i = i + 1_il
        j = j + 1_il
        If (i .GT. n19937x64) Then
            RNG%mt(1) = RNG%mt(n19937x64)
            i = 1_il
        End If
        If (j .GE. Size(seeds)) j = 0_il
    End Do
    Do k = 1_il,n19937x64
      RNG%mt(i+1_il) = IEOR(RNG%mt(i+1_il),2862933555777941757_id*IEOR(RNG%mt(i),ISHFT(RNG%mt(i),-62))) - Int(i,id)
      i = i + 1_il
      If (i .GT. n19937x64) Then
          RNG%mt(1) = RNG%mt(n19937x64)
          i = 1_il
      End If
    End Do
    RNG%mt(1) = ISHFT(1_id,63)  ! MSB is 1; assuring non-zero initial array
End Subroutine seed_ar_rng_mt19937x64

Function rng_mt19937x64_i(RNG) Result(y)
    Use Kinds, Only: id
    Implicit None
    Integer(id) :: y
    Class(MT19937x64_Type), Intent(InOut) :: RNG
    Integer(il) :: i
    Integer(id), Parameter :: mag01(0:1) = (/ 0_id, -5403634167711393303_id /)
    Integer(id), Parameter :: um = -2147483648_id ! most significant 33 bits
    Integer(id), Parameter :: lm =  2147483647_id ! least significant 31 bits

    If (RNG%mti .GT. n19937x64) Then ! generate n words at one time
        If (RNG%seeded) Then  !needs new words
            Do i = 1_il,n19937x64-m19937x64
                y = IOR(IAND(RNG%mt(i),um), IAND(RNG%mt(i+1_il), lm))
                RNG%mt(i) = IEOR(IEOR(RNG%mt(i+m19937x64), ISHFT(y,-1)), mag01(IAND(y,1_id)))
            End Do
            Do i = n19937x64-m19937x64+1,n19937x64-1
                y = IOR(IAND(RNG%mt(i), um), IAND(RNG%mt(i+1_il), lm))
                RNG%mt(i) = IEOR(IEOR(RNG%mt(i+m19937x64-n19937x64), ISHFT(y,-1)), mag01(IAND(y,1_id)))
            End Do
            y = IOR(IAND(RNG%mt(n19937x64), um), IAND(RNG%mt(1), lm))
            RNG%mt(n19937x64) = IEOR(IEOR(RNG%mt(m19937x64), ISHFT(y,-1)), mag01(IAND(y,1_id)))
            RNG%mti = 1_il
        Else  !needs seeding
            Call RNG%seed(default_seed_19937x64)
        End If
    End If
    y = RNG%mt(RNG%mti)
    RNG%mti = RNG%mti + 1_il
    y = IEOR(y, IAND(ISHFT(y,-29), 6148914691236517205_id))
    y = IEOR(y, IAND(ISHFT(y, 17), 8202884508482404352_id))
    y = IEOR(y, IAND(ISHFT(y, 37),   -2270628950310912_id))
    y = IEOR(y, ISHFT(y,-43))
End Function rng_mt19937x64_i

Function rng_mt19937x64_r(RNG) Result(x)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: x
    Class(MT19937x64_Type), Intent(InOut) :: RNG
    Real(dp), Parameter :: invtwo53 = 1._dp / 2._dp**53

    x = Real(ISHFT(RNG%i(),-11),dp) * invtwo53
End Function rng_mt19937x64_r

Subroutine save_RNG_mt19937x64(RNG,fname)
    Use Kinds, Only: id
    Use FileIO_Utilities, Only: Var_to_file
    Implicit None
    Class(MT19937x64_Type), Intent(In) :: RNG
    Character(*), Intent(In) :: fname
    Integer(id) :: state(1:n19937x64+1)

    state(1:n19937x64) = RNG%mt
    state(n19937x64+1) = Int(RNG%mti,id)
    Call Var_to_File(state,fname)
End Subroutine save_RNG_mt19937x64

Subroutine load_RNG_mt19937x64(RNG,fname)
    Use Kinds, Only: id
    Use Kinds, Only: il
    Use FileIO_Utilities, Only: Var_from_file
    Implicit None
    Class(MT19937x64_Type), Intent(InOut) :: RNG
    Character(*), Intent(In) :: fname
    Integer(id) :: state(1:n19937x64+1)

    Call Var_from_File(state,fname)
    RNG%mt = state(1:n19937x64)
    RNG%mti = Int(state(n19937x64+1),il)
    RNG%seeded = .TRUE.
End Subroutine load_RNG_mt19937x64

Subroutine seed_rng_mt2203(RNG,jj,seed,burn,resourcedir)
    Use Kinds, Only: il
    Use FileIO_Utilities, Only: max_path_len
    Use FileIO_Utilities, Only: slash
    Use FileIO_Utilities, Only: Output_Message
    Implicit None
    Class(MT2203_Type), Intent(InOut) :: RNG
    Integer(il), Intent(In) :: jj  !Index of the MT2203 stream for this PRNG
    Integer(il), Intent(In) :: seed  !Seed for PRNG
    Integer(il), Intent(In), Optional :: burn  !OPTIONAL: Number of random numbers to 'burn' after seeding
    Character(*), Intent(In), Optional :: resourcedir  !OPTIONAL: A directory, other than the default resources directory,
                                                       ! in which to find the MT2203 parameters file
    Integer(il) :: i
    Integer(il) :: k,burns
    Integer :: unit,stat
    Integer(il) :: nj2203  !number of parameter sets for MT2203 in the parameter file
    Character(:), Allocatable :: fname

    Allocate(Character(max_path_len) :: fname)
    If (Present(resourcedir)) Then
        fname = Trim(resourcedir)//'mt'//slash//'mt2203params.txt'
    Else
        fname = 'Resources'//slash//'mt'//slash//'mt2203params.txt'
    End If
    Open(NEWUNIT = unit , FILE = fname , STATUS = 'OLD' , ACTION = 'READ' , FORM = 'FORMATTED' , IOSTAT = stat)
    If (stat .NE. 0) Call Output_Message('ERROR:  PRNGs: seed_rng_mt2203:  Open MT parameter file failed',kill=.TRUE.)
    !Check available number of MT2203 parameter sets
    Read(unit,'(I11)') nj2203
    If (jj.LT.1_il .OR. jj.GT.nj2203) Then
        Write(*,'(A)')         'ERROR:  PRNGs: seed_rng_mt2203:  MT2203 parameter index out of range.'
        Write(*,'(A,I0,A,I0)') '        Specified index:  ',jj,'  Available range:  1-',nj2203
        ERROR STOP
    End If
    !Load MT2203 parameters from resource file
    Do i = 1_il,jj
        Read(unit,'(I11,2I12)') RNG%aj , RNG%bj , RNG%cj
    End Do
    Close(unit)
    !Seed the generator
    RNG%mt(1) = IAND(seed,-1_il)
    Do i = 2_il,n2203
        RNG%mt(i) = IAND(1812433253 * IEOR(RNG%mt(i-1_il),ISHFT(RNG%mt(i-1_il),-30)) + Int(i,il),-1_il)
    End Do
    RNG%mti = n2203 + 1_il
    RNG%seeded = .TRUE.
    If (Present(burn)) Then
        Do k = 1_il,burn
            burns = RNG%i()
        End Do
    End If
End Subroutine seed_rng_mt2203

Subroutine seed_ar_rng_mt2203(RNG,jj,seeds,resourcedir)
    Use Kinds, Only: il
    Implicit None
    Class(MT2203_Type), Intent(InOut) :: RNG
    Integer(il), Intent(In) :: jj
    Integer(il), Intent(In) :: seeds(:)
    Character(*), Intent(In), Optional :: resourcedir  !OPTIONAL: A directory, other than the default resources directory,
                                                       ! in which to find the MT2203 parameters file
    Integer(il) :: i,j,k

    If (Present(resourcedir)) Then
        Call RNG%seed(jj,19650218_il,RESOURCEDIR=resourcedir)
    Else
        Call RNG%seed(jj,19650218_il)
    End If
    i = 1_il
    j = 0_il
    Do k = 1_il,max(n2203,Size(seeds))
        RNG%mt(i+1_il)=IAND(IEOR(RNG%mt(i+1_il),IEOR(RNG%mt(i),ISHFT(RNG%mt(i),-30))*1664525_il)+seeds(j+1_il)+j,ALLBIT)
        i = i + 1_il
        j = j + 1_il
        If (i .GT. n2203) Then
            RNG%mt(1) = RNG%mt(n2203)
            i = 1_il
        End If
        If (j .GE. Size(seeds)) j = 0_il
    End Do
    Do k = 1_il,n2203
        RNG%mt(i+1_il)=IAND(IEOR(RNG%mt(i+1_il),IEOR(RNG%mt(i),ISHFT(RNG%mt(i),-30))*1566083941_il)-Int(i,il),ALLBIT)
        i = i + 1_il
        If (i .GT. n2203) Then
            RNG%mt(1) = RNG%mt(n2203)
            i = 1_il
        End If
    End Do
    RNG%mt(1) = TOPBIT
End Subroutine seed_ar_rng_mt2203

Function rng_mt2203_i(RNG) Result(y)
    Use Kinds, Only: il
    Implicit None
    Integer(il) :: y
    Class(MT2203_Type), Intent(InOut) :: RNG
    Integer(il) :: i
    Integer(il) :: mag01(0:1)
    Integer(il), Parameter :: lmask = 31_il !least significant r bits
    Integer(il), Parameter :: umask = -32_il !most significant w-r bits

    If (RNG%mti .GT. n2203) Then  !generate N words at one time
        If (RNG%seeded) Then  !needs new words
            mag01 = (/ 0_il , RNG%aj /)
            Do  i = 1_il,n2203-m2203
                y = IOR(IAND(RNG%mt(i),umask), IAND(RNG%mt(i+1_il),lmask))
                RNG%mt(i) = IEOR(IEOR(RNG%mt(i+m2203), ISHFT(y,-1)),mag01(IAND(y,1_il)))
            End Do
            Do  i = n2203-m2203+1,n2203-1
                y = IOR(IAND(RNG%mt(i),umask), IAND(RNG%mt(i+1),lmask))
                RNG%mt(i) = IEOR(IEOR(RNG%mt(i+(m2203-n2203)), ISHFT(y,-1)),mag01(IAND(y,1_il)))
            End Do
            y = IOR(IAND(RNG%mt(n2203),umask), IAND(RNG%mt(1),lmask))
            RNG%mt(n2203) = IEOR(IEOR(RNG%mt(m2203), ISHFT(y,-1)),mag01(IAND(y,1_il)))
            RNG%mti = 1_il
        Else  !needs seeding
            !HACK In the unseeded case, default behavior uses MT2203 index #1
            Call RNG%seed(1,default_seed_19937)
        End If
    End If
    y = RNG%mt(RNG%mti)
    RNG%mti = RNG%mti + 1_il
    y = IEOR(y, ISHFT(y,-12))
    y = IEOR(y, IAND(ISHFT(y,7),RNG%bj))
    y = IEOR(y, IAND(ISHFT(y,15),RNG%cj))
    y = IEOR(y, ISHFT(y,-18))
End Function rng_mt2203_i

Function rng_mt2203_r(RNG) Result(x)
    Use Kinds, Only: dp
    Use Kinds, Only: il
    Implicit None
    Real(dp) :: x
    Class(MT2203_Type), Intent(InOut) :: RNG
    Integer(il) :: y
    Real(dp), Parameter :: two32 = 2._dp**32
    Real(dp), Parameter :: invtwo32m1 = 1._dp / (two32 - 1._dp)

    y = RNG%i()
    If (y .LT. 0_il) Then
        x = (Real(y,dp) + two32) * invtwo32m1
    Else
        x = Real(y,dp) * invtwo32m1
    End If
End Function rng_mt2203_r

Subroutine save_RNG_mt2203(RNG,fname)
    Use Kinds, Only: il
    Use FileIO_Utilities, Only: Var_to_file
    Implicit None
    Class(MT2203_Type), Intent(In) :: RNG
    Character(*), Intent(In) :: fname
    Integer(il) :: state(1:n2203+1+3)

    state(1:n2203) = RNG%mt
    state(n2203+1) = RNG%mti
    state(n2203+1+1) = RNG%aj
    state(n2203+1+2) = RNG%bj
    state(n2203+1+3) = RNG%cj
    Call Var_to_File(state,fname)
End Subroutine save_RNG_mt2203

Subroutine load_RNG_mt2203(RNG,fname)
    Use Kinds, Only: il
    Use FileIO_Utilities, Only: Var_from_file
    Implicit None
    Class(MT2203_Type), Intent(InOut) :: RNG
    Character(*), Intent(In) :: fname
    Integer(il) :: state(1:n2203+1+3)

    Call Var_from_File(state,fname)
    RNG%mt = state(1:n2203)
    RNG%mti = state(n2203+1)
    RNG%aj = state(n2203+1+1)
    RNG%bj = state(n2203+1+2)
    RNG%cj = state(n2203+1+3)
    RNG%seeded = .TRUE.
End Subroutine load_RNG_mt2203

!-------------------------------------------------------------------------------
!    ACORN PRNGS:
!        - ACORN_kp (arbitrary state-space size ACORN generator)
!        - ACORN (Fixed state-space ACORN generator (k = 13 , p = 2))
!-------------------------------------------------------------------------------
!   This is a modern Fortran implementation of the Additive Congruential Random
!   Number (ACORN) generator developed by Ray Wikramaratna 1989-present.
!
!   http://acorn.wikramaratna.org/index.html
!
!   For non-commercial research and teaching, you may freely use all
!   information code executables and documents on this site, provided that you
!   make due acknowledgement.
!       --Roy Wikramaratna (mail : acorn@wikramaratna.org)
!-------------------------------------------------------------------------------

Subroutine seed_rng_ACORN_kp(RNG,k,p,seed,burn)
    Use Kinds, Only: id
    Use Kinds, Only: dp
    Implicit None
    Class(ACORN_kp_Type), Intent(InOut) :: RNG
    Integer, Intent(In) :: k,p
    Integer, Intent(In) :: seed
    Integer, Intent(In), Optional :: burn
    Integer :: i

    RNG%k = k
    RNG%p = p
    Allocate(RNG%Y(1:p,0:k))
    RNG%Y = 0_id
    Call ACORN_seeds(RNG%k,RNG%p,RNG%Y,seed)
    RNG%seeded = .TRUE.
    If (Present(burn)) Then
        Do i = 1,burn
            Call RNG%step()
        End Do
    End If
End Subroutine seed_rng_ACORN_kp

Subroutine ACORN_seeds(kk,pp,Y,seed)
    Use Kinds, Only: id
    Use Kinds, Only: dp
    Implicit None
    Integer, Intent(In) :: kk
    Integer, Intent(In) :: pp
    Integer(id), Intent(Out) :: Y(1:pp,0:kk)
    Integer, Intent(In) :: seed
    Integer :: k,p,b
    Integer :: s
    Integer, Allocatable :: ss(:)
    Real(dp) :: r

    Y = 0_id
    !we will use the intrinsic generator to seed the ACORN state based on the single integer seed provided
    Call RANDOM_SEED(size=s)
    Allocate(ss(1:s))
    Call randos(seed,s,ss)
    Call RANDOM_SEED(put=ss)
    !set the state with a uniform distribution of bit values
    Do k = 0,kk
        Do p = 1,pp
            Do b = 0,aMp-1
                Call RANDOM_NUMBER(harvest=r)
                If (r .LT. 0.5_dp) Then !set this bit to 0
                    Y(p,k) = IBCLR( Y(p,k) , b )
                Else !set this bit to 1
                    Y(p,k) = IBSET( Y(p,k) , b )
                End If
            End Do
        End Do
    End Do
    !set the least significant bit to 1 to guarantee an odd seed
    Y(1,0) = IBSET( Y(1,0) , 0 )
End Subroutine ACORN_seeds

Subroutine step_rng_ACORN_kp(RNG)
    !Use Kinds, Only: id
    Use Kinds, Only: dp
    Implicit None
    Class(ACORN_kp_Type), Intent(InOut) :: RNG
    Integer :: k,p

    ASSOCIATE ( Y => RNG%Y , kk => RNG%k , pp => RNG%p)
    Do k = 1,kk
        Y(:,k) = Y(:,k) + Y(:,k-1)
        Do p = pp,2,-1
            !If (Y(p,k) .GE. aM) Y(p-1:p,k) = Y(p-1:p,k) + (/ 1_id , -aM /)
            Y(p-1,k) = Y(p-1,k) + ISHFT( Y(p,k) , -aMp )
            Y(p,k) = IAND( Y(p,k) , aMm1 )
        End Do
        !If (Y(1,k) .GE. aM) Y(1,k) = Y(1,k) - aM
        Y(1,k) = IAND( Y(1,k) , aMm1 )
    End Do
    End ASSOCIATE
End Subroutine step_rng_ACORN_kp
Function rng_ACORN_r_i0e1_kp(RNG) Result(x)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: x
    Class(ACORN_kp_Type), Intent(InOut) :: RNG
    Real(dp), Parameter :: inv_two53 = 2._dp**(-53)

    Call RNG%step()
    x = inv_two53 * Real( ISHFT(RNG%Y(1,RNG%k),-7) , dp )
End Function rng_ACORN_r_i0e1_kp

Function rng_ACORN_r_e0i1_kp(RNG) Result(x)
    Use Kinds, Only: dp
    Use Kinds, Only: id
    Implicit None
    Real(dp) :: x
    Class(ACORN_kp_Type), Intent(InOut) :: RNG
    Real(dp), Parameter :: inv_two53 = 2._dp**(-53)

    Call RNG%step()
    x = inv_two53 * Real( ISHFT(RNG%Y(1,RNG%k),-7) + 1_id , dp )
End Function rng_ACORN_r_e0i1_kp

Function rng_ACORN_r_i0i1_kp(RNG) Result(x)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: x
    Class(ACORN_kp_Type), Intent(InOut) :: RNG
    Real(dp), Parameter :: inv_two53m1 = 2._dp**(-53) - 1._dp

    Call RNG%step()
    x = inv_two53m1 * Real( ISHFT(RNG%Y(1,RNG%k),-7) , dp )
End Function rng_ACORN_r_i0i1_kp

Function rng_ACORN_r_e0e1_kp(RNG) Result(x)
    Use Kinds, Only: dp
    Use Kinds, Only: id
    Implicit None
    Real(dp) :: x
    Class(ACORN_kp_Type), Intent(InOut) :: RNG
    Integer(id) :: y
    Real(dp), Parameter :: inv_two53 = 2._dp**(-53)

    Call RNG%step()
    x = 0.5_dp + inv_two53 * Real( SHIFTA(ISHFT(RNG%Y(1,RNG%k),4),11) , dp )
End Function rng_ACORN_r_e0e1_kp

Function rng_ACORN_i32_kp(RNG) Result(y)
    Implicit None
    Integer :: y
    Class(ACORN_kp_Type), Intent(InOut) :: RNG

    Call RNG%step()
    y = INT( ISHFT(RNG%Y(1,RNG%k),-28) , il )
End Function rng_ACORN_i32_kp

Function rng_ACORN_i64_kp(RNG) Result(y)
    Use Kinds, Only: id
    Implicit None
    Integer(id) :: y
    Class(ACORN_kp_Type), Intent(InOut) :: RNG

    Call RNG%step()
    y = ISHFT(RNG%Y(1,RNG%k),4) + ISHFT(RNG%Y(2,RNG%k),-56)
End Function rng_ACORN_i64_kp

Subroutine seed_rng_ACORN(RNG,seed,burn)
    Use Kinds, Only: id
    Use Kinds, Only: dp
    Implicit None
    Class(ACORN_Type), Intent(InOut) :: RNG
    Integer, Intent(In) :: seed
    Integer, Intent(In), Optional :: burn
    Integer :: i

    RNG%Y = 0_id
    Call ACORN_seeds(aK,aP,RNG%Y,seed)
    RNG%seeded = .TRUE.
    If (Present(burn)) Then
        Do i = 1,burn
            Call RNG%step()
        End Do
    End If
End Subroutine seed_rng_ACORN

Subroutine step_rng_ACORN(RNG)
    !Use Kinds, Only: id
    Use Kinds, Only: dp
    Implicit None
    Class(ACORN_Type), Intent(InOut) :: RNG
    Integer :: k

    ASSOCIATE ( Y => RNG%Y )
    Do k = 1,aK
        Y(:,k) = Y(:,k) + Y(:,k-1)
        !If (Y(2,k) .GE. aM) Y(:,k) = Y(:,k) + (/ 1_id , -aM /)
        Y(1,k) = Y(1,k) + ISHFT( Y(2,k) , -aMp )
        Y(2,k) = IAND( Y(2,k) , aMm1 )
        !If (Y(1,k) .GE. aM) Y(1,k) = Y(1,k) - aM
        Y(1,k) = IAND( Y(1,k) , aMm1 )
    End Do
    END ASSOCIATE
End Subroutine step_rng_ACORN

Function rng_ACORN_r_i0e1(RNG) Result(x)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: x
    Class(ACORN_Type), Intent(InOut) :: RNG
    Real(dp), Parameter :: inv_two53 = 2._dp**(-53)

    Call RNG%step()
    x = inv_two53 * Real( ISHFT(RNG%Y(1,aK),-7) , dp )
End Function rng_ACORN_r_i0e1

Function rng_ACORN_r_e0i1(RNG) Result(x)
    Use Kinds, Only: dp
    Use Kinds, Only: id
    Implicit None
    Real(dp) :: x
    Class(ACORN_Type), Intent(InOut) :: RNG
    Real(dp), Parameter :: inv_two53 = 2._dp**(-53)

    Call RNG%step()
    x = inv_two53 * Real( ISHFT(RNG%Y(1,aK),-7) + 1_id , dp )
End Function rng_ACORN_r_e0i1

Function rng_ACORN_r_i0i1(RNG) Result(x)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: x
    Class(ACORN_Type), Intent(InOut) :: RNG
    Real(dp), Parameter :: inv_two53m1 = 2._dp**(-53) - 1._dp

    Call RNG%step()
    x = inv_two53m1 * Real( ISHFT(RNG%Y(1,aK),-7) , dp )
End Function rng_ACORN_r_i0i1

Function rng_ACORN_r_e0e1(RNG) Result(x)
    Use Kinds, Only: dp
    Use Kinds, Only: id
    Implicit None
    Real(dp) :: x
    Class(ACORN_Type), Intent(InOut) :: RNG
    Integer(id) :: y
    Real(dp), Parameter :: inv_two53 = 2._dp**(-53)

    Call RNG%step()
    x = 0.5_dp + inv_two53 * Real( SHIFTA(ISHFT(RNG%Y(1,aK),4),11) , dp )
End Function rng_ACORN_r_e0e1

Function rng_ACORN_i32(RNG) Result(y)
    Use Kinds, Only: il
    Implicit None
    Integer(il) :: y
    Class(ACORN_Type), Intent(InOut) :: RNG

    Call RNG%step()
    y = INT( ISHFT(RNG%Y(1,aK),-28) , il )
End Function rng_ACORN_i32

Function rng_ACORN_i64(RNG) Result(y)
    Use Kinds, Only: id
    Implicit None
    Integer(id) :: y
    Class(ACORN_Type), Intent(InOut) :: RNG

    Call RNG%step()
    y = ISHFT(RNG%Y(1,aK),4) + ISHFT(RNG%Y(2,aK),-56)
End Function rng_ACORN_i64

Subroutine save_RNG_ACORN(RNG,fname)
    Use FileIO_Utilities, Only: Var_to_file
    Implicit None
    Class(ACORN_Type), Intent(In) :: RNG
    Character(*), Intent(In) :: fname

    Call Var_to_File(RNG%Y,fname)
End Subroutine save_RNG_ACORN

Subroutine load_RNG_ACORN(RNG,fname)
    Use FileIO_Utilities, Only: Var_from_file
    Implicit None
    Class(ACORN_Type), Intent(InOut) :: RNG
    Character(*), Intent(In) :: fname

    Call Var_from_File(RNG%Y,fname)
    RNG%seeded = .TRUE.
End Subroutine load_RNG_ACORN

Subroutine randos(seed,n,Ys)
    !Grows a single seed into an array of seeds
    Implicit None
    Integer, Intent(In) :: seed
    Integer, Intent(In) :: n
    Integer, Intent(Out) :: Ys(1:n)
    Integer :: i,y

    !Initialize
    y = IEOR(777755555,Abs(seed))
    !Fill the array Ys using Marsaglia shift sequence with period 2**32 − 1.
    Do i = 1,n
        y = IEOR( y , ISHFT(y,13) )
        y = IEOR( y , ISHFT(y,-17) )
        y = IEOR( y , ISHFT(y,5) )
        Ys(i) = y
    End Do
End Subroutine randos

End Module PRNGs


*=======================================================================
*
* WCSLIB 4.24 - an implementation of the FITS WCS standard.
* Copyright (C) 1995-2014, Mark Calabretta
*
* This file is part of WCSLIB.
*
* WCSLIB is free software: you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* WCSLIB 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 Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with WCSLIB.  If not, see http://www.gnu.org/licenses.
*
* Direct correspondence concerning WCSLIB to mark@calabretta.id.au
*
* Author: Mark Calabretta, Australia Telescope National Facility, CSIRO.
* http://www.atnf.csiro.au/people/Mark.Calabretta
* $Id: tsph.f,v 4.24 2014/09/18 15:25:02 mcalabre Exp $
*=======================================================================

      PROGRAM TSPH
*-----------------------------------------------------------------------
*
* TSPH tests the forward and reverse spherical coordinate transformation
* routines for closure.
*
*-----------------------------------------------------------------------
      INTEGER   J, LAT, LNG, NFAIL, SPHS2X, SPHX2S, STATUS
      DOUBLE PRECISION COSLAT, DLAT, DLATMX, DLNG, DLNGMX, LNG1(361),
     :          LNG2(361), EUL(5), LAT1, LAT2(361), PHI(361),
     :          THETA(361), TOL, ZETA

      PARAMETER (TOL = 1D-12)

      DOUBLE PRECISION D2R, PI
      PARAMETER (PI = 3.141592653589793238462643D0)
      PARAMETER (D2R = PI/180D0)
*-----------------------------------------------------------------------
      WRITE (*, 10)
 10   FORMAT ('Testing closure of WCSLIB coordinate transformation ',
     :        'routines (tsph.f)',/,
     :        '----------------------------------------------------',
     :        '-----------------')

*     Set reference angles.
      EUL(1) =  90D0
      EUL(2) =  30D0
      EUL(3) = -90D0
      WRITE (*, 20) (EUL(J),J=1,3)
 20   FORMAT (/,'Celestial longitude and latitude of the native pole, ',
     :        'and native',/,'longitude of the celestial pole ',
     :        '(degrees):',3F10.4)

      EUL(4) = COS(EUL(2)*D2R)
      EUL(5) = SIN(EUL(2)*D2R)

      WRITE (*, 30) TOL
 30   FORMAT ('Reporting tolerance:',1PG8.1,' degrees of arc.')

      NFAIL  = 0
      DLNGMX = 0D0
      DLATMX = 0D0

      DO 70 LAT = 90, -90, -1
        LAT1 = DBLE(LAT)
        COSLAT = COS(LAT1*D2R)

        J = 1
        DO 40 LNG = -180, 180
          LNG1(J) = DBLE(LNG)
          J = J + 1
 40     CONTINUE

        STATUS = SPHS2X (EUL, 361, 1, 1, 1, LNG1, LAT1, PHI, THETA)
        STATUS = SPHX2S (EUL, 361, 0, 1, 1, PHI, THETA, LNG2, LAT2)

        DO 60 J = 1, 361
          DLNG = ABS(LNG2(J) - LNG1(J))
          IF (DLNG.GT.180D0) DLNG = ABS(DLNG-360D0)
          DLNG = DLNG*COSLAT
          DLAT = ABS(LAT2(J)-LAT1)

          IF (DLNG.GT.DLNGMX) DLNGMX = DLNG
          IF (DLAT.GT.DLATMX) DLATMX = DLAT

          IF (DLNG.GT.TOL .OR. DLAT.GT.TOL) THEN
            NFAIL = NFAIL + 1
            WRITE (*, 50) LNG1(J), LAT1, PHI(J), THETA(J), LNG2(J),
     :                    LAT2(J)
 50         FORMAT ('Unclosed: LNG1 =',F20.15,'  LAT1 =',F20.15,/,
     :              '           PHI =',F20.15,' THETA =',F20.15,/,
     :              '          LNG2 =',F20.15,'  LAT2 =',F20.15)
          END IF
 60     CONTINUE
 70   CONTINUE

*     Test closure at points close to the pole.
      DO 90 J = -1, 1, 2
        ZETA = 1D0
        LNG1(1) = -180D0

        DO 80 LAT = 1, 12
          LAT1 = DBLE(J)*(90D0 - ZETA)

          STATUS = SPHS2X (EUL, 1, 1, 1, 1, LNG1, LAT1, PHI, THETA)
          STATUS = SPHX2S (EUL, 1, 1, 1, 1, PHI, THETA, LNG2, LAT2)

          DLNG = ABS(LNG2(1) - LNG1(1))
          IF (DLNG.GT.180D0) DLNG = ABS(DLNG-360D0)
          DLNG = DLNG*COSLAT
          DLAT = ABS(LAT2(1)-LAT1)

          IF (DLNG.GT.DLNGMX) DLNGMX = DLNG
          IF (DLAT.GT.DLATMX) DLATMX = DLAT

          IF (DLNG.GT.TOL .OR. DLAT.GT.TOL) THEN
            NFAIL = NFAIL + 1
            WRITE (*, 50) LNG1(1), LAT1, PHI(1), THETA(1), LNG2(1),
     :                    LAT2(1)
          END IF

          ZETA = ZETA/10D0
          LNG1(1) = LNG1(1) + 30D0
 80     CONTINUE
 90   CONTINUE

      WRITE (*, 100) DLNGMX, DLATMX
 100  FORMAT (/,'SPHS2X/SPHX2S: Maximum closure residual =',1P,E8.1,
     :  ' (lng)',E8.1,' (lat) deg.')

      IF (NFAIL.NE.0) THEN
        WRITE (*, 110) NFAIL
 110    FORMAT (/,'FAIL:',I5,' closure residuals exceed reporting ',
     :    'tolerance.')
      ELSE
        WRITE (*, 120)
 120    FORMAT (/,'PASS: All closure residuals are within reporting ',
     :    'tolerance.')
      END IF

      END


*> \brief \b SLARRE given the tridiagonal matrix T, sets small off-diagonal elements to zero and for each unreduced block Ti, finds base representations and eigenvalues.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLARRE + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2,
*                           RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M,
*                           W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN,
*                           WORK, IWORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          RANGE
*       INTEGER            IL, INFO, IU, M, N, NSPLIT
*       REAL               PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU
*       ..
*       .. Array Arguments ..
*       INTEGER            IBLOCK( * ), ISPLIT( * ), IWORK( * ),
*      $                   INDEXW( * )
*       REAL               D( * ), E( * ), E2( * ), GERS( * ),
*      $                   W( * ),WERR( * ), WGAP( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> To find the desired eigenvalues of a given real symmetric
*> tridiagonal matrix T, SLARRE sets any "small" off-diagonal
*> elements to zero, and for each unreduced block T_i, it finds
*> (a) a suitable shift at one end of the block's spectrum,
*> (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and
*> (c) eigenvalues of each L_i D_i L_i^T.
*> The representations and eigenvalues found are then used by
*> SSTEMR to compute the eigenvectors of T.
*> The accuracy varies depending on whether bisection is used to
*> find a few eigenvalues or the dqds algorithm (subroutine SLASQ2) to
*> conpute all and then discard any unwanted one.
*> As an added benefit, SLARRE also outputs the n
*> Gerschgorin intervals for the matrices L_i D_i L_i^T.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] RANGE
*> \verbatim
*>          RANGE is CHARACTER*1
*>          = 'A': ("All")   all eigenvalues will be found.
*>          = 'V': ("Value") all eigenvalues in the half-open interval
*>                           (VL, VU] will be found.
*>          = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
*>                           entire matrix) will be found.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix. N > 0.
*> \endverbatim
*>
*> \param[in,out] VL
*> \verbatim
*>          VL is REAL
*>          If RANGE='V', the lower bound for the eigenvalues.
*>          Eigenvalues less than or equal to VL, or greater than VU,
*>          will not be returned.  VL < VU.
*>          If RANGE='I' or ='A', SLARRE computes bounds on the desired
*>          part of the spectrum.
*> \endverbatim
*>
*> \param[in,out] VU
*> \verbatim
*>          VU is REAL
*>          If RANGE='V', the upper bound for the eigenvalues.
*>          Eigenvalues less than or equal to VL, or greater than VU,
*>          will not be returned.  VL < VU.
*>          If RANGE='I' or ='A', SLARRE computes bounds on the desired
*>          part of the spectrum.
*> \endverbatim
*>
*> \param[in] IL
*> \verbatim
*>          IL is INTEGER
*>          If RANGE='I', the index of the
*>          smallest eigenvalue to be returned.
*>          1 <= IL <= IU <= N.
*> \endverbatim
*>
*> \param[in] IU
*> \verbatim
*>          IU is INTEGER
*>          If RANGE='I', the index of the
*>          largest eigenvalue to be returned.
*>          1 <= IL <= IU <= N.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*>          D is REAL array, dimension (N)
*>          On entry, the N diagonal elements of the tridiagonal
*>          matrix T.
*>          On exit, the N diagonal elements of the diagonal
*>          matrices D_i.
*> \endverbatim
*>
*> \param[in,out] E
*> \verbatim
*>          E is REAL array, dimension (N)
*>          On entry, the first (N-1) entries contain the subdiagonal
*>          elements of the tridiagonal matrix T; E(N) need not be set.
*>          On exit, E contains the subdiagonal elements of the unit
*>          bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),
*>          1 <= I <= NSPLIT, contain the base points sigma_i on output.
*> \endverbatim
*>
*> \param[in,out] E2
*> \verbatim
*>          E2 is REAL array, dimension (N)
*>          On entry, the first (N-1) entries contain the SQUARES of the
*>          subdiagonal elements of the tridiagonal matrix T;
*>          E2(N) need not be set.
*>          On exit, the entries E2( ISPLIT( I ) ),
*>          1 <= I <= NSPLIT, have been set to zero
*> \endverbatim
*>
*> \param[in] RTOL1
*> \verbatim
*>          RTOL1 is REAL
*> \endverbatim
*>
*> \param[in] RTOL2
*> \verbatim
*>          RTOL2 is REAL
*>           Parameters for bisection.
*>           An interval [LEFT,RIGHT] has converged if
*>           RIGHT-LEFT < MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
*> \endverbatim
*>
*> \param[in] SPLTOL
*> \verbatim
*>          SPLTOL is REAL
*>          The threshold for splitting.
*> \endverbatim
*>
*> \param[out] NSPLIT
*> \verbatim
*>          NSPLIT is INTEGER
*>          The number of blocks T splits into. 1 <= NSPLIT <= N.
*> \endverbatim
*>
*> \param[out] ISPLIT
*> \verbatim
*>          ISPLIT is INTEGER array, dimension (N)
*>          The splitting points, at which T breaks up into blocks.
*>          The first block consists of rows/columns 1 to ISPLIT(1),
*>          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
*>          etc., and the NSPLIT-th consists of rows/columns
*>          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
*> \endverbatim
*>
*> \param[out] M
*> \verbatim
*>          M is INTEGER
*>          The total number of eigenvalues (of all L_i D_i L_i^T)
*>          found.
*> \endverbatim
*>
*> \param[out] W
*> \verbatim
*>          W is REAL array, dimension (N)
*>          The first M elements contain the eigenvalues. The
*>          eigenvalues of each of the blocks, L_i D_i L_i^T, are
*>          sorted in ascending order ( SLARRE may use the
*>          remaining N-M elements as workspace).
*> \endverbatim
*>
*> \param[out] WERR
*> \verbatim
*>          WERR is REAL array, dimension (N)
*>          The error bound on the corresponding eigenvalue in W.
*> \endverbatim
*>
*> \param[out] WGAP
*> \verbatim
*>          WGAP is REAL array, dimension (N)
*>          The separation from the right neighbor eigenvalue in W.
*>          The gap is only with respect to the eigenvalues of the same block
*>          as each block has its own representation tree.
*>          Exception: at the right end of a block we store the left gap
*> \endverbatim
*>
*> \param[out] IBLOCK
*> \verbatim
*>          IBLOCK is INTEGER array, dimension (N)
*>          The indices of the blocks (submatrices) associated with the
*>          corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
*>          W(i) belongs to the first block from the top, =2 if W(i)
*>          belongs to the second block, etc.
*> \endverbatim
*>
*> \param[out] INDEXW
*> \verbatim
*>          INDEXW is INTEGER array, dimension (N)
*>          The indices of the eigenvalues within each block (submatrix);
*>          for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
*>          i-th eigenvalue W(i) is the 10-th eigenvalue in block 2
*> \endverbatim
*>
*> \param[out] GERS
*> \verbatim
*>          GERS is REAL array, dimension (2*N)
*>          The N Gerschgorin intervals (the i-th Gerschgorin interval
*>          is (GERS(2*i-1), GERS(2*i)).
*> \endverbatim
*>
*> \param[out] PIVMIN
*> \verbatim
*>          PIVMIN is REAL
*>          The minimum pivot in the Sturm sequence for T.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (6*N)
*>          Workspace.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (5*N)
*>          Workspace.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          > 0:  A problem occurred in SLARRE.
*>          < 0:  One of the called subroutines signaled an internal problem.
*>                Needs inspection of the corresponding parameter IINFO
*>                for further information.
*>
*>          =-1:  Problem in SLARRD.
*>          = 2:  No base representation could be found in MAXTRY iterations.
*>                Increasing MAXTRY and recompilation might be a remedy.
*>          =-3:  Problem in SLARRB when computing the refined root
*>                representation for SLASQ2.
*>          =-4:  Problem in SLARRB when preforming bisection on the
*>                desired part of the spectrum.
*>          =-5:  Problem in SLASQ2.
*>          =-6:  Problem in SLASQ2.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup OTHERauxiliary
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The base representations are required to suffer very little
*>  element growth and consequently define all their eigenvalues to
*>  high relative accuracy.
*> \endverbatim
*
*> \par Contributors:
*  ==================
*>
*>     Beresford Parlett, University of California, Berkeley, USA \n
*>     Jim Demmel, University of California, Berkeley, USA \n
*>     Inderjit Dhillon, University of Texas, Austin, USA \n
*>     Osni Marques, LBNL/NERSC, USA \n
*>     Christof Voemel, University of California, Berkeley, USA \n
*>
*  =====================================================================
      SUBROUTINE SLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2,
     $                    RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M,
     $                    W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN,
     $                    WORK, IWORK, INFO )
*
*  -- LAPACK auxiliary routine (version 3.8.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     June 2016
*
*     .. Scalar Arguments ..
      CHARACTER          RANGE
      INTEGER            IL, INFO, IU, M, N, NSPLIT
      REAL               PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU
*     ..
*     .. Array Arguments ..
      INTEGER            IBLOCK( * ), ISPLIT( * ), IWORK( * ),
     $                   INDEXW( * )
      REAL               D( * ), E( * ), E2( * ), GERS( * ),
     $                   W( * ),WERR( * ), WGAP( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               FAC, FOUR, FOURTH, FUDGE, HALF, HNDRD,
     $                   MAXGROWTH, ONE, PERT, TWO, ZERO
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0,
     $                     TWO = 2.0E0, FOUR=4.0E0,
     $                     HNDRD = 100.0E0,
     $                     PERT = 4.0E0,
     $                     HALF = ONE/TWO, FOURTH = ONE/FOUR, FAC= HALF,
     $                     MAXGROWTH = 64.0E0, FUDGE = 2.0E0 )
      INTEGER            MAXTRY, ALLRNG, INDRNG, VALRNG
      PARAMETER          ( MAXTRY = 6, ALLRNG = 1, INDRNG = 2,
     $                     VALRNG = 3 )
*     ..
*     .. Local Scalars ..
      LOGICAL            FORCEB, NOREP, USEDQD
      INTEGER            CNT, CNT1, CNT2, I, IBEGIN, IDUM, IEND, IINFO,
     $                   IN, INDL, INDU, IRANGE, J, JBLK, MB, MM,
     $                   WBEGIN, WEND
      REAL               AVGAP, BSRTOL, CLWDTH, DMAX, DPIVOT, EABS,
     $                   EMAX, EOLD, EPS, GL, GU, ISLEFT, ISRGHT, RTL,
     $                   RTOL, S1, S2, SAFMIN, SGNDEF, SIGMA, SPDIAM,
     $                   TAU, TMP, TMP1

*     ..
*     .. Local Arrays ..
      INTEGER            ISEED( 4 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL                        SLAMCH
      EXTERNAL           SLAMCH, LSAME

*     ..
*     .. External Subroutines ..
      EXTERNAL           SCOPY, SLARNV, SLARRA, SLARRB, SLARRC, SLARRD,
     $                   SLASQ2, SLARRK
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN

*     ..
*     .. Executable Statements ..
*

      INFO = 0
*
*     Quick return if possible
*
      IF( N.LE.0 ) THEN
         RETURN
      END IF
*
*     Decode RANGE
*
      IF( LSAME( RANGE, 'A' ) ) THEN
         IRANGE = ALLRNG
      ELSE IF( LSAME( RANGE, 'V' ) ) THEN
         IRANGE = VALRNG
      ELSE IF( LSAME( RANGE, 'I' ) ) THEN
         IRANGE = INDRNG
      END IF

      M = 0

*     Get machine constants
      SAFMIN = SLAMCH( 'S' )
      EPS = SLAMCH( 'P' )

*     Set parameters
      RTL = HNDRD*EPS
*     If one were ever to ask for less initial precision in BSRTOL,
*     one should keep in mind that for the subset case, the extremal
*     eigenvalues must be at least as accurate as the current setting
*     (eigenvalues in the middle need not as much accuracy)
      BSRTOL = SQRT(EPS)*(0.5E-3)

*     Treat case of 1x1 matrix for quick return
      IF( N.EQ.1 ) THEN
         IF( (IRANGE.EQ.ALLRNG).OR.
     $       ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
     $       ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN
            M = 1
            W(1) = D(1)
*           The computation error of the eigenvalue is zero
            WERR(1) = ZERO
            WGAP(1) = ZERO
            IBLOCK( 1 ) = 1
            INDEXW( 1 ) = 1
            GERS(1) = D( 1 )
            GERS(2) = D( 1 )
         ENDIF
*        store the shift for the initial RRR, which is zero in this case
         E(1) = ZERO
         RETURN
      END IF

*     General case: tridiagonal matrix of order > 1
*
*     Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter.
*     Compute maximum off-diagonal entry and pivmin.
      GL = D(1)
      GU = D(1)
      EOLD = ZERO
      EMAX = ZERO
      E(N) = ZERO
      DO 5 I = 1,N
         WERR(I) = ZERO
         WGAP(I) = ZERO
         EABS = ABS( E(I) )
         IF( EABS .GE. EMAX ) THEN
            EMAX = EABS
         END IF
         TMP1 = EABS + EOLD
         GERS( 2*I-1) = D(I) - TMP1
         GL =  MIN( GL, GERS( 2*I - 1))
         GERS( 2*I ) = D(I) + TMP1
         GU = MAX( GU, GERS(2*I) )
         EOLD  = EABS
 5    CONTINUE
*     The minimum pivot allowed in the Sturm sequence for T
      PIVMIN = SAFMIN * MAX( ONE, EMAX**2 )
*     Compute spectral diameter. The Gerschgorin bounds give an
*     estimate that is wrong by at most a factor of SQRT(2)
      SPDIAM = GU - GL

*     Compute splitting points
      CALL SLARRA( N, D, E, E2, SPLTOL, SPDIAM,
     $                    NSPLIT, ISPLIT, IINFO )

*     Can force use of bisection instead of faster DQDS.
*     Option left in the code for future multisection work.
      FORCEB = .FALSE.

*     Initialize USEDQD, DQDS should be used for ALLRNG unless someone
*     explicitly wants bisection.
      USEDQD = (( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB))

      IF( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ) THEN
*        Set interval [VL,VU] that contains all eigenvalues
         VL = GL
         VU = GU
      ELSE
*        We call SLARRD to find crude approximations to the eigenvalues
*        in the desired range. In case IRANGE = INDRNG, we also obtain the
*        interval (VL,VU] that contains all the wanted eigenvalues.
*        An interval [LEFT,RIGHT] has converged if
*        RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT))
*        SLARRD needs a WORK of size 4*N, IWORK of size 3*N
         CALL SLARRD( RANGE, 'B', N, VL, VU, IL, IU, GERS,
     $                    BSRTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT,
     $                    MM, W, WERR, VL, VU, IBLOCK, INDEXW,
     $                    WORK, IWORK, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = -1
            RETURN
         ENDIF
*        Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0
         DO 14 I = MM+1,N
            W( I ) = ZERO
            WERR( I ) = ZERO
            IBLOCK( I ) = 0
            INDEXW( I ) = 0
 14      CONTINUE
      END IF

***
*     Loop over unreduced blocks
      IBEGIN = 1
      WBEGIN = 1
      DO 170 JBLK = 1, NSPLIT
         IEND = ISPLIT( JBLK )
         IN = IEND - IBEGIN + 1

*        1 X 1 block
         IF( IN.EQ.1 ) THEN
            IF( (IRANGE.EQ.ALLRNG).OR.( (IRANGE.EQ.VALRNG).AND.
     $         ( D( IBEGIN ).GT.VL ).AND.( D( IBEGIN ).LE.VU ) )
     $        .OR. ( (IRANGE.EQ.INDRNG).AND.(IBLOCK(WBEGIN).EQ.JBLK))
     $        ) THEN
               M = M + 1
               W( M ) = D( IBEGIN )
               WERR(M) = ZERO
*              The gap for a single block doesn't matter for the later
*              algorithm and is assigned an arbitrary large value
               WGAP(M) = ZERO
               IBLOCK( M ) = JBLK
               INDEXW( M ) = 1
               WBEGIN = WBEGIN + 1
            ENDIF
*           E( IEND ) holds the shift for the initial RRR
            E( IEND ) = ZERO
            IBEGIN = IEND + 1
            GO TO 170
         END IF
*
*        Blocks of size larger than 1x1
*
*        E( IEND ) will hold the shift for the initial RRR, for now set it =0
         E( IEND ) = ZERO
*
*        Find local outer bounds GL,GU for the block
         GL = D(IBEGIN)
         GU = D(IBEGIN)
         DO 15 I = IBEGIN , IEND
            GL = MIN( GERS( 2*I-1 ), GL )
            GU = MAX( GERS( 2*I ), GU )
 15      CONTINUE
         SPDIAM = GU - GL

         IF(.NOT. ((IRANGE.EQ.ALLRNG).AND.(.NOT.FORCEB)) ) THEN
*           Count the number of eigenvalues in the current block.
            MB = 0
            DO 20 I = WBEGIN,MM
               IF( IBLOCK(I).EQ.JBLK ) THEN
                  MB = MB+1
               ELSE
                  GOTO 21
               ENDIF
 20         CONTINUE
 21         CONTINUE

            IF( MB.EQ.0) THEN
*              No eigenvalue in the current block lies in the desired range
*              E( IEND ) holds the shift for the initial RRR
               E( IEND ) = ZERO
               IBEGIN = IEND + 1
               GO TO 170
            ELSE

*              Decide whether dqds or bisection is more efficient
               USEDQD = ( (MB .GT. FAC*IN) .AND. (.NOT.FORCEB) )
               WEND = WBEGIN + MB - 1
*              Calculate gaps for the current block
*              In later stages, when representations for individual
*              eigenvalues are different, we use SIGMA = E( IEND ).
               SIGMA = ZERO
               DO 30 I = WBEGIN, WEND - 1
                  WGAP( I ) = MAX( ZERO,
     $                        W(I+1)-WERR(I+1) - (W(I)+WERR(I)) )
 30            CONTINUE
               WGAP( WEND ) = MAX( ZERO,
     $                     VU - SIGMA - (W( WEND )+WERR( WEND )))
*              Find local index of the first and last desired evalue.
               INDL = INDEXW(WBEGIN)
               INDU = INDEXW( WEND )
            ENDIF
         ENDIF
         IF(( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ).OR.USEDQD) THEN
*           Case of DQDS
*           Find approximations to the extremal eigenvalues of the block
            CALL SLARRK( IN, 1, GL, GU, D(IBEGIN),
     $               E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO )
            IF( IINFO.NE.0 ) THEN
               INFO = -1
               RETURN
            ENDIF
            ISLEFT = MAX(GL, TMP - TMP1
     $               - HNDRD * EPS* ABS(TMP - TMP1))

            CALL SLARRK( IN, IN, GL, GU, D(IBEGIN),
     $               E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO )
            IF( IINFO.NE.0 ) THEN
               INFO = -1
               RETURN
            ENDIF
            ISRGHT = MIN(GU, TMP + TMP1
     $                 + HNDRD * EPS * ABS(TMP + TMP1))
*           Improve the estimate of the spectral diameter
            SPDIAM = ISRGHT - ISLEFT
         ELSE
*           Case of bisection
*           Find approximations to the wanted extremal eigenvalues
            ISLEFT = MAX(GL, W(WBEGIN) - WERR(WBEGIN)
     $                  - HNDRD * EPS*ABS(W(WBEGIN)- WERR(WBEGIN) ))
            ISRGHT = MIN(GU,W(WEND) + WERR(WEND)
     $                  + HNDRD * EPS * ABS(W(WEND)+ WERR(WEND)))
         ENDIF

*        Decide whether the base representation for the current block
*        L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I
*        should be on the left or the right end of the current block.
*        The strategy is to shift to the end which is "more populated"
*        Furthermore, decide whether to use DQDS for the computation of
*        the eigenvalue approximations at the end of SLARRE or bisection.
*        dqds is chosen if all eigenvalues are desired or the number of
*        eigenvalues to be computed is large compared to the blocksize.
         IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
*           If all the eigenvalues have to be computed, we use dqd
            USEDQD = .TRUE.
*           INDL is the local index of the first eigenvalue to compute
            INDL = 1
            INDU = IN
*           MB =  number of eigenvalues to compute
            MB = IN
            WEND = WBEGIN + MB - 1
*           Define 1/4 and 3/4 points of the spectrum
            S1 = ISLEFT + FOURTH * SPDIAM
            S2 = ISRGHT - FOURTH * SPDIAM
         ELSE
*           SLARRD has computed IBLOCK and INDEXW for each eigenvalue
*           approximation.
*           choose sigma
            IF( USEDQD ) THEN
               S1 = ISLEFT + FOURTH * SPDIAM
               S2 = ISRGHT - FOURTH * SPDIAM
            ELSE
               TMP = MIN(ISRGHT,VU) -  MAX(ISLEFT,VL)
               S1 =  MAX(ISLEFT,VL) + FOURTH * TMP
               S2 =  MIN(ISRGHT,VU) - FOURTH * TMP
            ENDIF
         ENDIF

*        Compute the negcount at the 1/4 and 3/4 points
         IF(MB.GT.1) THEN
            CALL SLARRC( 'T', IN, S1, S2, D(IBEGIN),
     $                    E(IBEGIN), PIVMIN, CNT, CNT1, CNT2, IINFO)
         ENDIF

         IF(MB.EQ.1) THEN
            SIGMA = GL
            SGNDEF = ONE
         ELSEIF( CNT1 - INDL .GE. INDU - CNT2 ) THEN
            IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
               SIGMA = MAX(ISLEFT,GL)
            ELSEIF( USEDQD ) THEN
*              use Gerschgorin bound as shift to get pos def matrix
*              for dqds
               SIGMA = ISLEFT
            ELSE
*              use approximation of the first desired eigenvalue of the
*              block as shift
               SIGMA = MAX(ISLEFT,VL)
            ENDIF
            SGNDEF = ONE
         ELSE
            IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
               SIGMA = MIN(ISRGHT,GU)
            ELSEIF( USEDQD ) THEN
*              use Gerschgorin bound as shift to get neg def matrix
*              for dqds
               SIGMA = ISRGHT
            ELSE
*              use approximation of the first desired eigenvalue of the
*              block as shift
               SIGMA = MIN(ISRGHT,VU)
            ENDIF
            SGNDEF = -ONE
         ENDIF

*        An initial SIGMA has been chosen that will be used for computing
*        T - SIGMA I = L D L^T
*        Define the increment TAU of the shift in case the initial shift
*        needs to be refined to obtain a factorization with not too much
*        element growth.
         IF( USEDQD ) THEN
*           The initial SIGMA was to the outer end of the spectrum
*           the matrix is definite and we need not retreat.
            TAU = SPDIAM*EPS*N + TWO*PIVMIN
            TAU = MAX( TAU,TWO*EPS*ABS(SIGMA) )
         ELSE
            IF(MB.GT.1) THEN
               CLWDTH = W(WEND) + WERR(WEND) - W(WBEGIN) - WERR(WBEGIN)
               AVGAP = ABS(CLWDTH / REAL(WEND-WBEGIN))
               IF( SGNDEF.EQ.ONE ) THEN
                  TAU = HALF*MAX(WGAP(WBEGIN),AVGAP)
                  TAU = MAX(TAU,WERR(WBEGIN))
               ELSE
                  TAU = HALF*MAX(WGAP(WEND-1),AVGAP)
                  TAU = MAX(TAU,WERR(WEND))
               ENDIF
            ELSE
               TAU = WERR(WBEGIN)
            ENDIF
         ENDIF
*
         DO 80 IDUM = 1, MAXTRY
*           Compute L D L^T factorization of tridiagonal matrix T - sigma I.
*           Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of
*           pivots in WORK(2*IN+1:3*IN)
            DPIVOT = D( IBEGIN ) - SIGMA
            WORK( 1 ) = DPIVOT
            DMAX = ABS( WORK(1) )
            J = IBEGIN
            DO 70 I = 1, IN - 1
               WORK( 2*IN+I ) = ONE / WORK( I )
               TMP = E( J )*WORK( 2*IN+I )
               WORK( IN+I ) = TMP
               DPIVOT = ( D( J+1 )-SIGMA ) - TMP*E( J )
               WORK( I+1 ) = DPIVOT
               DMAX = MAX( DMAX, ABS(DPIVOT) )
               J = J + 1
 70         CONTINUE
*           check for element growth
            IF( DMAX .GT. MAXGROWTH*SPDIAM ) THEN
               NOREP = .TRUE.
            ELSE
               NOREP = .FALSE.
            ENDIF
            IF( USEDQD .AND. .NOT.NOREP ) THEN
*              Ensure the definiteness of the representation
*              All entries of D (of L D L^T) must have the same sign
               DO 71 I = 1, IN
                  TMP = SGNDEF*WORK( I )
                  IF( TMP.LT.ZERO ) NOREP = .TRUE.
 71            CONTINUE
            ENDIF
            IF(NOREP) THEN
*              Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin
*              shift which makes the matrix definite. So we should end up
*              here really only in the case of IRANGE = VALRNG or INDRNG.
               IF( IDUM.EQ.MAXTRY-1 ) THEN
                  IF( SGNDEF.EQ.ONE ) THEN
*                    The fudged Gerschgorin shift should succeed
                     SIGMA =
     $                    GL - FUDGE*SPDIAM*EPS*N - FUDGE*TWO*PIVMIN
                  ELSE
                     SIGMA =
     $                    GU + FUDGE*SPDIAM*EPS*N + FUDGE*TWO*PIVMIN
                  END IF
               ELSE
                  SIGMA = SIGMA - SGNDEF * TAU
                  TAU = TWO * TAU
               END IF
            ELSE
*              an initial RRR is found
               GO TO 83
            END IF
 80      CONTINUE
*        if the program reaches this point, no base representation could be
*        found in MAXTRY iterations.
         INFO = 2
         RETURN

 83      CONTINUE
*        At this point, we have found an initial base representation
*        T - SIGMA I = L D L^T with not too much element growth.
*        Store the shift.
         E( IEND ) = SIGMA
*        Store D and L.
         CALL SCOPY( IN, WORK, 1, D( IBEGIN ), 1 )
         CALL SCOPY( IN-1, WORK( IN+1 ), 1, E( IBEGIN ), 1 )

         IF(MB.GT.1 ) THEN
*
*           Perturb each entry of the base representation by a small
*           (but random) relative amount to overcome difficulties with
*           glued matrices.
*
            DO 122 I = 1, 4
               ISEED( I ) = 1
 122        CONTINUE

            CALL SLARNV(2, ISEED, 2*IN-1, WORK(1))
            DO 125 I = 1,IN-1
               D(IBEGIN+I-1) = D(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(I))
               E(IBEGIN+I-1) = E(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(IN+I))
 125        CONTINUE
            D(IEND) = D(IEND)*(ONE+EPS*FOUR*WORK(IN))
*
         ENDIF
*
*        Don't update the Gerschgorin intervals because keeping track
*        of the updates would be too much work in SLARRV.
*        We update W instead and use it to locate the proper Gerschgorin
*        intervals.

*        Compute the required eigenvalues of L D L' by bisection or dqds
         IF ( .NOT.USEDQD ) THEN
*           If SLARRD has been used, shift the eigenvalue approximations
*           according to their representation. This is necessary for
*           a uniform SLARRV since dqds computes eigenvalues of the
*           shifted representation. In SLARRV, W will always hold the
*           UNshifted eigenvalue approximation.
            DO 134 J=WBEGIN,WEND
               W(J) = W(J) - SIGMA
               WERR(J) = WERR(J) + ABS(W(J)) * EPS
 134        CONTINUE
*           call SLARRB to reduce eigenvalue error of the approximations
*           from SLARRD
            DO 135 I = IBEGIN, IEND-1
               WORK( I ) = D( I ) * E( I )**2
 135        CONTINUE
*           use bisection to find EV from INDL to INDU
            CALL SLARRB(IN, D(IBEGIN), WORK(IBEGIN),
     $                  INDL, INDU, RTOL1, RTOL2, INDL-1,
     $                  W(WBEGIN), WGAP(WBEGIN), WERR(WBEGIN),
     $                  WORK( 2*N+1 ), IWORK, PIVMIN, SPDIAM,
     $                  IN, IINFO )
            IF( IINFO .NE. 0 ) THEN
               INFO = -4
               RETURN
            END IF
*           SLARRB computes all gaps correctly except for the last one
*           Record distance to VU/GU
            WGAP( WEND ) = MAX( ZERO,
     $           ( VU-SIGMA ) - ( W( WEND ) + WERR( WEND ) ) )
            DO 138 I = INDL, INDU
               M = M + 1
               IBLOCK(M) = JBLK
               INDEXW(M) = I
 138        CONTINUE
         ELSE
*           Call dqds to get all eigs (and then possibly delete unwanted
*           eigenvalues).
*           Note that dqds finds the eigenvalues of the L D L^T representation
*           of T to high relative accuracy. High relative accuracy
*           might be lost when the shift of the RRR is subtracted to obtain
*           the eigenvalues of T. However, T is not guaranteed to define its
*           eigenvalues to high relative accuracy anyway.
*           Set RTOL to the order of the tolerance used in SLASQ2
*           This is an ESTIMATED error, the worst case bound is 4*N*EPS
*           which is usually too large and requires unnecessary work to be
*           done by bisection when computing the eigenvectors
            RTOL = LOG(REAL(IN)) * FOUR * EPS
            J = IBEGIN
            DO 140 I = 1, IN - 1
               WORK( 2*I-1 ) = ABS( D( J ) )
               WORK( 2*I ) = E( J )*E( J )*WORK( 2*I-1 )
               J = J + 1
  140       CONTINUE
            WORK( 2*IN-1 ) = ABS( D( IEND ) )
            WORK( 2*IN ) = ZERO
            CALL SLASQ2( IN, WORK, IINFO )
            IF( IINFO .NE. 0 ) THEN
*              If IINFO = -5 then an index is part of a tight cluster
*              and should be changed. The index is in IWORK(1) and the
*              gap is in WORK(N+1)
               INFO = -5
               RETURN
            ELSE
*              Test that all eigenvalues are positive as expected
               DO 149 I = 1, IN
                  IF( WORK( I ).LT.ZERO ) THEN
                     INFO = -6
                     RETURN
                  ENDIF
 149           CONTINUE
            END IF
            IF( SGNDEF.GT.ZERO ) THEN
               DO 150 I = INDL, INDU
                  M = M + 1
                  W( M ) = WORK( IN-I+1 )
                  IBLOCK( M ) = JBLK
                  INDEXW( M ) = I
 150           CONTINUE
            ELSE
               DO 160 I = INDL, INDU
                  M = M + 1
                  W( M ) = -WORK( I )
                  IBLOCK( M ) = JBLK
                  INDEXW( M ) = I
 160           CONTINUE
            END IF

            DO 165 I = M - MB + 1, M
*              the value of RTOL below should be the tolerance in SLASQ2
               WERR( I ) = RTOL * ABS( W(I) )
 165        CONTINUE
            DO 166 I = M - MB + 1, M - 1
*              compute the right gap between the intervals
               WGAP( I ) = MAX( ZERO,
     $                          W(I+1)-WERR(I+1) - (W(I)+WERR(I)) )
 166        CONTINUE
            WGAP( M ) = MAX( ZERO,
     $           ( VU-SIGMA ) - ( W( M ) + WERR( M ) ) )
         END IF
*        proceed with next block
         IBEGIN = IEND + 1
         WBEGIN = WEND + 1
 170  CONTINUE
*

      RETURN
*
*     end of SLARRE
*
      END


module GwfStorageUtilsModule

  use KindModule, only: DP, I4B
  use ConstantsModule, only: DONE

  implicit none
  private
  public :: SsCapacity
  public :: SyCapacity

contains

  !> @brief Calculate the specific storage capacity
  !!
  !! Function to calculate the specific storage capacity using
  !! the cell geometry and the specific storage or storage coefficient.
  !!
  !! @return      sc1               specific storage capacity
  !<
  pure function SsCapacity(istor_coef, top, bot, area, ss) result(sc1)
    ! -- dummy variables
    integer(I4B), intent(in) :: istor_coef  !< flag indicating if ss is the storage coefficient
    real(DP), intent(in) :: top             !< top of cell
    real(DP), intent(in) :: bot             !< bottom of cell
    real(DP), intent(in) :: area            !< horizontal cell area
    real(DP), intent(in) :: ss              !< specific storage or storage coefficient
    ! -- local variables
    real(DP) :: sc1
    real(DP) :: thick
    ! -- calculate specific storage capacity
    if (istor_coef == 0) then
      thick = top - bot
    else
      thick = DONE
    end if
    sc1 = ss*thick*area
    !
    ! -- return
    return
  end function SsCapacity

  !> @brief Calculate the specific yield capacity
  !!
  !! Function to calculate the specific yield capacity using
  !! the cell area and the specific yield.
  !!
  !! @return      sc2               specific yield capacity
  !<
  pure function SyCapacity(area, sy) result(sc2)
    ! -- dummy variables
    real(DP), intent(in) :: area       !< horizontal cell area
    real(DP), intent(in) :: sy         !< specific yield
    ! -- local variables
    real(DP) :: sc2
    ! -- calculate specific yield capacity
    sc2 = sy*area
    !
    ! -- return
    return
  end function SyCapacity

end module GwfStorageUtilsModule